File Coverage

lib/WWW/Lengthen.pm

Criterion	Covered	Total	%
statement	9	50	18.0
branch	0	24	0.0
condition	0	6	0.0
subroutine	3	8	37.5
pod	4	4	100.0
total	16	92	17.3

package WWW::Lengthen;

use strict;
use warnings;
use LWP::UserAgent;

our $VERSION = '0.09';

our %KnownServices = (
  '0rz'            => qr{^https?://0rz\.tw/.+},
  Metamark         => qr{^https?://xrl\.us/.+},
  SnipURL          => qr{^https?://snipurl\.com/.+},
  TinyURL          => qr{^https?://tinyurl\.com/.+},
  snurl            => qr{^https?://snurl\.com/.+},
  bitly            => qr{^https?://bit\.ly/.+},
  htly             => qr{^https?://ht\.ly/.+},
  isgd             => qr{^https?://is\.gd/.+},
  owly             => qr{^https?://ow\.ly/.+},
  urlchen          => qr{^https?://urlchen\.de/.+},
  google           => qr{^https?://goo\.gl/.+},
);

# Can't test, but widely used
our %PartOfOtherServices = (
  twitterco        => qr{^https?://t\.co/.+},
  hatena           => qr{^https?://htn\.to/.+},
  jmp              => qr{^https?://j\.mp/.+},
  tumblr           => qr{^https?://tmblr\.co/.+},
  facebook         => qr{^https?://fb\.me/.+},
);

our %ExtraServices = (
  Shorl            => [ qr{^https?://shorl\.com/.+}, 'Shorl' ],
);

# not only dead but also failed anyhow when I tested
our %UnsupportedOrDeadServices = (
  icanhaz          => qr{^https?://icanhaz\.com/.+},
  urlTea           => qr{^https?://urltea\.com/.+},
  BabyURL          => qr{^https?://babyurl\.com/.+},
  Linkz            => qr{^https?://lin\.kz/?\?.+},
  TinyClick        => qr{^https?://tinyclick\.com/?\?.+},
  V3               => qr{^https?://\w+\.v3\.net/},
  ShortenURL       => qr{^https?://www\.shortenurl\.com/.+},
  URLjr            => qr{^https?://urljr\.com/.+},
  qURL             => qr{^https?://qurl\.net/.+},
  SmLnk            => qr{^https?://smlnk\.com/.+},
  ShortLink        => qr{^https?://shortlink\.us/.+},
  EkDk             => qr{^https?://add\.redir\.ek\.dk/.+},
  MakeAShorterLink => qr{^https?://tinyurl\.com/.+},
  LinkToolbot      => qr{^https?://link\.toolbot\.com/.+},
  haojp            => qr{^https?://hao\.jp/.+},
  Smallr           => qr{^https?://smallr\.com/.+},
  unu              => qr{^https?://u\.nu/.+},
  Tinylink         => [ qr{^https?://tinylink\.com/.+}, 'Tinylink' ],
  durlme           => qr{^https?://durl\.me/.+},
  NotLong          => qr{^https?://[\w\-]+\.notlong\.com/?$},
  shadyurl         => qr{^https?://5z8\.info/.+},
  miudin           => qr{^https?://miud\.in/.+},
  OneShortLink     => [ qr{^https?://1sl\.net/.+}, 'OneShortLink' ],
);

sub new {
  my $class = shift;

  my %services;
  if ( @_ ) {
    foreach my $name ( @_ ) {
      $services{$name} = $PartOfOtherServices{$name}
                      || $KnownServices{$name};
    }
  }
  else {
    %services = (%KnownServices, %PartOfOtherServices);
  }

  my $ua = LWP::UserAgent->new(
    env_proxy => 1,
    timeout   => 30,
    agent     => "$class/$VERSION",
    requests_redirectable => [],
  );

  bless { ua => $ua, services => \%services }, $class;
}

sub ua { shift->{ua} }

sub try {
  my ($self, $url) = @_;

  my $new_url;
  my %seen;
  my $max_try = 5;
  while ($max_try--) {
    $new_url = $self->_try($url);
    return $new_url if $new_url eq $url or $seen{$new_url}++;
    $url = $new_url;
  }
  return $url;
}

sub _try {
  my ($self, $url) = @_;

  foreach my $name ( keys %{ $self->{services} } ) {
    my $service = $self->{services}->{$name};
    next unless $service;
    if ( ref $service eq 'Regexp' ) {
      next unless $url =~ /$service/;
      my $res = $self->ua->get($url);
      next unless $res->is_redirect;
      my $location = $res->header('Location');
      return $location if defined $location;
    }
    elsif ( ref $service eq 'ARRAY' ) {
      my ($regex, $package) = @{ $service };
      next unless $url =~ /$regex/;
      $package = 'WWW::Shorten::'.$package
        unless $package =~ /^WWW::Shorten::/;
      eval "require $package";
      unless ($@) {
        my $longer_url = eval "$package\::makealongerlink('$url')";
        return $longer_url if defined $longer_url;
      }
    }
  }
  return $url;
}

sub add {
  my ($self, %hash) = @_;

  %{ $self->{services} } = ( %{ $self->{services} }, %hash );
}

1;

__END__