File Coverage

blib/lib/LWP/Protocol/AnyEvent/http.pm
Criterion Covered Total %
statement 78 98 79.5
branch 15 36 41.6
condition 0 11 0.0
subroutine 15 16 93.7
pod 1 1 100.0
total 109 162 67.2


line stmt bran cond sub pod time code
1              
2             package LWP::Protocol::AnyEvent::http;
3              
4 9     9   601098 use strict;
  9         25  
  9         399  
5 9     9   51 use warnings;
  9         18  
  9         506  
6              
7 9     9   8004 use version; our $VERSION = qv('v1.8.0');
  9         31435  
  9         60  
8              
9 9     9   12295 use AnyEvent qw( );
  9         22099  
  9         200  
10 9     9   13836 use AnyEvent::HTTP qw( http_request );
  9         472263  
  9         1427  
11 9     9   20374 use HTTP::Response qw( );
  9         336556  
  9         315  
12 9     9   8139 use LWP::Protocol qw( );
  9         26627  
  9         237  
13 9     9   7982 use LWP::Protocol::http qw( );
  9         573849  
  9         11984  
14              
15             our @ISA = 'LWP::Protocol';
16              
17             LWP::Protocol::implementor($_, __PACKAGE__) for qw( http https );
18              
19              
20             # This code was based on _extra_sock_opts in LWP::Protocol::https
21             sub _get_tls_ctx {
22 0     0   0 my ($self) = @_;
23 0 0       0 my %ssl_opts = %{ $self->{ua}{ssl_opts} || {} };
  0         0  
24 0         0 my %tls_ctx;
25              
26             # Convert various ssl_opts values to corresponding AnyEvent::TLS tls_ctx values.
27 0         0 $tls_ctx{ verify } = $ssl_opts{SSL_verify_mode};
28 0 0 0     0 $tls_ctx{ verify_peername } = 'http' if defined($ssl_opts{SSL_verifycn_scheme}) && $ssl_opts{SSL_verifycn_scheme} eq 'www';
29 0 0       0 $tls_ctx{ ca_file } = $ssl_opts{SSL_ca_file} if exists($ssl_opts{SSL_ca_file});
30 0 0       0 $tls_ctx{ ca_path } = $ssl_opts{SSL_ca_path} if exists($ssl_opts{SSL_ca_path});
31              
32 0 0       0 if ($ssl_opts{verify_hostname}) {
33 0   0     0 $tls_ctx{verify} ||= 1;
34 0         0 $tls_ctx{verify_peername} = 'http';
35             }
36              
37             # We are verifying certificates, but don't have any CA specified, so we try using Mozilla::CA.
38 0 0 0     0 if ($tls_ctx{verify} && !( exists($tls_ctx{ca_file}) || exists($tls_ctx{ca_path}) )) {
      0        
39 0 0       0 if (!eval { require Mozilla::CA }) {
  0         0  
40 0 0       0 if ($@ !~ /^Can\'t locate Mozilla\/CA\.pm/) {
41 0         0 die 'Unable to find a list of Certificate Authorities to trust. '
42             . 'To fix this error, either install Mozilla::CA or configure '
43             . 'the ssl_opts as documented in LWP::UserAgent';
44             } else {
45 0         0 die $@;
46             }
47             }
48              
49 0         0 $tls_ctx{ca_file} = Mozilla::CA::SSL_ca_file();
50             }
51              
52 0         0 return \%tls_ctx;
53             }
54              
55              
56             sub _set_response_headers {
57 31     31   99 my ($response, $headers) = @_;
58              
59 31         1010 my %headers = %$headers;
60              
61             $response->protocol( "HTTP/".delete($headers{ HTTPVersion }) )
62 31 100       1498 if $headers{ HTTPVersion };
63 31         705 $response->code( delete($headers{ Status }) );
64 31         532 $response->message( delete($headers{ Reason }) );
65              
66             # Uppercase headers are pseudo headers added by AnyEvent::HTTP.
67 31         942 $headers{"X-AE-$_"} = delete($headers{$_}) for grep /^(?!X-)[A-Z]/, keys(%headers);
68              
69 31 100       210 if (exists($headers->{'set-cookie'})) {
70             # Set-Cookie headers are very non-standard.
71             # They cannot be safely joined.
72             # Try to undo their joining for HTTP::Cookies.
73 2         11 $headers{'set-cookie'} = [
74             split(/,(?=\s*\w+\s*(?:[=,;]|\z))/, $headers{'set-cookie'})
75             ];
76             }
77              
78             # Imitate Net::HTTP's removal of newlines.
79             s/\s*\n\s+/ /g
80 31         330 for values %headers;
81              
82 31         525 $response->header(%headers);
83             }
84              
85              
86             sub request {
87 16     16 1 106161 my ($self, $request, $proxy, $arg, $size, $timeout) = @_;
88              
89 16         162 my $method = $request->method();
90 16         352 my $url = $request->uri();
91              
92 16         116 my %headers;
93             {
94 16         36 my $headers_obj = $request->headers->clone();
  16         72  
95              
96             # Convert user:pass in url into an Authorization header.
97 16         2434 LWP::Protocol::http->_fixup_header($headers_obj, $url, $proxy);
98              
99             $headers_obj->scan(sub {
100 33     33   15749 my ($k, $v) = @_;
101             # Imitate LWP::Protocol::http's removal of newlines.
102 33         101 $v =~ s/\n/ /g;
103 33         159 $headers{ lc($k) } = $v;
104 16         1613 });
105             }
106              
107 16         375 my $body = $request->content_ref();
108              
109             # Fix AnyEvent::HTTP setting Referer to the request URL
110 16 100       287 $headers{referer} = undef unless exists $headers{referer};
111              
112             # The status code will be replaced.
113 16         251 my $response = HTTP::Response->new(599, 'Internal Server Error');
114 16         1109 $response->request($request);
115              
116 16         1627 my $headers_avail = AnyEvent->condvar();
117 16         8158 my $data_avail = AnyEvent->condvar();
118 16         99 my @data_queue;
119              
120             my %handle_opts;
121 16 50       70 $handle_opts{read_size} = $size if defined($size);
122 16 50       76 $handle_opts{max_read_size} = $size if defined($size);
123              
124 16         726 my %opts = ( handle_params => \%handle_opts );
125 16 50       110 $opts{body} = $$body if defined($body);
126 16 50       99 $opts{timeout} = $timeout if defined($timeout);
127              
128 16 50       89 if ($url->scheme eq 'https') {
129 0         0 $opts{tls_ctx} = $self->_get_tls_ctx();
130             }
131              
132 16 100       310 if ($proxy) {
133 1         11 my $proxy_uri = URI->new($proxy);
134 1         65 $opts{proxy} = [ $proxy_uri->host, $proxy_uri->port, $proxy_uri->scheme ];
135             }
136              
137             # Let LWP handle redirects and cookies.
138             my $guard = http_request(
139             $method => $url,
140             headers => \%headers,
141             %opts,
142             recurse => 0,
143             on_header => sub {
144             #my ($headers) = @_;
145 15     15   10064872 _set_response_headers($response, $_[0]);
146 15         4504 $headers_avail->send();
147 15         206 return 1;
148             },
149             on_body => sub {
150             #my ($chunk, $headers) = @_;
151 16     16   7003652 push @data_queue, \$_[0];
152 16         175 $data_avail->send();
153 16         327 return 1;
154             },
155             sub { # On completion
156             # On successful completion: @_ = ( '', $headers )
157             # On error: @_ = ( undef, $headers )
158              
159             # It is possible for the request to complete without
160             # calling the header callback in the event of error.
161             # It is also possible for the Status to change as the
162             # result of an error. This handles these events.
163 16     16   4965172 _set_response_headers($response, $_[1]);
164 16         2782 $headers_avail->send();
165              
166 16         282 push @data_queue, \''; # '
167 16         73 $data_avail->send();
168             },
169 16         416 );
170              
171             # We need to wait for the headers so the response code
172             # is set up properly. LWP::Protocol decides on ->is_success
173             # whether to call the :content_cb or not.
174 16         267980 $headers_avail->recv();
175              
176             return $self->collect($arg, $response, sub {
177 32 100   32   49940 if (!@data_queue) {
178             # Re-prime our channel, in case there is more.
179 12         10682 $data_avail = AnyEvent->condvar();
180              
181             # Wait for more data to arrive
182 12         169 $data_avail->recv();
183             };
184              
185 32         2827 return shift(@data_queue);
186 16         4763 });
187             }
188              
189              
190             1;
191              
192              
193             __END__