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