File Coverage

blib/lib/Future/HTTP/Handler.pm
Criterion Covered Total %
statement 30 103 29.1
branch 3 48 6.2
condition 0 24 0.0
subroutine 7 10 70.0
pod 0 3 0.0
total 40 188 21.2


line stmt bran cond sub pod time code
1             package Future::HTTP::Handler;
2 6     6   59304 use Moo::Role;
  6         16  
  6         34  
3 6     6   2025 use Filter::signatures;
  6         73  
  6         33  
4 6     6   232 no warnings 'experimental::signatures';
  6         26  
  6         220  
5 6     6   32 use feature 'signatures';
  6         31  
  6         1456  
6              
7             our $VERSION = '0.15';
8              
9             =head1 NAME
10              
11             Future::HTTP::Handler - common role for handling HTTP responses
12              
13             =cut
14              
15             has 'on_http_response' => (
16             is => 'rw',
17             );
18              
19 3     3 0 6 sub http_response_received( $self, $res, $body, $headers ) {
  3         5  
  3         5  
  3         4  
  3         5  
  3         8  
20 3 50       16 $self->on_http_response( $res, $body, $headers )
21             if $self->on_http_response;
22 3 50       20 if( $headers->{Status} =~ /^[23]../ ) {
23 3         15 $body = $self->decode_content( $body, $headers );
24 3         72 $res->done($body, $headers);
25             } else {
26 0         0 $res->fail('error when connecting', $headers);
27             }
28             }
29              
30 6     6   54 no warnings 'once';
  6         12  
  6         6808  
31             sub decode_content {
32 3     3 0 9 my($self, $body, $headers) = @_;
33 3         6 my $content_ref = \$body;
34 3         5 my $content_ref_iscopy = 1;
35              
36 3 50       10 if (my $h = $headers->{'content-encoding'}) {
37 0         0 $h =~ s/^\s+//;
38 0         0 $h =~ s/\s+$//;
39 0         0 for my $ce (reverse split(/\s*,\s*/, lc($h))) {
40 0 0       0 next unless $ce;
41 0 0 0     0 next if $ce eq "identity" || $ce eq "none";
42 0 0 0     0 if ($ce eq "gzip" || $ce eq "x-gzip") {
    0 0        
    0 0        
    0          
    0          
    0          
43 0         0 require IO::Uncompress::Gunzip;
44 0         0 my $output;
45 0 0       0 IO::Uncompress::Gunzip::gunzip($content_ref, \$output, Transparent => 0)
46             or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError";
47 0         0 $content_ref = \$output;
48 0         0 $content_ref_iscopy++;
49             }
50             elsif ($ce eq "x-bzip2" or $ce eq "bzip2") {
51 0         0 require IO::Uncompress::Bunzip2;
52 0         0 my $output;
53 0 0       0 IO::Uncompress::Bunzip2::bunzip2($content_ref, \$output, Transparent => 0)
54             or die "Can't bunzip content: $IO::Uncompress::Bunzip2::Bunzip2Error";
55 0         0 $content_ref = \$output;
56 0         0 $content_ref_iscopy++;
57             }
58             elsif ($ce eq "deflate") {
59 0         0 require IO::Uncompress::Inflate;
60 0         0 my $output;
61 0         0 my $status = IO::Uncompress::Inflate::inflate($content_ref, \$output, Transparent => 0);
62 0         0 my $error = $IO::Uncompress::Inflate::InflateError;
63 0 0       0 unless ($status) {
64             # "Content-Encoding: deflate" is supposed to mean the
65             # "zlib" format of RFC 1950, but Microsoft got that
66             # wrong, so some servers sends the raw compressed
67             # "deflate" data. This tries to inflate this format.
68 0         0 $output = undef;
69 0         0 require IO::Uncompress::RawInflate;
70 0 0       0 unless (IO::Uncompress::RawInflate::rawinflate($content_ref, \$output)) {
71             #$self->push_header("Client-Warning" =>
72             #"Could not raw inflate content: $IO::Uncompress::RawInflate::RawInflateError");
73 0         0 $output = undef;
74             }
75             }
76 0 0       0 die "Can't inflate content: $error" unless defined $output;
77 0         0 $content_ref = \$output;
78 0         0 $content_ref_iscopy++;
79             }
80             elsif ($ce eq "compress" || $ce eq "x-compress") {
81 0         0 die "Can't uncompress content";
82             }
83             elsif ($ce eq "base64") { # not really C-T-E, but should be harmless
84 0         0 require MIME::Base64;
85 0         0 $content_ref = \MIME::Base64::decode($$content_ref);
86 0         0 $content_ref_iscopy++;
87             }
88             elsif ($ce eq "quoted-printable") { # not really C-T-E, but should be harmless
89 0         0 require MIME::QuotedPrint;
90 0         0 $content_ref = \MIME::QuotedPrint::decode($$content_ref);
91 0         0 $content_ref_iscopy++;
92             }
93             else {
94 0         0 die "Don't know how to decode Content-Encoding '$ce'";
95             }
96             }
97             }
98              
99 3         8 return $$content_ref
100             }
101              
102 0     0 0   sub mirror( $self, $url, $outfile, $args ) {
  0            
  0            
  0            
  0            
  0            
103 0 0         if ( exists $args->{headers} ) {
104 0           my $headers = {};
105 0 0         while ( my ($key, $value) = each %{$args->{headers} || {}} ) {
  0            
106 0           $headers->{lc $key} = $value;
107             }
108 0           $args->{headers} = $headers;
109             }
110              
111 0 0 0       if ( -e $outfile and my $mtime = (stat($outfile))[9] ) {
112 0   0       $args->{headers}{'if-modified-since'} ||= $self->_http_date($mtime);
113             }
114 0           my $tempfile = $outfile . int(rand(2**31));
115              
116 0           require Fcntl;
117 0 0         sysopen my $fh, $tempfile, Fcntl::O_CREAT()|Fcntl::O_EXCL()|Fcntl::O_WRONLY()
118             or croak(qq/Error: Could not create temporary file $tempfile for downloading: $!\n/);
119 0           binmode $fh;
120 0     0     $args->{on_body} = sub { print {$fh} $_[0] };
  0            
  0            
121 0     0     my $response_f = $self->request('GET', $url, $args)->on_done(sub( $response_f ) {
  0            
  0            
122 0 0         close $fh
123             or croak(qq/Error: Caught error closing temporary file $tempfile: $!\n/);
124              
125 0 0         if ( $response_f->is_success ) {
126 0           my $response = $response_f->get;
127 0 0         rename $tempfile, $outfile
128             or _croak(qq/Error replacing $outfile with $tempfile: $!\n/);
129 0           my $lm = $response->{headers}{'last-modified'};
130 0 0 0       if ( $lm and my $mtime = $self->_parse_http_date($lm) ) {
131 0           utime $mtime, $mtime, $outfile;
132             }
133             }
134 0   0       $response_f->{success} ||= $response_f->{status} eq '304';
135 0           unlink $tempfile;
136              
137 0           $response_f
138 0           });
139 0           return $response_f;
140             }
141              
142             1;