File Coverage

blib/lib/WWW/Shorten/qURL.pm
Criterion Covered Total %
statement 15 32 46.9
branch 0 14 0.0
condition n/a
subroutine 5 7 71.4
pod 2 2 100.0
total 22 55 40.0


line stmt bran cond sub pod time code
1             # $Id$
2              
3             =head1 NAME
4            
5             WWW::Shorten::qURL - Perl interface to qurl.com
6            
7             =head1 SYNOPSIS
8            
9             use WWW::Shorten::qURL;
10             use WWW::Shorten 'qURL';
11            
12             $short_url = makeashorterlink($long_url);
13            
14             $long_url = makealongerlink($short_url);
15            
16             =head1 DESCRIPTION
17            
18             A Perl interface to the web site qurl.com. qURL simply maintains
19             a database of long URLs, each of which has a unique identifier.
20            
21             =cut
22              
23             package WWW::Shorten::qURL;
24              
25 1     1   1735 use 5.006;
  1         2  
  1         22  
26 1     1   2 use strict;
  1         0  
  1         15  
27 1     1   2 use warnings;
  1         0  
  1         19  
28              
29 1     1   2 use base qw( WWW::Shorten::generic Exporter );
  1         0  
  1         64  
30             our @EXPORT = qw( makeashorterlink makealongerlink );
31             our $VERSION = '2.00';
32              
33 1     1   3 use Carp;
  1         0  
  1         174  
34              
35             =head1 Functions
36            
37             =head2 makeashorterlink
38            
39             The function C<makeashorterlink> will call the qURL web site passing
40             it your long URL and will return the shorter qURL version.
41            
42             =cut
43              
44             sub makeashorterlink ($)
45             {
46 0 0   0 1       my $url = shift or croak 'No URL passed to makeashorterlink';
47 0               my $ua = __PACKAGE__->ua();
48 0               my $qurl = 'http://qurl.com/automate.php';
49 0               my $resp = $ua->post($qurl, [
50             url => $url,
51             ]);
52 0 0             return undef unless $resp->is_success;
53 0               my $content = $resp->content;
54 0 0             return if $content eq $url;
55 0               return $content;
56             }
57              
58             =head2 makealongerlink
59            
60             The function C<makealongerlink> does the reverse. C<makealongerlink>
61             will accept as an argument either the full qURL URL or just the
62             qURL identifier.
63            
64             If anything goes wrong, then either function will return C<undef>.
65            
66             =cut
67              
68             sub makealongerlink ($)
69             {
70 0 0   0 1       my $qurl = shift
71             or croak 'No qURL key / URL passed to makealongerlink';
72 0               my $ua = __PACKAGE__->ua();
73              
74 0 0             $qurl = "http://qurl.com/$qurl"
75                 unless $qurl =~ m!^http://!i;
76              
77 0 0             if ($qurl =~ m|^http://www\.|) {
78 0                 $qurl =~ s/www\.//;
79                 }
80              
81 0               my $resp = $ua->get($qurl);
82              
83 0 0             return unless $resp->is_redirect;
84 0               my $url = $resp->header('Location');
85 0               return $url;
86             }
87              
88             1;
89              
90             __END__
91            
92             =head2 EXPORT
93            
94             makeashorterlink, makealongerlink
95            
96             =head1 SUPPORT, LICENCE, THANKS and SUCH
97            
98             See the main L<WWW::Shorten> docs.
99            
100             =head1 AUTHOR
101            
102             Dave Cross <dave@mag-sol.com>
103            
104             =head1 SEE ALSO
105            
106             L<WWW::Shorten>, L<perl>, L<http://qurl.com/>
107            
108             =cut
109