| 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 |  | 157645 | use strict; | 
|  | 3 |  |  |  |  | 6 |  | 
|  | 3 |  |  |  |  | 81 |  | 
| 28 | 3 |  |  | 3 |  | 18 | use warnings; | 
|  | 3 |  |  |  |  | 5 |  | 
|  | 3 |  |  |  |  | 102 |  | 
| 29 | 3 |  |  | 3 |  | 22 | use base qw(WWW::Shorten::generic Exporter); | 
|  | 3 |  |  |  |  | 6 |  | 
|  | 3 |  |  |  |  | 1064 |  | 
| 30 |  |  |  |  |  |  |  | 
| 31 |  |  |  |  |  |  | our @EXPORT = qw(makeashorterlink makealongerlink); | 
| 32 |  |  |  |  |  |  | our $VERSION = '0.1.7'; | 
| 33 |  |  |  |  |  |  |  | 
| 34 | 3 |  |  | 3 |  | 110970 | use Carp; | 
|  | 3 |  |  |  |  | 6 |  | 
|  | 3 |  |  |  |  | 163 |  | 
| 35 | 3 |  |  | 3 |  | 18 | use URI; | 
|  | 3 |  |  |  |  | 5 |  | 
|  | 3 |  |  |  |  | 978 |  | 
| 36 |  |  |  |  |  |  |  | 
| 37 |  |  |  |  |  |  | sub makeashorterlink { | 
| 38 | 1 | 50 |  | 1 | 0 | 14 | my $url = shift or croak 'No URL passed to makeashorterlink'; | 
| 39 |  |  |  |  |  |  |  | 
| 40 | 1 |  |  |  |  | 12 | my $host = URI->new($url)->host(); | 
| 41 | 1 | 50 |  |  |  | 32102 | if ($host !~ m/^(gist\.)?github\.com$/) { | 
| 42 | 0 |  |  |  |  | 0 | croak "Git.io only shortens URLs under the github.com domain"; | 
| 43 |  |  |  |  |  |  | } | 
| 44 |  |  |  |  |  |  |  | 
| 45 | 1 |  |  |  |  | 23 | my $ua = __PACKAGE__->ua(); | 
| 46 | 1 | 50 |  |  |  | 36321 | 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 | 1 | 50 |  |  |  | 2289511 | if ($response->header('Status') eq '200 OK') { | 
| 53 | 1 |  |  |  |  | 52 | return 'http://git.io/' . $response->decoded_content; | 
| 54 |  |  |  |  |  |  | } | 
| 55 |  |  |  |  |  |  |  | 
| 56 | 0 |  |  |  |  | 0 | return; | 
| 57 |  |  |  |  |  |  | } | 
| 58 |  |  |  |  |  |  |  | 
| 59 |  |  |  |  |  |  |  | 
| 60 |  |  |  |  |  |  | sub makealongerlink { | 
| 61 | 2 | 50 |  | 2 | 0 | 931 | my $token = shift or croak 'No URL / Git.io token passed to makealongerlink'; | 
| 62 |  |  |  |  |  |  |  | 
| 63 | 2 |  |  |  |  | 15 | my $url = URI->new($token); | 
| 64 |  |  |  |  |  |  |  | 
| 65 | 2 | 100 | 66 |  |  | 9739 | unless ($url->scheme() && $url->host() eq 'git.io') { | 
| 66 | 1 |  |  |  |  | 74 | $url->scheme('https'); | 
| 67 | 1 |  |  |  |  | 58 | $url->host('git.io'); | 
| 68 | 1 |  |  |  |  | 65 | $url->path($token); | 
| 69 |  |  |  |  |  |  | } | 
| 70 |  |  |  |  |  |  |  | 
| 71 | 2 |  |  |  |  | 261 | my $ua = __PACKAGE__->ua(); | 
| 72 | 2 |  |  |  |  | 19507 | my $response = $ua->get($url->as_string); | 
| 73 |  |  |  |  |  |  |  | 
| 74 | 2 | 50 |  |  |  | 1280327 | if ($response->is_redirect) { | 
| 75 | 2 |  |  |  |  | 35 | 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 |