File Coverage

blib/lib/WWW/Shorten/OneShortLink.pm
Criterion Covered Total %
statement 15 31 48.4
branch 0 16 0.0
condition n/a
subroutine 5 7 71.4
pod 2 2 100.0
total 22 56 39.3


line stmt bran cond sub pod time code
1             # $Id$
2              
3             =head1 NAME
4            
5             WWW::Shorten::OneShortLink - Perl interface to 1sl.net
6            
7             =head1 SYNOPSIS
8            
9             use WWW::Shorten::OneShortLink;
10            
11             use WWW::Shorten 'OneShortLink';
12            
13             $short_url = makeashorterlink($long_url);
14            
15             $long_url = makealongerlink($short_url);
16            
17             =head1 DESCRIPTION
18            
19             A Perl interface to the web site 1sl.net. OneShortLink simply maintains
20             a database of long URLs, each of which has a unique identifier.
21            
22             =cut
23              
24             package WWW::Shorten::OneShortLink;
25              
26 1     1   1444 use 5.006;
  1         2  
  1         22  
27 1     1   3 use strict;
  1         0  
  1         14  
28 1     1   2 use warnings;
  1         1  
  1         20  
29              
30 1     1   2 use base qw( WWW::Shorten::generic Exporter );
  1         1  
  1         66  
31             our @EXPORT = qw(makeashorterlink makealongerlink);
32             our $VERSION = '1.93';
33              
34 1     1   2 use Carp;
  1         1  
  1         281  
35              
36             =head1 Functions
37            
38             =head2 makeashorterlink
39            
40             The function C<makeashorterlink> will call the OneShortLink web site passing it
41             your long URL and will return the shorter OneShortLink version.
42            
43             =cut
44              
45             sub makeashorterlink ($)
46             {
47 0 0   0 1       my $url = shift or croak 'No URL passed to makeashorterlink';
48 0               my $ua = __PACKAGE__->ua();
49              
50 0               my $resp = $ua->post( 'http://1sl.net/', [
51             rurl => $url,
52             ] );
53              
54 0 0             return unless $resp->is_success;
55 0 0             return if $resp->content =~ />Operation Failed!/;
56              
57 0 0             if ($resp->content =~ m!
58             \Qyour Short Link\E
59             <[^>]*> \s* <[^>]*>
60             <a \s+ href="[^"]+">
61             ( \Qhttp://1sl.net/\E [^<]* )
62             </a>
63             !x) {
64 0           return $1;
65                 }
66              
67 0               return;
68             }
69              
70             =head2 makealongerlink
71            
72             The function C<makealongerlink> does the reverse. C<makealongerlink>
73             will accept as an argument either the full OneShortLink URL or just the
74             OneShortLink identifier.
75            
76             If anything goes wrong, then either function will return C<undef>.
77            
78             =cut
79              
80             sub makealongerlink ($)
81             {
82 0 0   0 1       my $short_url = shift
83             or croak '1 Short Link ID / URL passed to makealongerlink';
84 0               my $ua = __PACKAGE__->ua();
85              
86 0 0             $short_url = "http://1sl.net/$short_url"
87                 unless $short_url =~ m!^http://!i;
88              
89 0               my $resp = $ua->get($short_url);
90              
91 0 0             return unless $resp->is_success;
92              
93 0 0             if ($resp->content =~ m!<meta HTTP-EQUIV="Refresh" CONTENT="[0-9]+\; URL=(.*)"!i) {
94 0                   return $1;
95                 }
96              
97 0               return;
98             }
99             1;
100              
101             __END__
102            
103             =head2 EXPORT
104            
105             makeashorterlink, makealongerlink
106            
107             =head1 SUPPORT, LICENCE, THANKS and SUCH
108            
109             See the main L<WWW::Shorten> docs.
110            
111             =head1 AUTHOR
112            
113             Maintained by Iain Truskett <spoon@cpan.org>
114            
115             Original by P J Goodwin.
116            
117             =head1 SEE ALSO
118            
119             L<WWW::Shorten>, L<perl>, L<http://1sl.net/>
120            
121             =cut
122