File Coverage

blib/lib/WWW/Shorten/Shorl.pm
Criterion Covered Total %
statement 21 38 55.3
branch 0 14 0.0
condition n/a
subroutine 7 9 77.8
pod 2 2 100.0
total 30 63 47.6


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 1     1   1664 use 5.006;
  1         2  
  1         22  
28 1     1   2 use strict;
  1         1  
  1         14  
29 1     1   2 use warnings;
  1         0  
  1         20  
30              
31 1     1   2 use base qw( WWW::Shorten::generic Exporter );
  1         1  
  1         71  
32             our @EXPORT = qw(makeashorterlink makealongerlink);
33             our $VERSION = '1.91';
34              
35 1     1   3 use Carp;
  1         0  
  1         138  
36 1     1   2 use URI;
  1         1  
  1         14  
37 1     1   137 use URI::QueryParam;
  1         359  
  1         176  
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 0 0   0 1       my $url = shift or croak 'No URL passed to makeashorterlink';
55 0               my $ua = __PACKAGE__->ua();
56 0               $ua->agent('Mozilla/5.0');
57 0               my $shorl = URI->new('http://shorl.com/create.php');
58 0               $shorl->query_form( url => $url );
59 0               my $resp = $ua->get($shorl);
60 0 0             return unless $resp->is_success;
61 0 0             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 0 0         return wantarray ? ($1, $2) : $1;
74                 }
75 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 0 0   0 1       my $shorl_url = shift
91                     or croak 'No Shorl key / URL passed to makealongerlink';
92 0               my $ua = __PACKAGE__->ua();
93              
94 0 0             $shorl_url = "http://shorl.com/$shorl_url"
95                 unless $shorl_url =~ m!^http://!i;
96              
97 0               my $resp = $ua->get($shorl_url);
98              
99 0 0             return if $resp->is_error;
100 0               my ($url) = $resp->content =~ /URL=(.+)\"/;
101 0               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