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__ |