File Coverage

blib/lib/HTTP/Any/LWP.pm
Criterion Covered Total %
statement 6 105 5.7
branch 0 76 0.0
condition 0 39 0.0
subroutine 2 7 28.5
pod 0 1 0.0
total 8 228 3.5


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