File Coverage

blib/lib/WWW/Shorten/Shorl.pm
Criterion Covered Total %
statement 37 38 97.4
branch 10 14 71.4
condition n/a
subroutine 9 9 100.0
pod 2 2 100.0
total 58 63 92.1


line stmt bran cond sub pod time code
1             # $Id$
2              
3             =head1 NAME
4            
5             WWW::Shorten::Shorl - Perl interface to shorl.com
6            
7             =head1 SYNOPSIS
8            
9             use WWW::Shorten::Shorl;
10            
11             use WWW::Shorten 'Shorl';
12            
13             $short_url = makeashorterlink($long_url);
14             ($short_url,$password) = makeashorterlink($long_url);
15            
16             $long_url = makealongerlink($short_url);
17            
18             =head1 DESCRIPTION
19            
20             A Perl interface to the web site shorl.com. Shorl simply maintains
21             a database of long URLs, each of which has a unique identifier.
22            
23             =cut
24              
25             package WWW::Shorten::Shorl;
26              
27 2     2   131351 use 5.006;
  2         5  
  2         33  
28 2     2   6 use strict;
  2         2  
  2         32  
29 2     2   5 use warnings;
  2         1  
  2         51  
30              
31 2     2   6 use base qw( WWW::Shorten::generic Exporter );
  2         2  
  2         162  
32             our @EXPORT = qw(makeashorterlink makealongerlink);
33             our $VERSION = '1.92';
34              
35 2     2   44110 use Carp;
  2         3  
  2         71  
36 2     2   8 use URI;
  2         3  
  2         28  
37 2     2   315 use URI::QueryParam;
  2         743  
  2         382  
38              
39             =head1 Functions
40            
41             =head2 makeashorterlink
42            
43             The function C<makeashorterlink> will call the Shorl web site passing it
44             your long URL and will return the shorter Shorl version. If used in a
45             list context, then it will return both the Shorl URL and the password.
46            
47             Note that Shorl, unlike TinyURL and MakeAShorterLink, returns a unique code
48             for every submission.
49            
50             =cut
51              
52             sub makeashorterlink ($)
53             {
54 3 100   3 1 105188     my $url = shift or croak 'No URL passed to makeashorterlink';
55 2         23     my $ua = __PACKAGE__->ua();
56 2         1673     $ua->agent('Mozilla/5.0');
57 2         93     my $shorl = URI->new('http://shorl.com/create.php');
58 2         5828     $shorl->query_form( url => $url );
59 2         248     my $resp = $ua->get($shorl);
60 2 50       1297862     return unless $resp->is_success;
61 2 0       57     if ($resp->content =~ m!
62             \QShorl:\E
63             \s+
64             <a \s+ href="http://shorl.com/\w+"\s+rel="nofollow">
65             (\Qhttp://shorl.com/\E\w+)
66             </a>.*
67             <br>
68             [\r\n\s]*
69             \QPassword:\E
70             \s+
71             (\w+)
72             !x) {
73 2 100       144 return wantarray ? ($1, $2) : $1;
74                 }
75 0         0     return;
76             }
77              
78             =head2 makealongerlink
79            
80             The function C<makealongerlink> does the reverse. C<makealongerlink>
81             will accept as an argument either the full Shorl URL or just the
82             Shorl identifier.
83            
84             If anything goes wrong, then either function will return C<undef>.
85            
86             =cut
87              
88             sub makealongerlink ($)
89             {
90 3 100   3 1 871     my $shorl_url = shift
91                     or croak 'No Shorl key / URL passed to makealongerlink';
92 2         42     my $ua = __PACKAGE__->ua();
93              
94 2 100       45     $shorl_url = "http://shorl.com/$shorl_url"
95                 unless $shorl_url =~ m!^http://!i;
96              
97 2         28     my $resp = $ua->get($shorl_url);
98              
99 2 50       971852     return if $resp->is_error;
100 2         79     my ($url) = $resp->content =~ /URL=(.+)\"/;
101 2         90     return $url;
102             }
103              
104             1;
105              
106             __END__
107            
108             =head2 EXPORT
109            
110             makeashorterlink, makealongerlink
111            
112             =head1 SUPPORT, LICENCE, THANKS and SUCH
113            
114             See the main L<WWW::Shorten> docs.
115            
116             =head1 AUTHOR
117            
118             Iain Truskett <spoon@cpan.org>
119            
120             Based on WWW::MakeAShorterLink by Dave Cross <dave@dave.org.uk>
121            
122             =head1 SEE ALSO
123            
124             L<WWW::Shorten>, L<perl>, L<http://shorl.com/>
125            
126             =cut
127