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.08';

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

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

our %ExtraServices = (
  OneShortLink     => [ qr{^http://1sl\.net/.+}, 'OneShortLink' ],
  Shorl            => [ qr{^http://shorl\.com/.+}, 'Shorl' ],
);

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

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__