File Coverage

blib/lib/WWW/Shorten/Tinylink.pm
Criterion Covered Total %
statement 6 6 100.0
branch n/a
condition n/a
subroutine 2 2 100.0
pod n/a
total 8 8 100.0


line stmt bran cond sub pod time code
1             # $Id$
2              
3 2     2   117394 use strict;
  2         3  
  2         47  
4 2     2   6 use warnings;
  2         2  
  2         88  
5              
6             our $VERSION = '1.91';
7             require WWW::Shorten::_dead;
8              
9             0;
10             __END__
11            
12             =head1 NAME
13            
14             WWW::Shorten::Tinylink - Perl interface to Tinylink.com
15            
16             =head1 SYNOPSIS
17            
18             # No appropriate solution
19            
20             =head1 DESCRIPTION
21            
22             A Perl interface to the web site Tinylink.com. Tinylink.com simply
23             maintains a database of long URLs, each of which has a unique
24             identifier.
25            
26             Unfortunately, at some point in the middle of 2008, Tinylink.com stopped
27             returning useable URLs and therefore this module is now deprecated.
28            
29             =cut
30            
31             package WWW::Shorten::Tinylink;
32            
33             use 5.006;
34             use strict;
35             use warnings;
36            
37             use base qw( WWW::Shorten::generic Exporter );
38             our @EXPORT = qw(makeashorterlink makealongerlink);
39             our $VERSION = '1.90';
40            
41             use Carp;
42            
43             =head1 Functions
44            
45             =head2 makeashorterlink
46            
47             The function C<makeashorterlink> will call the Tinylink.com web site
48             passing it your long URL and will return the shorter (tinylink) version.
49            
50             Multiple submissions of the same URL will result in different codes
51             being returned.
52            
53             =cut
54            
55             sub makeashorterlink ($)
56             {
57             my $url = shift or croak 'No URL passed to makeashorterlink';
58             my $ua = __PACKAGE__->ua();
59             my $resp = $ua->post( 'http://www.digipills.com/tinylink/ajout.php', [
60             lurl => $url,
61             ],
62             );
63             return unless $resp->is_success;
64             if ($resp->content =~ m!
65             \Q<a href="\E(\Qhttp://tinylink.com/?\E\w+)"
66             !x) {
67             return $1;
68             }
69             return;
70             }
71            
72             =head2 makealongerlink
73            
74             The function C<makealongerlink> does the reverse. C<makealongerlink>
75             will accept as an argument either the full Tinylink URL or just the
76             Tinylink identifier/nickname.
77            
78             If anything goes wrong, then either function will return C<undef>.
79            
80             =cut
81            
82             sub makealongerlink ($)
83             {
84             my $code = shift
85             or croak 'No Tinylink nickname/URL passed to makealongerlink';
86             my $ua = __PACKAGE__->ua();
87            
88             my $short;
89             unless ( $code =~ m!^http://!i )
90             {
91             $short = $code;
92             $code = "http://tinylink.com/?$code";
93             }
94             else
95             {
96             ($short) = $code =~ /\?(\w+)/;
97             }
98            
99             my $resp = $ua->get($code);
100             while ( my $location = $resp->header('Location') )
101             {
102             $resp = $ua->get( $location );
103             }
104             if ( my $refresh = $resp->header('Refresh') )
105             {
106             return $2 if $refresh =~ m/; *URL=(['"]?)(.*)\1$/i;
107             }
108            
109             return;
110             }
111            
112             1;
113            
114             __END__
115            
116             =head2 EXPORT
117            
118             makeashorterlink, makealongerlink
119            
120             =head1 SUPPORT, LICENCE, THANKS and SUCH
121            
122             See the main L<WWW::Shorten> docs.
123            
124             =head1 AUTHOR
125            
126             Iain Truskett <spoon@cpan.org>
127            
128             =head1 SEE ALSO
129            
130             L<WWW::Shorten>, L<perl>, L<http://tinylink.com/>
131            
132             =cut
133