File Coverage

blib/lib/Alien/Base/ModuleBuild/Repository/HTTP.pm
Criterion Covered Total %
statement 106 113 93.8
branch 25 34 73.5
condition 13 19 68.4
subroutine 17 17 100.0
pod 0 8 0.0
total 161 191 84.2


line stmt bran cond sub pod time code
1             package Alien::Base::ModuleBuild::Repository::HTTP;
2              
3 2     2   234137 use strict;
  2         8  
  2         77  
4 2     2   12 use warnings;
  2         4  
  2         46  
5 2     2   10 use Carp;
  2         4  
  2         99  
6 2     2   1418 use HTTP::Tiny;
  2         73947  
  2         83  
7 2     2   17 use Scalar::Util qw( blessed );
  2         5  
  2         110  
8 2     2   1171 use URI;
  2         9167  
  2         63  
9 2     2   473 use Alien::Base::ModuleBuild::Utils;
  2         5  
  2         99  
10 2     2   16 use parent 'Alien::Base::ModuleBuild::Repository';
  2         9  
  2         10  
11              
12             # ABSTRACT: HTTP repository handler
13             our $VERSION = '1.15'; # VERSION
14              
15             our $Has_HTML_Parser = eval { require HTML::LinkExtor; 1 };
16              
17             sub connection {
18              
19 11     11 0 33 my $self = shift;
20              
21             return $self->{connection}
22 11 100       40 if $self->{connection};
23              
24             # allow easy use of HTTP::Tiny subclass
25 7   100     41 $self->{protocol_class} ||= 'HTTP::Tiny';
26 7         15 my $module = $self->{protocol_class};
27 7         26 $module =~ s{::}{/}g;
28 7         18 $module .= '.pm';
29 7 100       12 eval { require $module; 1 }
  7         715  
  6         20  
30             or croak "Could not load protocol_class '$self->{protocol_class}': $@";
31              
32 6         33 my $http = $self->{protocol_class}->new();
33              
34 6         558 $self->{connection} = $http;
35              
36 6         36 return $http;
37              
38             }
39              
40             sub get_file {
41 7     7 0 18 my $self = shift;
42 7   33     20 my $file = shift || croak "Must specify file to download";
43              
44 7         64 my $protocol = $self->protocol;
45 7         15 my $host = $self->{host};
46 7         17 my $from = $self->location;
47              
48 7         18 my $uri = $self->build_uri($protocol, $host, $from, $file);
49 7         715 $file = ($uri->path_segments())[-1];
50 7         268 my $res = $self->connection->mirror($uri, $file);
51 7         57 my ( $is_error, $content, $headers ) = $self->check_http_response( $res );
52 7 50       18 croak "Download failed: " . $content if $is_error;
53              
54 7         13 my $disposition = $headers->{"content-disposition"};
55 7 50 66     42 if ( defined($disposition) && ($disposition =~ /filename="([^"]+)"/ || $disposition =~ /filename=([^\s]+)/)) {
      66        
56 4         12 my $new_filename = $1;
57 4         113 rename $file, $new_filename;
58 4         21 $self->{new_filename} = $new_filename;
59             }
60              
61 7         36 return $file;
62             }
63              
64             sub list_files {
65 1     1 0 8 my $self = shift;
66              
67 1         9 my $protocol = $self->protocol;
68 1         9 my $host = $self->host;
69 1         6 my $location = $self->location;
70 1         6 my $uri = $self->build_uri($protocol, $host, $location);
71              
72 1         117 my $res = $self->connection->get($uri);
73              
74 1         131 my ( $is_error, $content, undef, $base_url ) = $self->check_http_response( $res );
75 1 50       5 if ( $is_error ) {
76 0         0 carp $content;
77 0         0 return ();
78             }
79              
80 1         3 $self->{base_url} = $base_url;
81              
82 1         3 my @links = $self->find_links($content);
83              
84 1         8 return @links;
85             }
86              
87             sub find_links {
88 3     3 0 2398 my $self = shift;
89 3         7 my ($html) = @_;
90              
91 3         6 my @links;
92 3 100       8 if ($Has_HTML_Parser) {
93 1         4 push @links, $self->find_links_preferred($html)
94             } else {
95 2         7 push @links, $self->find_links_textbalanced($html)
96             }
97              
98 3         17 return @links;
99             }
100              
101             sub find_links_preferred {
102 2     2 0 6111 my $self = shift;
103 2         4 my ($html) = @_;
104              
105 2         3 my @links;
106              
107             my $extor = HTML::LinkExtor->new(
108             sub {
109 8     8   228 my ($tag, %attrs) = @_;
110 8 50       19 return unless $tag eq 'a';
111 8 50       20 return unless defined $attrs{href};
112 8         54 push @links, $attrs{href};
113             },
114 2         19 );
115              
116 2         225 $extor->parse($html);
117              
118 2         26 return @links;
119             }
120              
121             sub find_links_textbalanced {
122 3     3 0 2817 my $self = shift;
123 3         7 my ($html) = @_;
124 3         12 return Alien::Base::ModuleBuild::Utils::find_anchor_targets($html);
125             }
126              
127             sub build_uri {
128 17     17 0 4297 my $self = shift;
129 17         46 my ($protocol, $host, $path, $target) = @_;
130              
131 17         27 my $uri;
132 17 100       39 if (defined $host) {
133 15         27 my $base = $self->{base_url};
134 15 50       37 unless($base)
135             {
136 15         50 $base = URI->new($host);
137 15 100       4296 unless (defined $base->scheme) {
138 14   100     295 $base = URI->new(($protocol || 'http') ."://$host");
139             }
140 15 100       2109 $base->path($path) if defined $path;
141             }
142 15         472 $uri = URI->new_abs($target, $base);
143             }
144             else {
145 2         12 $uri = URI->new($target);
146             }
147 17         3713 return $uri->canonical;
148             }
149              
150             sub check_http_response {
151 11     11 0 8361 my ( $self, $res ) = @_;
152 11 50 33     49 if ( blessed $res && $res->isa( 'HTTP::Response' ) ) {
153 0         0 my %headers = map { lc $_ => $res->header($_) } $res->header_field_names;
  0         0  
154 0 0       0 if ( !$res->is_success ) {
155 0         0 return ( 1, $res->status_line . " " . $res->decoded_content, \%headers, $res->request->uri );
156             }
157 0         0 return ( 0, $res->decoded_content, \%headers, $res->request->uri );
158             }
159             else {
160 11 100       31 if ( !$res->{success} ) {
161 3 100       12 my $reason = $res->{status} == 599 ? $res->{content} : "@{[ $res->{status} ]} @{[ $res->{reason} ]}";
  1         6  
  1         4  
162 3 100 100     19 if($res->{status} == 599 && $reason =~ /https support/)
163             {
164 1         4 $reason .= "See https://github.com/PerlAlien/Alien-Base-ModuleBuild/issues/6#issuecomment-417097485";
165             }
166 3         32 return ( 1, $reason, $res->{headers}, $res->{url} );
167             }
168 8         31 return ( 0, $res->{content}, $res->{headers}, $res->{url} );
169             }
170             }
171              
172             1;
173              
174             __END__