File Coverage

blib/lib/HTTP/Any/AnyEvent.pm
Criterion Covered Total %
statement 6 105 5.7
branch 0 78 0.0
condition 0 49 0.0
subroutine 2 8 25.0
pod 0 2 0.0
total 8 242 3.3


line stmt bran cond sub pod time code
1             package HTTP::Any::AnyEvent;
2              
3 1     1   1531 use strict;
  1         2  
  1         30  
4 1     1   6 use warnings;
  1         2  
  1         1315  
5              
6              
7             sub do_http {
8 0     0 0   my ($http_request, $url, $opt, $cb) = @_;
9              
10 0   0       my $method = $$opt{method} || "GET";
11              
12 0           my %headers = ();
13 0 0         %headers = %{$$opt{headers}} if $$opt{headers};
  0            
14              
15 0 0         $headers{"user-agent"} = $$opt{agent} if $$opt{agent};
16 0 0         $headers{"referer"} = $$opt{referer} if $$opt{referer};
17              
18 0 0 0       if ($$opt{compressed} or $$opt{gzip}) {
19 0           $headers{'Accept-Encoding'} = 'gzip, deflate';
20 0           require Compress::Raw::Zlib;
21             }
22              
23 0           my %args = ();
24 0 0         $args{headers} = \%headers if keys %headers;
25 0 0         $args{timeout} = $$opt{timeout} if $$opt{timeout};
26              
27 0 0         if (defined $$opt{max_redirect}) {
28 0           $args{recurse} = $$opt{max_redirect};
29             } else {
30 0           $args{recurse} = 7;
31             }
32              
33 0 0         if (my $proxy = $$opt{proxy}) {
34 0 0         if ($proxy =~ m/^socks/) {
    0          
35 0           $proxy =~ s!^socks://!socks5://!;
36 0           $args{socks} = $proxy;
37             } elsif ($proxy =~ m!^(\w+://)?(.+):(\d+)$!) {
38 0 0         if ($1) {
39 0           $args{proxy} = [$2, $3, $1];
40             } else {
41 0           $args{proxy} = [$2, $3];
42             }
43             }
44             }
45              
46 0 0         if ($$opt{cookie}) {
    0          
47 0           $args{cookie_jar} = $$opt{cookie};
48             } elsif (defined $$opt{cookie}) {
49 0           $args{cookie_jar} = {};
50             }
51              
52 0 0         $args{persistent} = $$opt{persistent} if exists $$opt{persistent};
53              
54 0           my $max_size = $$opt{max_size};
55 0           my $on_header = $$opt{on_header};
56 0           my $on_body = $$opt{on_body};
57              
58 0           my $body_from_on_body_length = 0;
59 0           my @body_from_on_body = ();
60              
61 0 0 0       if ($max_size or $on_header or $on_body) {
      0        
62 0           my $headers_got = 0;
63 0           my $content_encoding;
64             my $inflate;
65              
66             $args{on_header} = sub {
67 0     0     my ($headers) = @_;
68 0           $body_from_on_body_length = 0;
69 0           @body_from_on_body = ();
70 0           $headers_got = 1;
71 0           my ($is_success, $status, $h, $redirects) = headers($headers);
72 0           $content_encoding = $$h{'content-encoding'};
73 0 0 0       if (($$opt{compressed} or $$opt{gzip}) and $content_encoding) {
      0        
74 0 0         if ($content_encoding eq 'deflate') {
    0          
75 0           $inflate = Compress::Raw::Zlib::Inflate->new();
76             } elsif ($content_encoding eq 'gzip') {
77 0           $inflate = Compress::Raw::Zlib::Inflate->new(-WindowBits => Compress::Raw::Zlib::WANT_GZIP());
78             }
79             }
80              
81              
82 0 0         if ($on_header) {
83 0 0         $on_header->($is_success, $h, $redirects) or return;
84             }
85 0           return 1;
86 0           };
87              
88             $args{on_body} = sub {
89 0     0     my ($partial_body, $headers) = @_;
90 0           $body_from_on_body_length += length $partial_body;
91 0 0         push @body_from_on_body, $partial_body unless $on_body;
92 0 0 0       if ($headers_got and $max_size and $body_from_on_body_length > $max_size) {
      0        
93 0           return;
94             }
95 0 0 0       if ($headers_got and $on_body) {
96 0 0         if ($inflate) {
97 0           my $status = $inflate->inflate($partial_body, my $output);
98 0 0 0       $status == Compress::Raw::Zlib::Z_OK() or $status == Compress::Raw::Zlib::Z_STREAM_END() or warn "inflation failed: $status\n";
99 0 0         if ($output) {
100 0 0         $on_body->($output) or return;
101             }
102             } else {
103 0 0         $on_body->($partial_body) or return;
104             }
105             }
106 0           return 1;
107 0           };
108             }
109              
110 0 0         if ($method eq "POST") {
111 0   0       $args{headers}{"Content-Type"} ||= "application/x-www-form-urlencoded";
112 0           $args{body} = $$opt{body};
113             }
114              
115             $http_request->(
116             $method => $url,
117             %args,
118             sub {
119 0     0     my ($body, $headers) = @_;
120 0           my ($is_success, $status, $h, $redirects) = headers($headers);
121              
122 0 0         if (not $body) {
123 0 0         if ($status >= 590) {
    0          
124 0           $is_success = 0;
125 0           $body = "";
126 0 0         if ($status == 598) {
127 0           $$h{"Reason"} = "MaxSize";
128             }
129 0           $$h{"Status"} = $status = 599;
130 0           delete $$h{"Orig$_"} foreach qw(Status Reason);
131             } elsif (@body_from_on_body) {
132 0           $body = join "", @body_from_on_body;
133             }
134             }
135              
136 0           $$h{Protocol} = "HTTP/" . $$h{HTTPVersion};
137              
138 0           my $content_encoding = $$h{'content-encoding'};
139 0 0 0       if ($body and ($$opt{compressed} or $$opt{gzip}) and $content_encoding) {
      0        
      0        
140 0 0 0       if ($content_encoding eq 'deflate' or $content_encoding eq 'gzip') {
141 0 0         my $inflate = Compress::Raw::Zlib::Inflate->new($content_encoding eq 'gzip' ? (-WindowBits => Compress::Raw::Zlib::WANT_GZIP()) : ());
142 0           my $status = $inflate->inflate($body, my $output);
143 0 0 0       $status == Compress::Raw::Zlib::Z_OK() or $status == Compress::Raw::Zlib::Z_STREAM_END() or warn "inflation failed: $status\n";
144 0           $cb->($is_success, $output, $h, $redirects);
145             }
146             } else {
147 0           $cb->($is_success, $body, $h, $redirects);
148             }
149              
150             }
151 0           );
152             }
153              
154              
155              
156             sub headers {
157 0     0 0   my ($headers) = @_;
158              
159 0           my $status = $$headers{Status};
160 0 0 0       my $is_success = ($status >= 200 and $status < 300) ? 1 : 0;
161 0           my ($h, @hr) = _headers($headers);
162              
163 0           return $is_success, $status, $h, \@hr;
164             }
165              
166              
167              
168             sub _headers {
169 0     0     my ($h) = @_;
170 0           my %h = map { $_ => $$h{$_} } grep { $_ ne 'Redirect' } keys %$h;
  0            
  0            
171 0 0         if (my $r = $$h{'Redirect'}) {
172 0           return \%h, _headers($$r[1]);
173             } else {
174 0           return \%h;
175             }
176             }
177              
178              
179             1;