line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package WWW::Shorten::GitHub; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
# ABSTRACT: Shorten GitHub URLs using GitHub's URL shortener - git.io |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
=head1 NAME |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
WWW::Shorten::GitHub - Shorten GitHub URLs using GitHub's URL shortener - git.io |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
=head1 SYNOPSIS |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
This module provides a perl interface to GitHub's URL shortening service, git.io. |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
It allows you to shorten any GitHub URL, and also retrieve the original URL from |
14
|
|
|
|
|
|
|
a pre-shortened URL |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
=head1 USAGE |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
use WWW::Shorten 'GitHub'; |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
my $long_url = 'https://github.com/LoonyPandora/WWW-Shorten-GitHub'; |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
my $short_url = makeashorterlink($long_url); |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
=cut |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
|
27
|
3
|
|
|
3
|
|
152865
|
use strict; |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
87
|
|
28
|
3
|
|
|
3
|
|
18
|
use warnings; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
114
|
|
29
|
3
|
|
|
3
|
|
22
|
use base qw(WWW::Shorten::generic Exporter); |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
1070
|
|
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
our @EXPORT = qw(makeashorterlink makealongerlink); |
32
|
|
|
|
|
|
|
our $VERSION = '0.1.6'; |
33
|
|
|
|
|
|
|
|
34
|
3
|
|
|
3
|
|
49385
|
use Carp; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
178
|
|
35
|
3
|
|
|
3
|
|
15
|
use URI; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
976
|
|
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
sub makeashorterlink { |
38
|
1
|
50
|
|
1
|
0
|
10
|
my $url = shift or croak 'No URL passed to makeashorterlink'; |
39
|
|
|
|
|
|
|
|
40
|
1
|
|
|
|
|
9
|
my $host = URI->new($url)->host(); |
41
|
1
|
50
|
|
|
|
17023
|
if ($host !~ m/^(gist\.)?github\.com$/) { |
42
|
0
|
|
|
|
|
0
|
croak "Git.io only shortens URLs under the github.com domain"; |
43
|
|
|
|
|
|
|
} |
44
|
|
|
|
|
|
|
|
45
|
1
|
|
|
|
|
15
|
my $ua = __PACKAGE__->ua(); |
46
|
1
|
50
|
|
|
|
97763
|
my $response = $ua->post('https://git.io/create', [ |
47
|
|
|
|
|
|
|
url => $url, |
48
|
|
|
|
|
|
|
source => 'PerlAPI-' . (defined __PACKAGE__->VERSION ? __PACKAGE__->VERSION : 'dev'), |
49
|
|
|
|
|
|
|
format => 'simple', |
50
|
|
|
|
|
|
|
]); |
51
|
|
|
|
|
|
|
|
52
|
0
|
0
|
|
|
|
0
|
if ($response->header('Status') eq '200 OK') { |
53
|
0
|
|
|
|
|
0
|
return 'http://git.io/' . $response->decoded_content; |
54
|
|
|
|
|
|
|
} |
55
|
|
|
|
|
|
|
|
56
|
0
|
|
|
|
|
0
|
return; |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
sub makealongerlink { |
61
|
1
|
50
|
|
1
|
0
|
11
|
my $token = shift or croak 'No URL / Git.io token passed to makealongerlink'; |
62
|
|
|
|
|
|
|
|
63
|
1
|
|
|
|
|
10
|
my $url = URI->new($token); |
64
|
|
|
|
|
|
|
|
65
|
1
|
50
|
33
|
|
|
9778
|
unless ($url->scheme() && $url->host() eq 'git.io') { |
66
|
0
|
|
|
|
|
0
|
$url->scheme('https'); |
67
|
0
|
|
|
|
|
0
|
$url->host('git.io'); |
68
|
0
|
|
|
|
|
0
|
$url->path($token); |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
|
71
|
1
|
|
|
|
|
207
|
my $ua = __PACKAGE__->ua(); |
72
|
1
|
|
|
|
|
19067
|
my $response = $ua->get($url->as_string); |
73
|
|
|
|
|
|
|
|
74
|
0
|
0
|
|
|
|
|
if ($response->is_redirect) { |
75
|
0
|
|
|
|
|
|
return $response->header('Location'); |
76
|
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
|
|
78
|
0
|
|
|
|
|
|
return; |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
1; |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
=head1 CAVEATS |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
Git.io only shortens URLs on github.com and its subdomains. |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
It is not a general purpose URL shortener. |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
=head1 SEE ALSO |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
L, L |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
=head1 AUTHOR |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
James Aitken |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
This software is copyright (c) 2011 by James Aitken. |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
This is free software; you can redistribute it and/or modify it under |
102
|
|
|
|
|
|
|
the same terms as the Perl 5 programming language system itself. |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
=cut |