line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# vim: ts=4 sts=4 sw=4 et: |
2
|
|
|
|
|
|
|
package HTTP::Tiny; |
3
|
29
|
|
|
29
|
|
2039454
|
use strict; |
|
29
|
|
|
|
|
251
|
|
|
29
|
|
|
|
|
682
|
|
4
|
29
|
|
|
29
|
|
130
|
use warnings; |
|
29
|
|
|
|
|
63
|
|
|
29
|
|
|
|
|
3291
|
|
5
|
|
|
|
|
|
|
# ABSTRACT: A small, simple, correct HTTP/1.1 client |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
our $VERSION = '0.081'; # TRIAL |
8
|
|
|
|
|
|
|
|
9
|
15
|
|
|
15
|
|
64
|
sub _croak { require Carp; Carp::croak(@_) } |
|
15
|
|
|
|
|
1220
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
#pod =method new |
12
|
|
|
|
|
|
|
#pod |
13
|
|
|
|
|
|
|
#pod $http = HTTP::Tiny->new( %attributes ); |
14
|
|
|
|
|
|
|
#pod |
15
|
|
|
|
|
|
|
#pod This constructor returns a new HTTP::Tiny object. Valid attributes include: |
16
|
|
|
|
|
|
|
#pod |
17
|
|
|
|
|
|
|
#pod =for :list |
18
|
|
|
|
|
|
|
#pod * C — A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If |
19
|
|
|
|
|
|
|
#pod C — ends in a space character, the default user-agent string is |
20
|
|
|
|
|
|
|
#pod appended. |
21
|
|
|
|
|
|
|
#pod * C — An instance of L — or equivalent class |
22
|
|
|
|
|
|
|
#pod that supports the C and C methods |
23
|
|
|
|
|
|
|
#pod * C — A hashref of default headers to apply to requests |
24
|
|
|
|
|
|
|
#pod * C — The local IP address to bind to |
25
|
|
|
|
|
|
|
#pod * C — Whether to reuse the last connection (if for the same |
26
|
|
|
|
|
|
|
#pod scheme, host and port) (defaults to 1) |
27
|
|
|
|
|
|
|
#pod * C — Maximum number of redirects allowed (defaults to 5) |
28
|
|
|
|
|
|
|
#pod * C — Maximum response size in bytes (only when not using a data |
29
|
|
|
|
|
|
|
#pod callback). If defined, requests with responses larger than this will return |
30
|
|
|
|
|
|
|
#pod a 599 status code. |
31
|
|
|
|
|
|
|
#pod * C — URL of a proxy server to use for HTTP connections |
32
|
|
|
|
|
|
|
#pod (default is C<$ENV{http_proxy}> — if set) |
33
|
|
|
|
|
|
|
#pod * C — URL of a proxy server to use for HTTPS connections |
34
|
|
|
|
|
|
|
#pod (default is C<$ENV{https_proxy}> — if set) |
35
|
|
|
|
|
|
|
#pod * C — URL of a generic proxy server for both HTTP and HTTPS |
36
|
|
|
|
|
|
|
#pod connections (default is C<$ENV{all_proxy}> — if set) |
37
|
|
|
|
|
|
|
#pod * C — List of domain suffixes that should not be proxied. Must |
38
|
|
|
|
|
|
|
#pod be a comma-separated string or an array reference. (default is |
39
|
|
|
|
|
|
|
#pod C<$ENV{no_proxy}> —) |
40
|
|
|
|
|
|
|
#pod * C — Request timeout in seconds (default is 60) If a socket open, |
41
|
|
|
|
|
|
|
#pod read or write takes longer than the timeout, the request response status code |
42
|
|
|
|
|
|
|
#pod will be 599. |
43
|
|
|
|
|
|
|
#pod * C — A boolean that indicates whether to validate the SSL |
44
|
|
|
|
|
|
|
#pod certificate of an C — connection (default is false) |
45
|
|
|
|
|
|
|
#pod * C — A hashref of C — options to pass through to |
46
|
|
|
|
|
|
|
#pod L |
47
|
|
|
|
|
|
|
#pod |
48
|
|
|
|
|
|
|
#pod An accessor/mutator method exists for each attribute. |
49
|
|
|
|
|
|
|
#pod |
50
|
|
|
|
|
|
|
#pod Passing an explicit C for C, C or C will |
51
|
|
|
|
|
|
|
#pod prevent getting the corresponding proxies from the environment. |
52
|
|
|
|
|
|
|
#pod |
53
|
|
|
|
|
|
|
#pod Errors during request execution will result in a pseudo-HTTP status code of 599 |
54
|
|
|
|
|
|
|
#pod and a reason of "Internal Exception". The content field in the response will |
55
|
|
|
|
|
|
|
#pod contain the text of the error. |
56
|
|
|
|
|
|
|
#pod |
57
|
|
|
|
|
|
|
#pod The C parameter enables a persistent connection, but only to a |
58
|
|
|
|
|
|
|
#pod single destination scheme, host and port. If any connection-relevant |
59
|
|
|
|
|
|
|
#pod attributes are modified via accessor, or if the process ID or thread ID change, |
60
|
|
|
|
|
|
|
#pod the persistent connection will be dropped. If you want persistent connections |
61
|
|
|
|
|
|
|
#pod across multiple destinations, use multiple HTTP::Tiny objects. |
62
|
|
|
|
|
|
|
#pod |
63
|
|
|
|
|
|
|
#pod See L for more on the C and C attributes. |
64
|
|
|
|
|
|
|
#pod |
65
|
|
|
|
|
|
|
#pod =cut |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
my @attributes; |
68
|
|
|
|
|
|
|
BEGIN { |
69
|
29
|
|
|
29
|
|
158
|
@attributes = qw( |
70
|
|
|
|
|
|
|
cookie_jar default_headers http_proxy https_proxy keep_alive |
71
|
|
|
|
|
|
|
local_address max_redirect max_size proxy no_proxy |
72
|
|
|
|
|
|
|
SSL_options verify_SSL |
73
|
|
|
|
|
|
|
); |
74
|
29
|
|
|
|
|
75
|
my %persist_ok = map {; $_ => 1 } qw( |
|
116
|
|
|
|
|
330
|
|
75
|
|
|
|
|
|
|
cookie_jar default_headers max_redirect max_size |
76
|
|
|
|
|
|
|
); |
77
|
29
|
|
|
29
|
|
176
|
no strict 'refs'; |
|
29
|
|
|
|
|
53
|
|
|
29
|
|
|
|
|
873
|
|
78
|
29
|
|
|
29
|
|
145
|
no warnings 'uninitialized'; |
|
29
|
|
|
|
|
64
|
|
|
29
|
|
|
|
|
4005
|
|
79
|
29
|
|
|
|
|
86
|
for my $accessor ( @attributes ) { |
80
|
348
|
|
|
|
|
18004
|
*{$accessor} = sub { |
81
|
|
|
|
|
|
|
@_ > 1 |
82
|
|
|
|
|
|
|
? do { |
83
|
1
|
50
|
33
|
|
|
4
|
delete $_[0]->{handle} if !$persist_ok{$accessor} && $_[1] ne $_[0]->{$accessor}; |
84
|
1
|
|
|
|
|
3
|
$_[0]->{$accessor} = $_[1] |
85
|
|
|
|
|
|
|
} |
86
|
97
|
100
|
|
97
|
|
447
|
: $_[0]->{$accessor}; |
87
|
348
|
|
|
|
|
812
|
}; |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
sub agent { |
92
|
151
|
|
|
151
|
0
|
288
|
my($self, $agent) = @_; |
93
|
151
|
100
|
|
|
|
380
|
if( @_ > 1 ){ |
94
|
|
|
|
|
|
|
$self->{agent} = |
95
|
145
|
100
|
100
|
|
|
743
|
(defined $agent && $agent =~ / $/) ? $agent . $self->_agent : $agent; |
96
|
|
|
|
|
|
|
} |
97
|
151
|
|
|
|
|
269
|
return $self->{agent}; |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
sub timeout { |
101
|
8
|
|
|
8
|
0
|
25
|
my ($self, $timeout) = @_; |
102
|
8
|
100
|
|
|
|
16
|
if ( @_ > 1 ) { |
103
|
3
|
|
|
|
|
6
|
$self->{timeout} = $timeout; |
104
|
3
|
100
|
|
|
|
8
|
if ($self->{handle}) { |
105
|
2
|
|
|
|
|
5
|
$self->{handle}->timeout($timeout); |
106
|
|
|
|
|
|
|
} |
107
|
|
|
|
|
|
|
} |
108
|
8
|
|
|
|
|
22
|
return $self->{timeout}; |
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
sub new { |
112
|
144
|
|
|
144
|
1
|
1207356
|
my($class, %args) = @_; |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
my $self = { |
115
|
|
|
|
|
|
|
max_redirect => 5, |
116
|
|
|
|
|
|
|
timeout => defined $args{timeout} ? $args{timeout} : 60, |
117
|
|
|
|
|
|
|
keep_alive => 1, |
118
|
|
|
|
|
|
|
verify_SSL => $args{verify_SSL} || $args{verify_ssl} || 0, # no verification by default |
119
|
|
|
|
|
|
|
no_proxy => $ENV{no_proxy}, |
120
|
144
|
100
|
100
|
|
|
1415
|
}; |
121
|
|
|
|
|
|
|
|
122
|
144
|
|
|
|
|
290
|
bless $self, $class; |
123
|
|
|
|
|
|
|
|
124
|
144
|
100
|
|
|
|
385
|
$class->_validate_cookie_jar( $args{cookie_jar} ) if $args{cookie_jar}; |
125
|
|
|
|
|
|
|
|
126
|
142
|
|
|
|
|
288
|
for my $key ( @attributes ) { |
127
|
1704
|
100
|
|
|
|
2771
|
$self->{$key} = $args{$key} if exists $args{$key} |
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
|
130
|
142
|
100
|
|
|
|
485
|
$self->agent( exists $args{agent} ? $args{agent} : $class->_agent ); |
131
|
|
|
|
|
|
|
|
132
|
142
|
|
|
|
|
381
|
$self->_set_proxies; |
133
|
|
|
|
|
|
|
|
134
|
141
|
|
|
|
|
1131
|
return $self; |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
sub _set_proxies { |
138
|
142
|
|
|
142
|
|
244
|
my ($self) = @_; |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
# get proxies from %ENV only if not provided; explicit undef will disable |
141
|
|
|
|
|
|
|
# getting proxies from the environment |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
# generic proxy |
144
|
142
|
100
|
|
|
|
292
|
if (! exists $self->{proxy} ) { |
145
|
139
|
|
100
|
|
|
480
|
$self->{proxy} = $ENV{all_proxy} || $ENV{ALL_PROXY}; |
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
|
148
|
142
|
100
|
|
|
|
282
|
if ( defined $self->{proxy} ) { |
149
|
4
|
|
|
|
|
11
|
$self->_split_proxy( 'generic proxy' => $self->{proxy} ); # validate |
150
|
|
|
|
|
|
|
} |
151
|
|
|
|
|
|
|
else { |
152
|
138
|
|
|
|
|
222
|
delete $self->{proxy}; |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
# http proxy |
156
|
142
|
100
|
|
|
|
295
|
if (! exists $self->{http_proxy} ) { |
157
|
|
|
|
|
|
|
# under CGI, bypass HTTP_PROXY as request sets it from Proxy header |
158
|
141
|
100
|
100
|
|
|
319
|
local $ENV{HTTP_PROXY} = ($ENV{CGI_HTTP_PROXY} || "") if $ENV{REQUEST_METHOD}; |
159
|
141
|
|
100
|
|
|
620
|
$self->{http_proxy} = $ENV{http_proxy} || $ENV{HTTP_PROXY} || $self->{proxy}; |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
|
162
|
142
|
100
|
|
|
|
284
|
if ( defined $self->{http_proxy} ) { |
163
|
10
|
|
|
|
|
27
|
$self->_split_proxy( http_proxy => $self->{http_proxy} ); # validate |
164
|
9
|
|
|
|
|
26
|
$self->{_has_proxy}{http} = 1; |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
else { |
167
|
132
|
|
|
|
|
201
|
delete $self->{http_proxy}; |
168
|
|
|
|
|
|
|
} |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
# https proxy |
171
|
141
|
100
|
|
|
|
266
|
if (! exists $self->{https_proxy} ) { |
172
|
140
|
|
100
|
|
|
588
|
$self->{https_proxy} = $ENV{https_proxy} || $ENV{HTTPS_PROXY} || $self->{proxy}; |
173
|
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
|
175
|
141
|
100
|
|
|
|
286
|
if ( $self->{https_proxy} ) { |
176
|
6
|
|
|
|
|
23
|
$self->_split_proxy( https_proxy => $self->{https_proxy} ); # validate |
177
|
6
|
|
|
|
|
15
|
$self->{_has_proxy}{https} = 1; |
178
|
|
|
|
|
|
|
} |
179
|
|
|
|
|
|
|
else { |
180
|
135
|
|
|
|
|
185
|
delete $self->{https_proxy}; |
181
|
|
|
|
|
|
|
} |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
# Split no_proxy to array reference if not provided as such |
184
|
141
|
100
|
|
|
|
291
|
unless ( ref $self->{no_proxy} eq 'ARRAY' ) { |
185
|
|
|
|
|
|
|
$self->{no_proxy} = |
186
|
138
|
100
|
|
|
|
312
|
(defined $self->{no_proxy}) ? [ split /\s*,\s*/, $self->{no_proxy} ] : []; |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
141
|
|
|
|
|
240
|
return; |
190
|
|
|
|
|
|
|
} |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
#pod =method get|head|put|post|patch|delete |
193
|
|
|
|
|
|
|
#pod |
194
|
|
|
|
|
|
|
#pod $response = $http->get($url); |
195
|
|
|
|
|
|
|
#pod $response = $http->get($url, \%options); |
196
|
|
|
|
|
|
|
#pod $response = $http->head($url); |
197
|
|
|
|
|
|
|
#pod |
198
|
|
|
|
|
|
|
#pod These methods are shorthand for calling C for the given method. The |
199
|
|
|
|
|
|
|
#pod URL must have unsafe characters escaped and international domain names encoded. |
200
|
|
|
|
|
|
|
#pod See C for valid options and a description of the response. |
201
|
|
|
|
|
|
|
#pod |
202
|
|
|
|
|
|
|
#pod The C field of the response will be true if the status code is 2XX. |
203
|
|
|
|
|
|
|
#pod |
204
|
|
|
|
|
|
|
#pod =cut |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
for my $sub_name ( qw/get head put post patch delete/ ) { |
207
|
|
|
|
|
|
|
my $req_method = uc $sub_name; |
208
|
29
|
|
|
29
|
|
193
|
no strict 'refs'; |
|
29
|
|
|
|
|
50
|
|
|
29
|
|
|
|
|
113281
|
|
209
|
1
|
0
|
0
|
1
|
1
|
43
|
eval <<"HERE"; ## no critic |
|
1
|
100
|
33
|
77
|
1
|
3
|
|
|
1
|
0
|
50
|
2
|
1
|
5
|
|
|
77
|
0
|
100
|
0
|
1
|
26619
|
|
|
77
|
50
|
100
|
2
|
1
|
290
|
|
|
74
|
50
|
100
|
8
|
1
|
469
|
|
|
2
|
|
0
|
|
|
1008
|
|
|
2
|
|
33
|
|
|
8
|
|
|
2
|
|
50
|
|
|
13
|
|
|
0
|
|
0
|
|
|
0
|
|
|
0
|
|
0
|
|
|
0
|
|
|
0
|
|
0
|
|
|
0
|
|
|
2
|
|
33
|
|
|
87
|
|
|
2
|
|
33
|
|
|
13
|
|
|
2
|
|
50
|
|
|
8
|
|
|
8
|
|
33
|
|
|
290
|
|
|
8
|
|
33
|
|
|
42
|
|
|
8
|
|
50
|
|
|
25
|
|
210
|
|
|
|
|
|
|
sub $sub_name { |
211
|
|
|
|
|
|
|
my (\$self, \$url, \$args) = \@_; |
212
|
|
|
|
|
|
|
\@_ == 2 || (\@_ == 3 && ref \$args eq 'HASH') |
213
|
|
|
|
|
|
|
or _croak(q/Usage: \$http->$sub_name(URL, [HASHREF])/ . "\n"); |
214
|
|
|
|
|
|
|
return \$self->request('$req_method', \$url, \$args || {}); |
215
|
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
|
HERE |
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
#pod =method post_form |
220
|
|
|
|
|
|
|
#pod |
221
|
|
|
|
|
|
|
#pod $response = $http->post_form($url, $form_data); |
222
|
|
|
|
|
|
|
#pod $response = $http->post_form($url, $form_data, \%options); |
223
|
|
|
|
|
|
|
#pod |
224
|
|
|
|
|
|
|
#pod This method executes a C request and sends the key/value pairs from a |
225
|
|
|
|
|
|
|
#pod form data hash or array reference to the given URL with a C of |
226
|
|
|
|
|
|
|
#pod C. If data is provided as an array |
227
|
|
|
|
|
|
|
#pod reference, the order is preserved; if provided as a hash reference, the terms |
228
|
|
|
|
|
|
|
#pod are sorted on key and value for consistency. See documentation for the |
229
|
|
|
|
|
|
|
#pod C method for details on the encoding. |
230
|
|
|
|
|
|
|
#pod |
231
|
|
|
|
|
|
|
#pod The URL must have unsafe characters escaped and international domain names |
232
|
|
|
|
|
|
|
#pod encoded. See C for valid options and a description of the response. |
233
|
|
|
|
|
|
|
#pod Any C header or content in the options hashref will be ignored. |
234
|
|
|
|
|
|
|
#pod |
235
|
|
|
|
|
|
|
#pod The C field of the response will be true if the status code is 2XX. |
236
|
|
|
|
|
|
|
#pod |
237
|
|
|
|
|
|
|
#pod =cut |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
sub post_form { |
240
|
6
|
|
|
6
|
1
|
974
|
my ($self, $url, $data, $args) = @_; |
241
|
6
|
50
|
33
|
|
|
18
|
(@_ == 3 || @_ == 4 && ref $args eq 'HASH') |
|
|
|
66
|
|
|
|
|
242
|
|
|
|
|
|
|
or _croak(q/Usage: $http->post_form(URL, DATAREF, [HASHREF])/ . "\n"); |
243
|
|
|
|
|
|
|
|
244
|
6
|
|
|
|
|
10
|
my $headers = {}; |
245
|
6
|
100
|
|
|
|
9
|
while ( my ($key, $value) = each %{$args->{headers} || {}} ) { |
|
7
|
|
|
|
|
53
|
|
246
|
1
|
|
|
|
|
5
|
$headers->{lc $key} = $value; |
247
|
|
|
|
|
|
|
} |
248
|
|
|
|
|
|
|
|
249
|
6
|
|
|
|
|
28
|
return $self->request('POST', $url, { |
250
|
|
|
|
|
|
|
# Any existing 'headers' key in $args will be overridden with a |
251
|
|
|
|
|
|
|
# normalized version below. |
252
|
|
|
|
|
|
|
%$args, |
253
|
|
|
|
|
|
|
content => $self->www_form_urlencode($data), |
254
|
|
|
|
|
|
|
headers => { |
255
|
|
|
|
|
|
|
%$headers, |
256
|
|
|
|
|
|
|
'content-type' => 'application/x-www-form-urlencoded' |
257
|
|
|
|
|
|
|
}, |
258
|
|
|
|
|
|
|
} |
259
|
|
|
|
|
|
|
); |
260
|
|
|
|
|
|
|
} |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
#pod =method mirror |
263
|
|
|
|
|
|
|
#pod |
264
|
|
|
|
|
|
|
#pod $response = $http->mirror($url, $file, \%options) |
265
|
|
|
|
|
|
|
#pod if ( $response->{success} ) { |
266
|
|
|
|
|
|
|
#pod print "$file is up to date\n"; |
267
|
|
|
|
|
|
|
#pod } |
268
|
|
|
|
|
|
|
#pod |
269
|
|
|
|
|
|
|
#pod Executes a C request for the URL and saves the response body to the file |
270
|
|
|
|
|
|
|
#pod name provided. The URL must have unsafe characters escaped and international |
271
|
|
|
|
|
|
|
#pod domain names encoded. If the file already exists, the request will include an |
272
|
|
|
|
|
|
|
#pod C header with the modification timestamp of the file. You |
273
|
|
|
|
|
|
|
#pod may specify a different C header yourself in the C<< |
274
|
|
|
|
|
|
|
#pod $options->{headers} >> hash. |
275
|
|
|
|
|
|
|
#pod |
276
|
|
|
|
|
|
|
#pod The C field of the response will be true if the status code is 2XX |
277
|
|
|
|
|
|
|
#pod or if the status code is 304 (unmodified). |
278
|
|
|
|
|
|
|
#pod |
279
|
|
|
|
|
|
|
#pod If the file was modified and the server response includes a properly |
280
|
|
|
|
|
|
|
#pod formatted C header, the file modification time will |
281
|
|
|
|
|
|
|
#pod be updated accordingly. |
282
|
|
|
|
|
|
|
#pod |
283
|
|
|
|
|
|
|
#pod =cut |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
sub mirror { |
286
|
9
|
|
|
9
|
1
|
2026
|
my ($self, $url, $file, $args) = @_; |
287
|
9
|
100
|
100
|
|
|
52
|
@_ == 3 || (@_ == 4 && ref $args eq 'HASH') |
|
|
|
100
|
|
|
|
|
288
|
|
|
|
|
|
|
or _croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ . "\n"); |
289
|
|
|
|
|
|
|
|
290
|
5
|
100
|
|
|
|
10
|
if ( exists $args->{headers} ) { |
291
|
1
|
|
|
|
|
2
|
my $headers = {}; |
292
|
1
|
50
|
|
|
|
2
|
while ( my ($key, $value) = each %{$args->{headers} || {}} ) { |
|
2
|
|
|
|
|
13
|
|
293
|
1
|
|
|
|
|
4
|
$headers->{lc $key} = $value; |
294
|
|
|
|
|
|
|
} |
295
|
1
|
|
|
|
|
2
|
$args->{headers} = $headers; |
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
|
298
|
5
|
100
|
66
|
|
|
84
|
if ( -e $file and my $mtime = (stat($file))[9] ) { |
299
|
3
|
|
66
|
|
|
19
|
$args->{headers}{'if-modified-since'} ||= $self->_http_date($mtime); |
300
|
|
|
|
|
|
|
} |
301
|
5
|
|
|
|
|
20
|
my $tempfile = $file . int(rand(2**31)); |
302
|
|
|
|
|
|
|
|
303
|
5
|
|
|
|
|
24
|
require Fcntl; |
304
|
5
|
50
|
|
|
|
281
|
sysopen my $fh, $tempfile, Fcntl::O_CREAT()|Fcntl::O_EXCL()|Fcntl::O_WRONLY() |
305
|
|
|
|
|
|
|
or _croak(qq/Error: Could not create temporary file $tempfile for downloading: $!\n/); |
306
|
5
|
|
|
|
|
22
|
binmode $fh; |
307
|
5
|
|
|
3
|
|
23
|
$args->{data_callback} = sub { print {$fh} $_[0] }; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
35
|
|
308
|
5
|
|
|
|
|
14
|
my $response = $self->request('GET', $url, $args); |
309
|
5
|
50
|
|
|
|
113
|
close $fh |
310
|
|
|
|
|
|
|
or _croak(qq/Error: Caught error closing temporary file $tempfile: $!\n/); |
311
|
|
|
|
|
|
|
|
312
|
5
|
100
|
|
|
|
18
|
if ( $response->{success} ) { |
313
|
3
|
50
|
|
|
|
202
|
rename $tempfile, $file |
314
|
|
|
|
|
|
|
or _croak(qq/Error replacing $file with $tempfile: $!\n/); |
315
|
3
|
|
|
|
|
13
|
my $lm = $response->{headers}{'last-modified'}; |
316
|
3
|
50
|
33
|
|
|
12
|
if ( $lm and my $mtime = $self->_parse_http_date($lm) ) { |
317
|
3
|
|
|
|
|
47
|
utime $mtime, $mtime, $file; |
318
|
|
|
|
|
|
|
} |
319
|
|
|
|
|
|
|
} |
320
|
5
|
|
100
|
|
|
20
|
$response->{success} ||= $response->{status} eq '304'; |
321
|
5
|
|
|
|
|
94
|
unlink $tempfile; |
322
|
5
|
|
|
|
|
39
|
return $response; |
323
|
|
|
|
|
|
|
} |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
#pod =method request |
326
|
|
|
|
|
|
|
#pod |
327
|
|
|
|
|
|
|
#pod $response = $http->request($method, $url); |
328
|
|
|
|
|
|
|
#pod $response = $http->request($method, $url, \%options); |
329
|
|
|
|
|
|
|
#pod |
330
|
|
|
|
|
|
|
#pod Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST', |
331
|
|
|
|
|
|
|
#pod 'PUT', etc.) on the given URL. The URL must have unsafe characters escaped and |
332
|
|
|
|
|
|
|
#pod international domain names encoded. |
333
|
|
|
|
|
|
|
#pod |
334
|
|
|
|
|
|
|
#pod B: Method names are B per the HTTP/1.1 specification. |
335
|
|
|
|
|
|
|
#pod Don't use C when you really want C. See L for |
336
|
|
|
|
|
|
|
#pod how this applies to redirection. |
337
|
|
|
|
|
|
|
#pod |
338
|
|
|
|
|
|
|
#pod If the URL includes a "user:password" stanza, they will be used for Basic-style |
339
|
|
|
|
|
|
|
#pod authorization headers. (Authorization headers will not be included in a |
340
|
|
|
|
|
|
|
#pod redirected request.) For example: |
341
|
|
|
|
|
|
|
#pod |
342
|
|
|
|
|
|
|
#pod $http->request('GET', 'http://Aladdin:open sesame@example.com/'); |
343
|
|
|
|
|
|
|
#pod |
344
|
|
|
|
|
|
|
#pod If the "user:password" stanza contains reserved characters, they must |
345
|
|
|
|
|
|
|
#pod be percent-escaped: |
346
|
|
|
|
|
|
|
#pod |
347
|
|
|
|
|
|
|
#pod $http->request('GET', 'http://john%40example.com:password@example.com/'); |
348
|
|
|
|
|
|
|
#pod |
349
|
|
|
|
|
|
|
#pod A hashref of options may be appended to modify the request. |
350
|
|
|
|
|
|
|
#pod |
351
|
|
|
|
|
|
|
#pod Valid options are: |
352
|
|
|
|
|
|
|
#pod |
353
|
|
|
|
|
|
|
#pod =for :list |
354
|
|
|
|
|
|
|
#pod * C — |
355
|
|
|
|
|
|
|
#pod A hashref containing headers to include with the request. If the value for |
356
|
|
|
|
|
|
|
#pod a header is an array reference, the header will be output multiple times with |
357
|
|
|
|
|
|
|
#pod each value in the array. These headers over-write any default headers. |
358
|
|
|
|
|
|
|
#pod * C — |
359
|
|
|
|
|
|
|
#pod A scalar to include as the body of the request OR a code reference |
360
|
|
|
|
|
|
|
#pod that will be called iteratively to produce the body of the request |
361
|
|
|
|
|
|
|
#pod * C — |
362
|
|
|
|
|
|
|
#pod A code reference that will be called if it exists to provide a hashref |
363
|
|
|
|
|
|
|
#pod of trailing headers (only used with chunked transfer-encoding) |
364
|
|
|
|
|
|
|
#pod * C — |
365
|
|
|
|
|
|
|
#pod A code reference that will be called for each chunks of the response |
366
|
|
|
|
|
|
|
#pod body received. |
367
|
|
|
|
|
|
|
#pod * C — |
368
|
|
|
|
|
|
|
#pod Override host resolution and force all connections to go only to a |
369
|
|
|
|
|
|
|
#pod specific peer address, regardless of the URL of the request. This will |
370
|
|
|
|
|
|
|
#pod include any redirections! This options should be used with extreme |
371
|
|
|
|
|
|
|
#pod caution (e.g. debugging or very special circumstances). It can be given as |
372
|
|
|
|
|
|
|
#pod either a scalar or a code reference that will receive the hostname and |
373
|
|
|
|
|
|
|
#pod whose response will be taken as the address. |
374
|
|
|
|
|
|
|
#pod |
375
|
|
|
|
|
|
|
#pod The C header is generated from the URL in accordance with RFC 2616. It |
376
|
|
|
|
|
|
|
#pod is a fatal error to specify C in the C option. Other headers |
377
|
|
|
|
|
|
|
#pod may be ignored or overwritten if necessary for transport compliance. |
378
|
|
|
|
|
|
|
#pod |
379
|
|
|
|
|
|
|
#pod If the C option is a code reference, it will be called iteratively |
380
|
|
|
|
|
|
|
#pod to provide the content body of the request. It should return the empty |
381
|
|
|
|
|
|
|
#pod string or undef when the iterator is exhausted. |
382
|
|
|
|
|
|
|
#pod |
383
|
|
|
|
|
|
|
#pod If the C option is the empty string, no C or |
384
|
|
|
|
|
|
|
#pod C headers will be generated. |
385
|
|
|
|
|
|
|
#pod |
386
|
|
|
|
|
|
|
#pod If the C option is provided, it will be called iteratively until |
387
|
|
|
|
|
|
|
#pod the entire response body is received. The first argument will be a string |
388
|
|
|
|
|
|
|
#pod containing a chunk of the response body, the second argument will be the |
389
|
|
|
|
|
|
|
#pod in-progress response hash reference, as described below. (This allows |
390
|
|
|
|
|
|
|
#pod customizing the action of the callback based on the C or C |
391
|
|
|
|
|
|
|
#pod received prior to the content body.) |
392
|
|
|
|
|
|
|
#pod |
393
|
|
|
|
|
|
|
#pod Content data in the request/response is handled as "raw bytes". Any |
394
|
|
|
|
|
|
|
#pod encoding/decoding (with associated headers) are the responsibility of the |
395
|
|
|
|
|
|
|
#pod caller. |
396
|
|
|
|
|
|
|
#pod |
397
|
|
|
|
|
|
|
#pod The C method returns a hashref containing the response. The hashref |
398
|
|
|
|
|
|
|
#pod will have the following keys: |
399
|
|
|
|
|
|
|
#pod |
400
|
|
|
|
|
|
|
#pod =for :list |
401
|
|
|
|
|
|
|
#pod * C — |
402
|
|
|
|
|
|
|
#pod Boolean indicating whether the operation returned a 2XX status code |
403
|
|
|
|
|
|
|
#pod * C — |
404
|
|
|
|
|
|
|
#pod URL that provided the response. This is the URL of the request unless |
405
|
|
|
|
|
|
|
#pod there were redirections, in which case it is the last URL queried |
406
|
|
|
|
|
|
|
#pod in a redirection chain |
407
|
|
|
|
|
|
|
#pod * C — |
408
|
|
|
|
|
|
|
#pod The HTTP status code of the response |
409
|
|
|
|
|
|
|
#pod * C — |
410
|
|
|
|
|
|
|
#pod The response phrase returned by the server |
411
|
|
|
|
|
|
|
#pod * C — |
412
|
|
|
|
|
|
|
#pod The body of the response. If the response does not have any content |
413
|
|
|
|
|
|
|
#pod or if a data callback is provided to consume the response body, |
414
|
|
|
|
|
|
|
#pod this will be the empty string |
415
|
|
|
|
|
|
|
#pod * C — |
416
|
|
|
|
|
|
|
#pod A hashref of header fields. All header field names will be normalized |
417
|
|
|
|
|
|
|
#pod to be lower case. If a header is repeated, the value will be an arrayref; |
418
|
|
|
|
|
|
|
#pod it will otherwise be a scalar string containing the value |
419
|
|
|
|
|
|
|
#pod * C - |
420
|
|
|
|
|
|
|
#pod If this field exists, it is the protocol of the response |
421
|
|
|
|
|
|
|
#pod such as HTTP/1.0 or HTTP/1.1 |
422
|
|
|
|
|
|
|
#pod * C |
423
|
|
|
|
|
|
|
#pod If this field exists, it is an arrayref of response hash references from |
424
|
|
|
|
|
|
|
#pod redirects in the same order that redirections occurred. If it does |
425
|
|
|
|
|
|
|
#pod not exist, then no redirections occurred. |
426
|
|
|
|
|
|
|
#pod |
427
|
|
|
|
|
|
|
#pod On an error during the execution of the request, the C field will |
428
|
|
|
|
|
|
|
#pod contain 599, and the C field will contain the text of the error. |
429
|
|
|
|
|
|
|
#pod |
430
|
|
|
|
|
|
|
#pod =cut |
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
my %idempotent = map { $_ => 1 } qw/GET HEAD PUT DELETE OPTIONS TRACE/; |
433
|
|
|
|
|
|
|
|
434
|
|
|
|
|
|
|
sub request { |
435
|
143
|
|
|
143
|
1
|
8366
|
my ($self, $method, $url, $args) = @_; |
436
|
143
|
100
|
100
|
|
|
731
|
@_ == 3 || (@_ == 4 && ref $args eq 'HASH') |
|
|
|
100
|
|
|
|
|
437
|
|
|
|
|
|
|
or _croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/ . "\n"); |
438
|
139
|
|
100
|
|
|
334
|
$args ||= {}; # we keep some state in this during _request |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
# RFC 2616 Section 8.1.4 mandates a single retry on broken socket |
441
|
139
|
|
|
|
|
176
|
my $response; |
442
|
139
|
|
|
|
|
348
|
for ( 0 .. 1 ) { |
443
|
139
|
|
|
|
|
194
|
$response = eval { $self->_request($method, $url, $args) }; |
|
139
|
|
|
|
|
322
|
|
444
|
139
|
50
|
66
|
|
|
1085
|
last unless $@ && $idempotent{$method} |
|
|
|
33
|
|
|
|
|
445
|
|
|
|
|
|
|
&& $@ =~ m{^(?:Socket closed|Unexpected end|SSL read error)}; |
446
|
|
|
|
|
|
|
} |
447
|
|
|
|
|
|
|
|
448
|
139
|
100
|
|
|
|
375
|
if (my $e = $@) { |
449
|
|
|
|
|
|
|
# maybe we got a response hash thrown from somewhere deep |
450
|
10
|
0
|
33
|
|
|
204
|
if ( ref $e eq 'HASH' && exists $e->{status} ) { |
451
|
0
|
0
|
|
|
|
0
|
$e->{redirects} = delete $args->{_redirects} if @{ $args->{_redirects} || []}; |
|
0
|
0
|
|
|
|
0
|
|
452
|
0
|
|
|
|
|
0
|
return $e; |
453
|
|
|
|
|
|
|
} |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
# otherwise, stringify it |
456
|
10
|
|
|
|
|
27
|
$e = "$e"; |
457
|
|
|
|
|
|
|
$response = { |
458
|
|
|
|
|
|
|
url => $url, |
459
|
|
|
|
|
|
|
success => q{}, |
460
|
|
|
|
|
|
|
status => 599, |
461
|
|
|
|
|
|
|
reason => 'Internal Exception', |
462
|
|
|
|
|
|
|
content => $e, |
463
|
|
|
|
|
|
|
headers => { |
464
|
|
|
|
|
|
|
'content-type' => 'text/plain', |
465
|
|
|
|
|
|
|
'content-length' => length $e, |
466
|
|
|
|
|
|
|
}, |
467
|
10
|
100
|
|
|
|
47
|
( @{$args->{_redirects} || []} ? (redirects => delete $args->{_redirects}) : () ), |
|
10
|
50
|
|
|
|
110
|
|
468
|
|
|
|
|
|
|
}; |
469
|
|
|
|
|
|
|
} |
470
|
139
|
|
|
|
|
442
|
return $response; |
471
|
|
|
|
|
|
|
} |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
#pod =method www_form_urlencode |
474
|
|
|
|
|
|
|
#pod |
475
|
|
|
|
|
|
|
#pod $params = $http->www_form_urlencode( $data ); |
476
|
|
|
|
|
|
|
#pod $response = $http->get("http://example.com/query?$params"); |
477
|
|
|
|
|
|
|
#pod |
478
|
|
|
|
|
|
|
#pod This method converts the key/value pairs from a data hash or array reference |
479
|
|
|
|
|
|
|
#pod into a C string. The keys and values from the data |
480
|
|
|
|
|
|
|
#pod reference will be UTF-8 encoded and escaped per RFC 3986. If a value is an |
481
|
|
|
|
|
|
|
#pod array reference, the key will be repeated with each of the values of the array |
482
|
|
|
|
|
|
|
#pod reference. If data is provided as a hash reference, the key/value pairs in the |
483
|
|
|
|
|
|
|
#pod resulting string will be sorted by key and value for consistent ordering. |
484
|
|
|
|
|
|
|
#pod |
485
|
|
|
|
|
|
|
#pod =cut |
486
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
sub www_form_urlencode { |
488
|
6
|
|
|
6
|
1
|
10
|
my ($self, $data) = @_; |
489
|
6
|
50
|
33
|
|
|
23
|
(@_ == 2 && ref $data) |
490
|
|
|
|
|
|
|
or _croak(q/Usage: $http->www_form_urlencode(DATAREF)/ . "\n"); |
491
|
6
|
50
|
66
|
|
|
24
|
(ref $data eq 'HASH' || ref $data eq 'ARRAY') |
492
|
|
|
|
|
|
|
or _croak("form data must be a hash or array reference\n"); |
493
|
|
|
|
|
|
|
|
494
|
6
|
100
|
|
|
|
21
|
my @params = ref $data eq 'HASH' ? %$data : @$data; |
495
|
6
|
50
|
|
|
|
16
|
@params % 2 == 0 |
496
|
|
|
|
|
|
|
or _croak("form data reference must have an even number of terms\n"); |
497
|
|
|
|
|
|
|
|
498
|
6
|
|
|
|
|
6
|
my @terms; |
499
|
6
|
|
|
|
|
12
|
while( @params ) { |
500
|
14
|
|
|
|
|
27
|
my ($key, $value) = splice(@params, 0, 2); |
501
|
14
|
100
|
|
|
|
23
|
_croak("form data keys must not be undef") |
502
|
|
|
|
|
|
|
if !defined($key); |
503
|
13
|
50
|
|
|
|
20
|
if ( ref $value eq 'ARRAY' ) { |
504
|
0
|
|
|
|
|
0
|
unshift @params, map { $key => $_ } @$value; |
|
0
|
|
|
|
|
0
|
|
505
|
|
|
|
|
|
|
} |
506
|
|
|
|
|
|
|
else { |
507
|
13
|
|
|
|
|
35
|
push @terms, join("=", map { $self->_uri_escape($_) } $key, $value); |
|
26
|
|
|
|
|
36
|
|
508
|
|
|
|
|
|
|
} |
509
|
|
|
|
|
|
|
} |
510
|
|
|
|
|
|
|
|
511
|
5
|
100
|
|
|
|
37
|
return join("&", (ref $data eq 'ARRAY') ? (@terms) : (sort @terms) ); |
512
|
|
|
|
|
|
|
} |
513
|
|
|
|
|
|
|
|
514
|
|
|
|
|
|
|
#pod =method can_ssl |
515
|
|
|
|
|
|
|
#pod |
516
|
|
|
|
|
|
|
#pod $ok = HTTP::Tiny->can_ssl; |
517
|
|
|
|
|
|
|
#pod ($ok, $why) = HTTP::Tiny->can_ssl; |
518
|
|
|
|
|
|
|
#pod ($ok, $why) = $http->can_ssl; |
519
|
|
|
|
|
|
|
#pod |
520
|
|
|
|
|
|
|
#pod Indicates if SSL support is available. When called as a class object, it |
521
|
|
|
|
|
|
|
#pod checks for the correct version of L and L. |
522
|
|
|
|
|
|
|
#pod When called as an object methods, if C is true or if C |
523
|
|
|
|
|
|
|
#pod is set in C, it checks that a CA file is available. |
524
|
|
|
|
|
|
|
#pod |
525
|
|
|
|
|
|
|
#pod In scalar context, returns a boolean indicating if SSL is available. |
526
|
|
|
|
|
|
|
#pod In list context, returns the boolean and a (possibly multi-line) string of |
527
|
|
|
|
|
|
|
#pod errors indicating why SSL isn't available. |
528
|
|
|
|
|
|
|
#pod |
529
|
|
|
|
|
|
|
#pod =cut |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
sub can_ssl { |
532
|
13
|
|
|
13
|
1
|
107847
|
my ($self) = @_; |
533
|
|
|
|
|
|
|
|
534
|
13
|
|
|
|
|
57
|
my($ok, $reason) = (1, ''); |
535
|
|
|
|
|
|
|
|
536
|
|
|
|
|
|
|
# Need IO::Socket::SSL 1.42 for SSL_create_ctx_callback |
537
|
13
|
|
|
|
|
162
|
local @INC = @INC; |
538
|
13
|
50
|
|
|
|
59
|
pop @INC if $INC[-1] eq '.'; |
539
|
13
|
50
|
|
|
|
43
|
unless (eval {require IO::Socket::SSL; IO::Socket::SSL->VERSION(1.42)}) { |
|
13
|
|
|
|
|
142
|
|
|
13
|
|
|
|
|
447
|
|
540
|
0
|
|
|
|
|
0
|
$ok = 0; |
541
|
0
|
|
|
|
|
0
|
$reason .= qq/IO::Socket::SSL 1.42 must be installed for https support\n/; |
542
|
|
|
|
|
|
|
} |
543
|
|
|
|
|
|
|
|
544
|
|
|
|
|
|
|
# Need Net::SSLeay 1.49 for MODE_AUTO_RETRY |
545
|
13
|
50
|
|
|
|
45
|
unless (eval {require Net::SSLeay; Net::SSLeay->VERSION(1.49)}) { |
|
13
|
|
|
|
|
61
|
|
|
13
|
|
|
|
|
215
|
|
546
|
0
|
|
|
|
|
0
|
$ok = 0; |
547
|
0
|
|
|
|
|
0
|
$reason .= qq/Net::SSLeay 1.49 must be installed for https support\n/; |
548
|
|
|
|
|
|
|
} |
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
# If an object, check that SSL config lets us get a CA if necessary |
551
|
13
|
100
|
66
|
|
|
92
|
if ( ref($self) && ( $self->{verify_SSL} || $self->{SSL_options}{SSL_verify_mode} ) ) { |
|
|
|
66
|
|
|
|
|
552
|
|
|
|
|
|
|
my $handle = HTTP::Tiny::Handle->new( |
553
|
|
|
|
|
|
|
SSL_options => $self->{SSL_options}, |
554
|
|
|
|
|
|
|
verify_SSL => $self->{verify_SSL}, |
555
|
2
|
|
|
|
|
51
|
); |
556
|
2
|
100
|
|
|
|
24
|
unless ( eval { $handle->_find_CA_file; 1 } ) { |
|
2
|
|
|
|
|
24
|
|
|
1
|
|
|
|
|
122
|
|
557
|
1
|
|
|
|
|
22
|
$ok = 0; |
558
|
1
|
|
|
|
|
6
|
$reason .= "$@"; |
559
|
|
|
|
|
|
|
} |
560
|
|
|
|
|
|
|
} |
561
|
|
|
|
|
|
|
|
562
|
13
|
100
|
|
|
|
105
|
wantarray ? ($ok, $reason) : $ok; |
563
|
|
|
|
|
|
|
} |
564
|
|
|
|
|
|
|
|
565
|
|
|
|
|
|
|
#pod =method connected |
566
|
|
|
|
|
|
|
#pod |
567
|
|
|
|
|
|
|
#pod $host = $http->connected; |
568
|
|
|
|
|
|
|
#pod ($host, $port) = $http->connected; |
569
|
|
|
|
|
|
|
#pod |
570
|
|
|
|
|
|
|
#pod Indicates if a connection to a peer is being kept alive, per the C |
571
|
|
|
|
|
|
|
#pod option. |
572
|
|
|
|
|
|
|
#pod |
573
|
|
|
|
|
|
|
#pod In scalar context, returns the peer host and port, joined with a colon, or |
574
|
|
|
|
|
|
|
#pod C (if no peer is connected). |
575
|
|
|
|
|
|
|
#pod In list context, returns the peer host and port or an empty list (if no peer |
576
|
|
|
|
|
|
|
#pod is connected). |
577
|
|
|
|
|
|
|
#pod |
578
|
|
|
|
|
|
|
#pod B: This method cannot reliably be used to discover whether the remote |
579
|
|
|
|
|
|
|
#pod host has closed its end of the socket. |
580
|
|
|
|
|
|
|
#pod |
581
|
|
|
|
|
|
|
#pod =cut |
582
|
|
|
|
|
|
|
|
583
|
|
|
|
|
|
|
sub connected { |
584
|
0
|
|
|
0
|
1
|
0
|
my ($self) = @_; |
585
|
|
|
|
|
|
|
|
586
|
0
|
0
|
|
|
|
0
|
if ( $self->{handle} ) { |
587
|
0
|
|
|
|
|
0
|
return $self->{handle}->connected; |
588
|
|
|
|
|
|
|
} |
589
|
0
|
|
|
|
|
0
|
return; |
590
|
|
|
|
|
|
|
} |
591
|
|
|
|
|
|
|
|
592
|
|
|
|
|
|
|
#--------------------------------------------------------------------------# |
593
|
|
|
|
|
|
|
# private methods |
594
|
|
|
|
|
|
|
#--------------------------------------------------------------------------# |
595
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
my %DefaultPort = ( |
597
|
|
|
|
|
|
|
http => 80, |
598
|
|
|
|
|
|
|
https => 443, |
599
|
|
|
|
|
|
|
); |
600
|
|
|
|
|
|
|
|
601
|
|
|
|
|
|
|
sub _agent { |
602
|
144
|
|
66
|
144
|
|
481
|
my $class = ref($_[0]) || $_[0]; |
603
|
144
|
|
|
|
|
596
|
(my $default_agent = $class) =~ s{::}{-}g; |
604
|
144
|
|
|
|
|
1145
|
my $version = $class->VERSION; |
605
|
144
|
50
|
|
|
|
559
|
$default_agent .= "/$version" if defined $version; |
606
|
144
|
|
|
|
|
470
|
return $default_agent; |
607
|
|
|
|
|
|
|
} |
608
|
|
|
|
|
|
|
|
609
|
|
|
|
|
|
|
sub _request { |
610
|
150
|
|
|
150
|
|
366
|
my ($self, $method, $url, $args) = @_; |
611
|
|
|
|
|
|
|
|
612
|
150
|
|
|
|
|
314
|
my ($scheme, $host, $port, $path_query, $auth) = $self->_split_url($url); |
613
|
|
|
|
|
|
|
|
614
|
150
|
100
|
100
|
|
|
425
|
if ($scheme ne 'http' && $scheme ne 'https') { |
615
|
1
|
|
|
|
|
4
|
die(qq/Unsupported URL scheme '$scheme'\n/); |
616
|
|
|
|
|
|
|
} |
617
|
|
|
|
|
|
|
|
618
|
|
|
|
|
|
|
my $request = { |
619
|
|
|
|
|
|
|
method => $method, |
620
|
|
|
|
|
|
|
scheme => $scheme, |
621
|
|
|
|
|
|
|
host => $host, |
622
|
|
|
|
|
|
|
port => $port, |
623
|
149
|
100
|
|
|
|
974
|
host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"), |
624
|
|
|
|
|
|
|
uri => $path_query, |
625
|
|
|
|
|
|
|
headers => {}, |
626
|
|
|
|
|
|
|
}; |
627
|
|
|
|
|
|
|
|
628
|
149
|
|
33
|
|
|
480
|
my $peer = $args->{peer} || $host; |
629
|
|
|
|
|
|
|
|
630
|
|
|
|
|
|
|
# Allow 'peer' to be a coderef. |
631
|
149
|
50
|
|
|
|
312
|
if ('CODE' eq ref $peer) { |
632
|
0
|
|
|
|
|
0
|
$peer = $peer->($host); |
633
|
|
|
|
|
|
|
} |
634
|
|
|
|
|
|
|
|
635
|
|
|
|
|
|
|
# We remove the cached handle so it is not reused in the case of redirect. |
636
|
|
|
|
|
|
|
# If all is well, it will be recached at the end of _request. We only |
637
|
|
|
|
|
|
|
# reuse for the same scheme, host and port |
638
|
149
|
|
|
|
|
225
|
my $handle = delete $self->{handle}; |
639
|
149
|
100
|
|
|
|
263
|
if ( $handle ) { |
640
|
13
|
100
|
|
|
|
29
|
unless ( $handle->can_reuse( $scheme, $host, $port, $peer ) ) { |
641
|
10
|
|
|
|
|
53
|
$handle->close; |
642
|
10
|
|
|
|
|
158
|
undef $handle; |
643
|
|
|
|
|
|
|
} |
644
|
|
|
|
|
|
|
} |
645
|
149
|
|
100
|
|
|
533
|
$handle ||= $self->_open_handle( $request, $scheme, $host, $port, $peer ); |
646
|
|
|
|
|
|
|
|
647
|
145
|
|
|
|
|
830
|
$self->_prepare_headers_and_cb($request, $args, $url, $auth); |
648
|
144
|
|
|
|
|
426
|
$handle->write_request($request); |
649
|
|
|
|
|
|
|
|
650
|
143
|
|
|
|
|
1170
|
my $response; |
651
|
145
|
|
|
|
|
289
|
do { $response = $handle->read_response_header } |
652
|
143
|
|
|
|
|
170
|
until (substr($response->{status},0,1) ne '1'); |
653
|
|
|
|
|
|
|
|
654
|
141
|
100
|
|
|
|
414
|
$self->_update_cookie_jar( $url, $response ) if $self->{cookie_jar}; |
655
|
141
|
|
|
|
|
350
|
my @redir_args = $self->_maybe_redirect($request, $response, $args); |
656
|
|
|
|
|
|
|
|
657
|
141
|
|
|
|
|
161
|
my $known_message_length; |
658
|
141
|
100
|
100
|
|
|
510
|
if ($method eq 'HEAD' || $response->{status} =~ /^[23]04/) { |
659
|
|
|
|
|
|
|
# response has no message body |
660
|
2
|
|
|
|
|
4
|
$known_message_length = 1; |
661
|
|
|
|
|
|
|
} |
662
|
|
|
|
|
|
|
else { |
663
|
|
|
|
|
|
|
# Ignore any data callbacks during redirection. |
664
|
139
|
100
|
|
|
|
295
|
my $cb_args = @redir_args ? +{} : $args; |
665
|
139
|
|
|
|
|
293
|
my $data_cb = $self->_prepare_data_cb($response, $cb_args); |
666
|
139
|
|
|
|
|
302
|
$known_message_length = $handle->read_body($data_cb, $response); |
667
|
|
|
|
|
|
|
} |
668
|
|
|
|
|
|
|
|
669
|
140
|
100
|
66
|
|
|
514
|
if ( $self->{keep_alive} |
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
670
|
|
|
|
|
|
|
&& $handle->connected |
671
|
|
|
|
|
|
|
&& $known_message_length |
672
|
|
|
|
|
|
|
&& $response->{protocol} eq 'HTTP/1.1' |
673
|
|
|
|
|
|
|
&& ($response->{headers}{connection} || '') ne 'close' |
674
|
|
|
|
|
|
|
) { |
675
|
29
|
|
|
|
|
1516
|
$self->{handle} = $handle; |
676
|
|
|
|
|
|
|
} |
677
|
|
|
|
|
|
|
else { |
678
|
111
|
|
|
|
|
317
|
$handle->close; |
679
|
|
|
|
|
|
|
} |
680
|
|
|
|
|
|
|
|
681
|
140
|
|
|
|
|
474
|
$response->{success} = substr( $response->{status}, 0, 1 ) eq '2'; |
682
|
140
|
|
|
|
|
223
|
$response->{url} = $url; |
683
|
|
|
|
|
|
|
|
684
|
|
|
|
|
|
|
# Push the current response onto the stack of redirects if redirecting. |
685
|
140
|
100
|
|
|
|
306
|
if (@redir_args) { |
686
|
11
|
|
|
|
|
12
|
push @{$args->{_redirects}}, $response; |
|
11
|
|
|
|
|
23
|
|
687
|
11
|
|
|
|
|
29
|
return $self->_request(@redir_args, $args); |
688
|
|
|
|
|
|
|
} |
689
|
|
|
|
|
|
|
|
690
|
|
|
|
|
|
|
# Copy the stack of redirects into the response before returning. |
691
|
|
|
|
|
|
|
$response->{redirects} = delete $args->{_redirects} |
692
|
129
|
100
|
|
|
|
155
|
if @{$args->{_redirects}}; |
|
129
|
|
|
|
|
298
|
|
693
|
129
|
|
|
|
|
996
|
return $response; |
694
|
|
|
|
|
|
|
} |
695
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
sub _open_handle { |
697
|
146
|
|
|
146
|
|
316
|
my ($self, $request, $scheme, $host, $port, $peer) = @_; |
698
|
|
|
|
|
|
|
|
699
|
|
|
|
|
|
|
my $handle = HTTP::Tiny::Handle->new( |
700
|
|
|
|
|
|
|
timeout => $self->{timeout}, |
701
|
|
|
|
|
|
|
SSL_options => $self->{SSL_options}, |
702
|
|
|
|
|
|
|
verify_SSL => $self->{verify_SSL}, |
703
|
|
|
|
|
|
|
local_address => $self->{local_address}, |
704
|
|
|
|
|
|
|
keep_alive => $self->{keep_alive} |
705
|
146
|
|
|
|
|
835
|
); |
706
|
|
|
|
|
|
|
|
707
|
146
|
100
|
66
|
|
|
605
|
if ($self->{_has_proxy}{$scheme} && ! grep { $host =~ /\Q$_\E$/ } @{$self->{no_proxy}}) { |
|
0
|
|
|
|
|
0
|
|
|
2
|
|
|
|
|
9
|
|
708
|
2
|
|
|
|
|
7
|
return $self->_proxy_connect( $request, $handle ); |
709
|
|
|
|
|
|
|
} |
710
|
|
|
|
|
|
|
else { |
711
|
144
|
|
|
|
|
449
|
return $handle->connect($scheme, $host, $port, $peer); |
712
|
|
|
|
|
|
|
} |
713
|
|
|
|
|
|
|
} |
714
|
|
|
|
|
|
|
|
715
|
|
|
|
|
|
|
sub _proxy_connect { |
716
|
2
|
|
|
2
|
|
8
|
my ($self, $request, $handle) = @_; |
717
|
|
|
|
|
|
|
|
718
|
2
|
|
|
|
|
4
|
my @proxy_vars; |
719
|
2
|
50
|
|
|
|
6
|
if ( $request->{scheme} eq 'https' ) { |
720
|
0
|
0
|
|
|
|
0
|
_croak(qq{No https_proxy defined}) unless $self->{https_proxy}; |
721
|
0
|
|
|
|
|
0
|
@proxy_vars = $self->_split_proxy( https_proxy => $self->{https_proxy} ); |
722
|
0
|
0
|
|
|
|
0
|
if ( $proxy_vars[0] eq 'https' ) { |
723
|
0
|
|
|
|
|
0
|
_croak(qq{Can't proxy https over https: $request->{uri} via $self->{https_proxy}}); |
724
|
|
|
|
|
|
|
} |
725
|
|
|
|
|
|
|
} |
726
|
|
|
|
|
|
|
else { |
727
|
2
|
50
|
|
|
|
6
|
_croak(qq{No http_proxy defined}) unless $self->{http_proxy}; |
728
|
2
|
|
|
|
|
5
|
@proxy_vars = $self->_split_proxy( http_proxy => $self->{http_proxy} ); |
729
|
|
|
|
|
|
|
} |
730
|
|
|
|
|
|
|
|
731
|
2
|
|
|
|
|
6
|
my ($p_scheme, $p_host, $p_port, $p_auth) = @proxy_vars; |
732
|
|
|
|
|
|
|
|
733
|
2
|
100
|
66
|
|
|
13
|
if ( length $p_auth && ! defined $request->{headers}{'proxy-authorization'} ) { |
734
|
1
|
|
|
|
|
2
|
$self->_add_basic_auth_header( $request, 'proxy-authorization' => $p_auth ); |
735
|
|
|
|
|
|
|
} |
736
|
|
|
|
|
|
|
|
737
|
2
|
|
|
|
|
8
|
$handle->connect($p_scheme, $p_host, $p_port, $p_host); |
738
|
|
|
|
|
|
|
|
739
|
2
|
50
|
|
|
|
13
|
if ($request->{scheme} eq 'https') { |
740
|
0
|
|
|
|
|
0
|
$self->_create_proxy_tunnel( $request, $handle ); |
741
|
|
|
|
|
|
|
} |
742
|
|
|
|
|
|
|
else { |
743
|
|
|
|
|
|
|
# non-tunneled proxy requires absolute URI |
744
|
2
|
|
|
|
|
6
|
$request->{uri} = "$request->{scheme}://$request->{host_port}$request->{uri}"; |
745
|
|
|
|
|
|
|
} |
746
|
|
|
|
|
|
|
|
747
|
2
|
|
|
|
|
9
|
return $handle; |
748
|
|
|
|
|
|
|
} |
749
|
|
|
|
|
|
|
|
750
|
|
|
|
|
|
|
sub _split_proxy { |
751
|
22
|
|
|
22
|
|
37
|
my ($self, $type, $proxy) = @_; |
752
|
|
|
|
|
|
|
|
753
|
22
|
|
|
|
|
27
|
my ($scheme, $host, $port, $path_query, $auth) = eval { $self->_split_url($proxy) }; |
|
22
|
|
|
|
|
38
|
|
754
|
|
|
|
|
|
|
|
755
|
22
|
50
|
66
|
|
|
144
|
unless( |
|
|
|
66
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
756
|
|
|
|
|
|
|
defined($scheme) && length($scheme) && length($host) && length($port) |
757
|
|
|
|
|
|
|
&& $path_query eq '/' |
758
|
|
|
|
|
|
|
) { |
759
|
1
|
|
|
|
|
3
|
_croak(qq{$type URL must be in format http[s]://[auth@]:/\n}); |
760
|
|
|
|
|
|
|
} |
761
|
|
|
|
|
|
|
|
762
|
21
|
|
|
|
|
44
|
return ($scheme, $host, $port, $auth); |
763
|
|
|
|
|
|
|
} |
764
|
|
|
|
|
|
|
|
765
|
|
|
|
|
|
|
sub _create_proxy_tunnel { |
766
|
0
|
|
|
0
|
|
0
|
my ($self, $request, $handle) = @_; |
767
|
|
|
|
|
|
|
|
768
|
0
|
|
|
|
|
0
|
$handle->_assert_ssl; |
769
|
|
|
|
|
|
|
|
770
|
|
|
|
|
|
|
my $agent = exists($request->{headers}{'user-agent'}) |
771
|
0
|
0
|
|
|
|
0
|
? $request->{headers}{'user-agent'} : $self->{agent}; |
772
|
|
|
|
|
|
|
|
773
|
0
|
|
|
|
|
0
|
my $connect_request = { |
774
|
|
|
|
|
|
|
method => 'CONNECT', |
775
|
|
|
|
|
|
|
uri => "$request->{host}:$request->{port}", |
776
|
|
|
|
|
|
|
headers => { |
777
|
|
|
|
|
|
|
host => "$request->{host}:$request->{port}", |
778
|
|
|
|
|
|
|
'user-agent' => $agent, |
779
|
|
|
|
|
|
|
} |
780
|
|
|
|
|
|
|
}; |
781
|
|
|
|
|
|
|
|
782
|
0
|
0
|
|
|
|
0
|
if ( $request->{headers}{'proxy-authorization'} ) { |
783
|
|
|
|
|
|
|
$connect_request->{headers}{'proxy-authorization'} = |
784
|
0
|
|
|
|
|
0
|
delete $request->{headers}{'proxy-authorization'}; |
785
|
|
|
|
|
|
|
} |
786
|
|
|
|
|
|
|
|
787
|
0
|
|
|
|
|
0
|
$handle->write_request($connect_request); |
788
|
0
|
|
|
|
|
0
|
my $response; |
789
|
0
|
|
|
|
|
0
|
do { $response = $handle->read_response_header } |
790
|
0
|
|
|
|
|
0
|
until (substr($response->{status},0,1) ne '1'); |
791
|
|
|
|
|
|
|
|
792
|
|
|
|
|
|
|
# if CONNECT failed, throw the response so it will be |
793
|
|
|
|
|
|
|
# returned from the original request() method; |
794
|
0
|
0
|
|
|
|
0
|
unless (substr($response->{status},0,1) eq '2') { |
795
|
0
|
|
|
|
|
0
|
die $response; |
796
|
|
|
|
|
|
|
} |
797
|
|
|
|
|
|
|
|
798
|
|
|
|
|
|
|
# tunnel established, so start SSL handshake |
799
|
0
|
|
|
|
|
0
|
$handle->start_ssl( $request->{host} ); |
800
|
|
|
|
|
|
|
|
801
|
0
|
|
|
|
|
0
|
return; |
802
|
|
|
|
|
|
|
} |
803
|
|
|
|
|
|
|
|
804
|
|
|
|
|
|
|
sub _prepare_headers_and_cb { |
805
|
145
|
|
|
145
|
|
278
|
my ($self, $request, $args, $url, $auth) = @_; |
806
|
|
|
|
|
|
|
|
807
|
145
|
|
|
|
|
394
|
for ($self->{default_headers}, $args->{headers}) { |
808
|
290
|
100
|
|
|
|
548
|
next unless defined; |
809
|
24
|
|
|
|
|
105
|
while (my ($k, $v) = each %$_) { |
810
|
31
|
|
|
|
|
95
|
$request->{headers}{lc $k} = $v; |
811
|
31
|
|
|
|
|
162
|
$request->{header_case}{lc $k} = $k; |
812
|
|
|
|
|
|
|
} |
813
|
|
|
|
|
|
|
} |
814
|
|
|
|
|
|
|
|
815
|
145
|
100
|
|
|
|
283
|
if (exists $request->{headers}{'host'}) { |
816
|
1
|
|
|
|
|
10
|
die(qq/The 'Host' header must not be provided as header option\n/); |
817
|
|
|
|
|
|
|
} |
818
|
|
|
|
|
|
|
|
819
|
144
|
|
|
|
|
270
|
$request->{headers}{'host'} = $request->{host_port}; |
820
|
144
|
|
33
|
|
|
542
|
$request->{headers}{'user-agent'} ||= $self->{agent}; |
821
|
|
|
|
|
|
|
$request->{headers}{'connection'} = "close" |
822
|
144
|
100
|
|
|
|
323
|
unless $self->{keep_alive}; |
823
|
|
|
|
|
|
|
|
824
|
|
|
|
|
|
|
# Some servers error on an empty-body PUT/POST without a content-length |
825
|
144
|
100
|
100
|
|
|
536
|
if ( $request->{method} eq 'PUT' || $request->{method} eq 'POST' ) { |
826
|
42
|
100
|
100
|
|
|
145
|
if (!defined($args->{content}) || !length($args->{content}) ) { |
827
|
16
|
|
|
|
|
26
|
$request->{headers}{'content-length'} = 0; |
828
|
|
|
|
|
|
|
} |
829
|
|
|
|
|
|
|
} |
830
|
|
|
|
|
|
|
|
831
|
144
|
100
|
|
|
|
266
|
if ( defined $args->{content} ) { |
832
|
27
|
100
|
|
|
|
68
|
if ( ref $args->{content} eq 'CODE' ) { |
|
|
100
|
|
|
|
|
|
833
|
5
|
50
|
33
|
|
|
19
|
if ( exists $request->{'content-length'} && $request->{'content-length'} == 0 ) { |
834
|
0
|
|
|
0
|
|
0
|
$request->{cb} = sub { "" }; |
|
0
|
|
|
|
|
0
|
|
835
|
|
|
|
|
|
|
} |
836
|
|
|
|
|
|
|
else { |
837
|
5
|
|
50
|
|
|
11
|
$request->{headers}{'content-type'} ||= "application/octet-stream"; |
838
|
|
|
|
|
|
|
$request->{headers}{'transfer-encoding'} = 'chunked' |
839
|
|
|
|
|
|
|
unless exists $request->{headers}{'content-length'} |
840
|
5
|
50
|
66
|
|
|
15
|
|| $request->{headers}{'transfer-encoding'}; |
841
|
5
|
|
|
|
|
6
|
$request->{cb} = $args->{content}; |
842
|
|
|
|
|
|
|
} |
843
|
|
|
|
|
|
|
} |
844
|
|
|
|
|
|
|
elsif ( length $args->{content} ) { |
845
|
21
|
|
|
|
|
31
|
my $content = $args->{content}; |
846
|
21
|
50
|
|
|
|
44
|
if ( $] ge '5.008' ) { |
847
|
21
|
50
|
|
|
|
52
|
utf8::downgrade($content, 1) |
848
|
|
|
|
|
|
|
or die(qq/Wide character in request message body\n/); |
849
|
|
|
|
|
|
|
} |
850
|
21
|
|
100
|
|
|
77
|
$request->{headers}{'content-type'} ||= "application/octet-stream"; |
851
|
|
|
|
|
|
|
$request->{headers}{'content-length'} = length $content |
852
|
|
|
|
|
|
|
unless $request->{headers}{'content-length'} |
853
|
21
|
50
|
66
|
|
|
70
|
|| $request->{headers}{'transfer-encoding'}; |
854
|
21
|
|
|
42
|
|
82
|
$request->{cb} = sub { substr $content, 0, length $content, '' }; |
|
42
|
|
|
|
|
117
|
|
855
|
|
|
|
|
|
|
} |
856
|
|
|
|
|
|
|
$request->{trailer_cb} = $args->{trailer_callback} |
857
|
27
|
100
|
|
|
|
65
|
if ref $args->{trailer_callback} eq 'CODE'; |
858
|
|
|
|
|
|
|
} |
859
|
|
|
|
|
|
|
|
860
|
|
|
|
|
|
|
### If we have a cookie jar, then maybe add relevant cookies |
861
|
144
|
100
|
|
|
|
283
|
if ( $self->{cookie_jar} ) { |
862
|
34
|
|
|
|
|
56
|
my $cookies = $self->cookie_jar->cookie_header( $url ); |
863
|
34
|
100
|
|
|
|
333
|
$request->{headers}{cookie} = $cookies if length $cookies; |
864
|
|
|
|
|
|
|
} |
865
|
|
|
|
|
|
|
|
866
|
|
|
|
|
|
|
# if we have Basic auth parameters, add them |
867
|
144
|
100
|
100
|
|
|
318
|
if ( length $auth && ! defined $request->{headers}{authorization} ) { |
868
|
4
|
|
|
|
|
9
|
$self->_add_basic_auth_header( $request, 'authorization' => $auth ); |
869
|
|
|
|
|
|
|
} |
870
|
|
|
|
|
|
|
|
871
|
144
|
|
|
|
|
199
|
return; |
872
|
|
|
|
|
|
|
} |
873
|
|
|
|
|
|
|
|
874
|
|
|
|
|
|
|
sub _add_basic_auth_header { |
875
|
5
|
|
|
5
|
|
10
|
my ($self, $request, $header, $auth) = @_; |
876
|
5
|
|
|
|
|
772
|
require MIME::Base64; |
877
|
5
|
|
|
|
|
1072
|
$request->{headers}{$header} = |
878
|
|
|
|
|
|
|
"Basic " . MIME::Base64::encode_base64($auth, ""); |
879
|
5
|
|
|
|
|
12
|
return; |
880
|
|
|
|
|
|
|
} |
881
|
|
|
|
|
|
|
|
882
|
|
|
|
|
|
|
sub _prepare_data_cb { |
883
|
139
|
|
|
139
|
|
234
|
my ($self, $response, $args) = @_; |
884
|
139
|
|
|
|
|
197
|
my $data_cb = $args->{data_callback}; |
885
|
139
|
|
|
|
|
206
|
$response->{content} = ''; |
886
|
|
|
|
|
|
|
|
887
|
139
|
100
|
100
|
|
|
373
|
if (!$data_cb || $response->{status} !~ /^2/) { |
888
|
135
|
100
|
|
|
|
278
|
if (defined $self->{max_size}) { |
889
|
|
|
|
|
|
|
$data_cb = sub { |
890
|
1
|
|
|
1
|
|
4
|
$_[1]->{content} .= $_[0]; |
891
|
|
|
|
|
|
|
die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/) |
892
|
1
|
50
|
|
|
|
21
|
if length $_[1]->{content} > $self->{max_size}; |
893
|
1
|
|
|
|
|
9
|
}; |
894
|
|
|
|
|
|
|
} |
895
|
|
|
|
|
|
|
else { |
896
|
134
|
|
|
334
|
|
492
|
$data_cb = sub { $_[1]->{content} .= $_[0] }; |
|
334
|
|
|
|
|
2227
|
|
897
|
|
|
|
|
|
|
} |
898
|
|
|
|
|
|
|
} |
899
|
139
|
|
|
|
|
232
|
return $data_cb; |
900
|
|
|
|
|
|
|
} |
901
|
|
|
|
|
|
|
|
902
|
|
|
|
|
|
|
sub _update_cookie_jar { |
903
|
34
|
|
|
34
|
|
59
|
my ($self, $url, $response) = @_; |
904
|
|
|
|
|
|
|
|
905
|
34
|
|
|
|
|
44
|
my $cookies = $response->{headers}->{'set-cookie'}; |
906
|
34
|
100
|
|
|
|
60
|
return unless defined $cookies; |
907
|
|
|
|
|
|
|
|
908
|
30
|
100
|
|
|
|
63
|
my @cookies = ref $cookies ? @$cookies : $cookies; |
909
|
|
|
|
|
|
|
|
910
|
30
|
|
|
|
|
64
|
$self->cookie_jar->add( $url, $_ ) for @cookies; |
911
|
|
|
|
|
|
|
|
912
|
30
|
|
|
|
|
498
|
return; |
913
|
|
|
|
|
|
|
} |
914
|
|
|
|
|
|
|
|
915
|
|
|
|
|
|
|
sub _validate_cookie_jar { |
916
|
15
|
|
|
15
|
|
28
|
my ($class, $jar) = @_; |
917
|
|
|
|
|
|
|
|
918
|
|
|
|
|
|
|
# duck typing |
919
|
15
|
|
|
|
|
26
|
for my $method ( qw/add cookie_header/ ) { |
920
|
29
|
100
|
66
|
|
|
205
|
_croak(qq/Cookie jar must provide the '$method' method\n/) |
921
|
|
|
|
|
|
|
unless ref($jar) && ref($jar)->can($method); |
922
|
|
|
|
|
|
|
} |
923
|
|
|
|
|
|
|
|
924
|
13
|
|
|
|
|
22
|
return; |
925
|
|
|
|
|
|
|
} |
926
|
|
|
|
|
|
|
|
927
|
|
|
|
|
|
|
sub _maybe_redirect { |
928
|
141
|
|
|
141
|
|
254
|
my ($self, $request, $response, $args) = @_; |
929
|
141
|
|
|
|
|
202
|
my $headers = $response->{headers}; |
930
|
141
|
|
|
|
|
287
|
my ($status, $method) = ($response->{status}, $request->{method}); |
931
|
141
|
|
100
|
|
|
566
|
$args->{_redirects} ||= []; |
932
|
|
|
|
|
|
|
|
933
|
141
|
100
|
100
|
|
|
556
|
if (($status eq '303' or ($status =~ /^30[1278]/ && $method =~ /^GET|HEAD$/)) |
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
934
|
|
|
|
|
|
|
and $headers->{location} |
935
|
13
|
|
|
|
|
36
|
and @{$args->{_redirects}} < $self->{max_redirect} |
936
|
|
|
|
|
|
|
) { |
937
|
|
|
|
|
|
|
my $location = ($headers->{location} =~ /^\//) |
938
|
|
|
|
|
|
|
? "$request->{scheme}://$request->{host_port}$headers->{location}" |
939
|
11
|
100
|
|
|
|
33
|
: $headers->{location} ; |
940
|
11
|
100
|
|
|
|
35
|
return (($status eq '303' ? 'GET' : $method), $location); |
941
|
|
|
|
|
|
|
} |
942
|
130
|
|
|
|
|
265
|
return; |
943
|
|
|
|
|
|
|
} |
944
|
|
|
|
|
|
|
|
945
|
|
|
|
|
|
|
sub _split_url { |
946
|
186
|
|
|
186
|
|
6894
|
my $url = pop; |
947
|
|
|
|
|
|
|
|
948
|
|
|
|
|
|
|
# URI regex adapted from the URI module |
949
|
186
|
100
|
|
|
|
1252
|
my ($scheme, $host, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)> |
950
|
|
|
|
|
|
|
or die(qq/Cannot parse URL: '$url'\n/); |
951
|
|
|
|
|
|
|
|
952
|
185
|
|
|
|
|
455
|
$scheme = lc $scheme; |
953
|
185
|
100
|
|
|
|
488
|
$path_query = "/$path_query" unless $path_query =~ m<\A/>; |
954
|
|
|
|
|
|
|
|
955
|
185
|
|
|
|
|
261
|
my $auth = ''; |
956
|
185
|
100
|
|
|
|
459
|
if ( (my $i = index $host, '@') != -1 ) { |
957
|
|
|
|
|
|
|
# user:pass@host |
958
|
12
|
|
|
|
|
25
|
$auth = substr $host, 0, $i, ''; # take up to the @ for auth |
959
|
12
|
|
|
|
|
19
|
substr $host, 0, 1, ''; # knock the @ off the host |
960
|
|
|
|
|
|
|
|
961
|
|
|
|
|
|
|
# userinfo might be percent escaped, so recover real auth info |
962
|
12
|
|
|
|
|
24
|
$auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; |
|
1
|
|
|
|
|
6
|
|
963
|
|
|
|
|
|
|
} |
964
|
185
|
100
|
100
|
|
|
796
|
my $port = $host =~ s/:(\d*)\z// && length $1 ? $1 |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
965
|
|
|
|
|
|
|
: $scheme eq 'http' ? 80 |
966
|
|
|
|
|
|
|
: $scheme eq 'https' ? 443 |
967
|
|
|
|
|
|
|
: undef; |
968
|
|
|
|
|
|
|
|
969
|
185
|
100
|
|
|
|
823
|
return ($scheme, (length $host ? lc $host : "localhost") , $port, $path_query, $auth); |
970
|
|
|
|
|
|
|
} |
971
|
|
|
|
|
|
|
|
972
|
|
|
|
|
|
|
# Date conversions adapted from HTTP::Date |
973
|
|
|
|
|
|
|
my $DoW = "Sun|Mon|Tue|Wed|Thu|Fri|Sat"; |
974
|
|
|
|
|
|
|
my $MoY = "Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec"; |
975
|
|
|
|
|
|
|
sub _http_date { |
976
|
3
|
|
|
3
|
|
1094
|
my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($_[1]); |
977
|
3
|
|
|
|
|
38
|
return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT", |
978
|
|
|
|
|
|
|
substr($DoW,$wday*4,3), |
979
|
|
|
|
|
|
|
$mday, substr($MoY,$mon*4,3), $year+1900, |
980
|
|
|
|
|
|
|
$hour, $min, $sec |
981
|
|
|
|
|
|
|
); |
982
|
|
|
|
|
|
|
} |
983
|
|
|
|
|
|
|
|
984
|
|
|
|
|
|
|
sub _parse_http_date { |
985
|
9
|
|
|
9
|
|
2756
|
my ($self, $str) = @_; |
986
|
9
|
|
|
|
|
819
|
require Time::Local; |
987
|
9
|
|
|
|
|
3412
|
my @tl_parts; |
988
|
9
|
100
|
|
|
|
283
|
if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
989
|
5
|
|
|
|
|
35
|
@tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3); |
990
|
|
|
|
|
|
|
} |
991
|
|
|
|
|
|
|
elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) { |
992
|
2
|
|
|
|
|
14
|
@tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3); |
993
|
|
|
|
|
|
|
} |
994
|
|
|
|
|
|
|
elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) { |
995
|
2
|
|
|
|
|
16
|
@tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6); |
996
|
|
|
|
|
|
|
} |
997
|
9
|
|
|
|
|
19
|
return eval { |
998
|
9
|
50
|
|
|
|
29
|
my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1; |
999
|
9
|
50
|
|
|
|
298
|
$t < 0 ? undef : $t; |
1000
|
|
|
|
|
|
|
}; |
1001
|
|
|
|
|
|
|
} |
1002
|
|
|
|
|
|
|
|
1003
|
|
|
|
|
|
|
# URI escaping adapted from URI::Escape |
1004
|
|
|
|
|
|
|
# c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1 |
1005
|
|
|
|
|
|
|
# perl 5.6 ready UTF-8 encoding adapted from JSON::PP |
1006
|
|
|
|
|
|
|
my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255; |
1007
|
|
|
|
|
|
|
$escapes{' '}="+"; |
1008
|
|
|
|
|
|
|
my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/; |
1009
|
|
|
|
|
|
|
|
1010
|
|
|
|
|
|
|
sub _uri_escape { |
1011
|
26
|
|
|
26
|
|
36
|
my ($self, $str) = @_; |
1012
|
26
|
100
|
|
|
|
43
|
return "" if !defined $str; |
1013
|
24
|
50
|
|
|
|
34
|
if ( $] ge '5.008' ) { |
1014
|
24
|
|
|
|
|
34
|
utf8::encode($str); |
1015
|
|
|
|
|
|
|
} |
1016
|
|
|
|
|
|
|
else { |
1017
|
|
|
|
|
|
|
$str = pack("U*", unpack("C*", $str)) # UTF-8 encode a byte string |
1018
|
29
|
0
|
|
29
|
|
13989
|
if ( length $str == do { use bytes; length $str } ); |
|
29
|
|
|
|
|
346
|
|
|
29
|
|
|
|
|
134
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
1019
|
0
|
|
|
|
|
0
|
$str = pack("C*", unpack("C*", $str)); # clear UTF-8 flag |
1020
|
|
|
|
|
|
|
} |
1021
|
24
|
|
|
|
|
126
|
$str =~ s/($unsafe_char)/$escapes{$1}/g; |
1022
|
24
|
|
|
|
|
71
|
return $str; |
1023
|
|
|
|
|
|
|
} |
1024
|
|
|
|
|
|
|
|
1025
|
|
|
|
|
|
|
package |
1026
|
|
|
|
|
|
|
HTTP::Tiny::Handle; # hide from PAUSE/indexers |
1027
|
29
|
|
|
29
|
|
2457
|
use strict; |
|
29
|
|
|
|
|
52
|
|
|
29
|
|
|
|
|
510
|
|
1028
|
29
|
|
|
29
|
|
118
|
use warnings; |
|
29
|
|
|
|
|
49
|
|
|
29
|
|
|
|
|
829
|
|
1029
|
|
|
|
|
|
|
|
1030
|
29
|
|
|
29
|
|
9158
|
use Errno qw[EINTR EPIPE]; |
|
29
|
|
|
|
|
28515
|
|
|
29
|
|
|
|
|
2495
|
|
1031
|
29
|
|
|
29
|
|
10483
|
use IO::Socket qw[SOCK_STREAM]; |
|
29
|
|
|
|
|
315611
|
|
|
29
|
|
|
|
|
123
|
|
1032
|
29
|
|
|
29
|
|
5231
|
use Socket qw[SOL_SOCKET SO_KEEPALIVE]; |
|
29
|
|
|
|
|
58
|
|
|
29
|
|
|
|
|
117123
|
|
1033
|
|
|
|
|
|
|
|
1034
|
|
|
|
|
|
|
# PERL_HTTP_TINY_IPV4_ONLY is a private environment variable to force old |
1035
|
|
|
|
|
|
|
# behavior if someone is unable to boostrap CPAN from a new perl install; it is |
1036
|
|
|
|
|
|
|
# not intended for general, per-client use and may be removed in the future |
1037
|
|
|
|
|
|
|
my $SOCKET_CLASS = |
1038
|
|
|
|
|
|
|
$ENV{PERL_HTTP_TINY_IPV4_ONLY} ? 'IO::Socket::INET' : |
1039
|
|
|
|
|
|
|
eval { require IO::Socket::IP; IO::Socket::IP->VERSION(0.32) } ? 'IO::Socket::IP' : |
1040
|
|
|
|
|
|
|
'IO::Socket::INET'; |
1041
|
|
|
|
|
|
|
|
1042
|
|
|
|
|
|
|
sub BUFSIZE () { 32768 } ## no critic |
1043
|
|
|
|
|
|
|
|
1044
|
|
|
|
|
|
|
my $Printable = sub { |
1045
|
|
|
|
|
|
|
local $_ = shift; |
1046
|
|
|
|
|
|
|
s/\r/\\r/g; |
1047
|
|
|
|
|
|
|
s/\n/\\n/g; |
1048
|
|
|
|
|
|
|
s/\t/\\t/g; |
1049
|
|
|
|
|
|
|
s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge; |
1050
|
|
|
|
|
|
|
$_; |
1051
|
|
|
|
|
|
|
}; |
1052
|
|
|
|
|
|
|
|
1053
|
|
|
|
|
|
|
my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/; |
1054
|
|
|
|
|
|
|
my $Field_Content = qr/[[:print:]]+ (?: [\x20\x09]+ [[:print:]]+ )*/x; |
1055
|
|
|
|
|
|
|
|
1056
|
|
|
|
|
|
|
sub new { |
1057
|
162
|
|
|
162
|
|
10886
|
my ($class, %args) = @_; |
1058
|
162
|
|
|
|
|
1383
|
return bless { |
1059
|
|
|
|
|
|
|
rbuf => '', |
1060
|
|
|
|
|
|
|
timeout => 60, |
1061
|
|
|
|
|
|
|
max_line_size => 16384, |
1062
|
|
|
|
|
|
|
max_header_lines => 64, |
1063
|
|
|
|
|
|
|
verify_SSL => 0, |
1064
|
|
|
|
|
|
|
SSL_options => {}, |
1065
|
|
|
|
|
|
|
%args |
1066
|
|
|
|
|
|
|
}, $class; |
1067
|
|
|
|
|
|
|
} |
1068
|
|
|
|
|
|
|
|
1069
|
|
|
|
|
|
|
sub timeout { |
1070
|
2
|
|
|
2
|
|
3
|
my ($self, $timeout) = @_; |
1071
|
2
|
50
|
|
|
|
5
|
if ( @_ > 1 ) { |
1072
|
2
|
|
|
|
|
3
|
$self->{timeout} = $timeout; |
1073
|
2
|
50
|
33
|
|
|
18
|
if ( $self->{fh} && $self->{fh}->can('timeout') ) { |
1074
|
0
|
|
|
|
|
0
|
$self->{fh}->timeout($timeout); |
1075
|
|
|
|
|
|
|
} |
1076
|
|
|
|
|
|
|
} |
1077
|
2
|
|
|
|
|
5
|
return $self->{timeout}; |
1078
|
|
|
|
|
|
|
} |
1079
|
|
|
|
|
|
|
|
1080
|
|
|
|
|
|
|
sub connect { |
1081
|
12
|
50
|
|
12
|
|
54
|
@_ == 5 || die(q/Usage: $handle->connect(scheme, host, port, peer)/ . "\n"); |
1082
|
12
|
|
|
|
|
47
|
my ($self, $scheme, $host, $port, $peer) = @_; |
1083
|
|
|
|
|
|
|
|
1084
|
12
|
100
|
|
|
|
39
|
if ( $scheme eq 'https' ) { |
1085
|
9
|
|
|
|
|
34
|
$self->_assert_ssl; |
1086
|
|
|
|
|
|
|
} |
1087
|
|
|
|
|
|
|
|
1088
|
|
|
|
|
|
|
$self->{fh} = $SOCKET_CLASS->new( |
1089
|
|
|
|
|
|
|
PeerHost => $peer, |
1090
|
|
|
|
|
|
|
PeerPort => $port, |
1091
|
|
|
|
|
|
|
$self->{local_address} ? |
1092
|
|
|
|
|
|
|
( LocalAddr => $self->{local_address} ) : (), |
1093
|
|
|
|
|
|
|
Proto => 'tcp', |
1094
|
|
|
|
|
|
|
Type => SOCK_STREAM, |
1095
|
|
|
|
|
|
|
Timeout => $self->{timeout}, |
1096
|
12
|
100
|
|
|
|
193
|
) or die(qq/Could not connect to '$host:$port': $@\n/); |
|
|
100
|
|
|
|
|
|
1097
|
|
|
|
|
|
|
|
1098
|
|
|
|
|
|
|
binmode($self->{fh}) |
1099
|
11
|
50
|
|
|
|
327274
|
or die(qq/Could not binmode() socket: '$!'\n/); |
1100
|
|
|
|
|
|
|
|
1101
|
11
|
50
|
|
|
|
46
|
if ( $self->{keep_alive} ) { |
1102
|
11
|
50
|
|
|
|
77
|
unless ( defined( $self->{fh}->setsockopt( SOL_SOCKET, SO_KEEPALIVE, 1 ) ) ) { |
1103
|
0
|
|
|
|
|
0
|
CORE::close($self->{fh}); |
1104
|
0
|
|
|
|
|
0
|
die(qq/Could not set SO_KEEPALIVE on socket: '$!'\n/); |
1105
|
|
|
|
|
|
|
} |
1106
|
|
|
|
|
|
|
} |
1107
|
|
|
|
|
|
|
|
1108
|
11
|
100
|
|
|
|
287
|
$self->start_ssl($host) if $scheme eq 'https'; |
1109
|
|
|
|
|
|
|
|
1110
|
8
|
|
|
|
|
43
|
$self->{scheme} = $scheme; |
1111
|
8
|
|
|
|
|
36
|
$self->{host} = $host; |
1112
|
8
|
|
|
|
|
24
|
$self->{peer} = $peer; |
1113
|
8
|
|
|
|
|
23
|
$self->{port} = $port; |
1114
|
8
|
|
|
|
|
37
|
$self->{pid} = $$; |
1115
|
8
|
|
|
|
|
30
|
$self->{tid} = _get_tid(); |
1116
|
|
|
|
|
|
|
|
1117
|
8
|
|
|
|
|
66
|
return $self; |
1118
|
|
|
|
|
|
|
} |
1119
|
|
|
|
|
|
|
|
1120
|
|
|
|
|
|
|
sub connected { |
1121
|
8
|
|
|
8
|
|
31
|
my ($self) = @_; |
1122
|
8
|
50
|
33
|
|
|
120
|
if ( $self->{fh} && $self->{fh}->connected ) { |
1123
|
|
|
|
|
|
|
return wantarray |
1124
|
|
|
|
|
|
|
? ( $self->{fh}->peerhost, $self->{fh}->peerport ) |
1125
|
8
|
50
|
|
|
|
437
|
: join( ':', $self->{fh}->peerhost, $self->{fh}->peerport ); |
1126
|
|
|
|
|
|
|
} |
1127
|
0
|
|
|
|
|
0
|
return; |
1128
|
|
|
|
|
|
|
} |
1129
|
|
|
|
|
|
|
|
1130
|
|
|
|
|
|
|
sub start_ssl { |
1131
|
9
|
|
|
9
|
|
50
|
my ($self, $host) = @_; |
1132
|
|
|
|
|
|
|
|
1133
|
|
|
|
|
|
|
# As this might be used via CONNECT after an SSL session |
1134
|
|
|
|
|
|
|
# to a proxy, we shut down any existing SSL before attempting |
1135
|
|
|
|
|
|
|
# the handshake |
1136
|
9
|
50
|
|
|
|
59
|
if ( ref($self->{fh}) eq 'IO::Socket::SSL' ) { |
1137
|
0
|
0
|
|
|
|
0
|
unless ( $self->{fh}->stop_SSL ) { |
1138
|
0
|
|
|
|
|
0
|
my $ssl_err = IO::Socket::SSL->errstr; |
1139
|
0
|
|
|
|
|
0
|
die(qq/Error halting prior SSL connection: $ssl_err/); |
1140
|
|
|
|
|
|
|
} |
1141
|
|
|
|
|
|
|
} |
1142
|
|
|
|
|
|
|
|
1143
|
9
|
|
|
|
|
40
|
my $ssl_args = $self->_ssl_args($host); |
1144
|
|
|
|
|
|
|
IO::Socket::SSL->start_SSL( |
1145
|
|
|
|
|
|
|
$self->{fh}, |
1146
|
|
|
|
|
|
|
%$ssl_args, |
1147
|
|
|
|
|
|
|
SSL_create_ctx_callback => sub { |
1148
|
9
|
|
|
9
|
|
64333
|
my $ctx = shift; |
1149
|
9
|
|
|
|
|
253
|
Net::SSLeay::CTX_set_mode($ctx, Net::SSLeay::MODE_AUTO_RETRY()); |
1150
|
|
|
|
|
|
|
}, |
1151
|
9
|
|
|
|
|
183
|
); |
1152
|
|
|
|
|
|
|
|
1153
|
9
|
100
|
|
|
|
418659
|
unless ( ref($self->{fh}) eq 'IO::Socket::SSL' ) { |
1154
|
3
|
|
|
|
|
22
|
my $ssl_err = IO::Socket::SSL->errstr; |
1155
|
3
|
|
|
|
|
642
|
die(qq/SSL connection failed for $host: $ssl_err\n/); |
1156
|
|
|
|
|
|
|
} |
1157
|
|
|
|
|
|
|
} |
1158
|
|
|
|
|
|
|
|
1159
|
|
|
|
|
|
|
sub close { |
1160
|
0
|
0
|
|
0
|
|
0
|
@_ == 1 || die(q/Usage: $handle->close()/ . "\n"); |
1161
|
0
|
|
|
|
|
0
|
my ($self) = @_; |
1162
|
|
|
|
|
|
|
CORE::close($self->{fh}) |
1163
|
0
|
0
|
|
|
|
0
|
or die(qq/Could not close socket: '$!'\n/); |
1164
|
|
|
|
|
|
|
} |
1165
|
|
|
|
|
|
|
|
1166
|
|
|
|
|
|
|
sub write { |
1167
|
359
|
50
|
|
359
|
|
664
|
@_ == 2 || die(q/Usage: $handle->write(buf)/ . "\n"); |
1168
|
359
|
|
|
|
|
541
|
my ($self, $buf) = @_; |
1169
|
|
|
|
|
|
|
|
1170
|
359
|
50
|
|
|
|
617
|
if ( $] ge '5.008' ) { |
1171
|
359
|
50
|
|
|
|
710
|
utf8::downgrade($buf, 1) |
1172
|
|
|
|
|
|
|
or die(qq/Wide character in write()\n/); |
1173
|
|
|
|
|
|
|
} |
1174
|
|
|
|
|
|
|
|
1175
|
359
|
|
|
|
|
416
|
my $len = length $buf; |
1176
|
359
|
|
|
|
|
379
|
my $off = 0; |
1177
|
|
|
|
|
|
|
|
1178
|
359
|
|
|
|
|
4333
|
local $SIG{PIPE} = 'IGNORE'; |
1179
|
|
|
|
|
|
|
|
1180
|
359
|
|
|
|
|
612
|
while () { |
1181
|
359
|
50
|
|
|
|
875
|
$self->can_write |
1182
|
|
|
|
|
|
|
or die(qq/Timed out while waiting for socket to become ready for writing\n/); |
1183
|
359
|
|
|
|
|
6552
|
my $r = syswrite($self->{fh}, $buf, $len, $off); |
1184
|
359
|
50
|
|
|
|
1950
|
if (defined $r) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
1185
|
359
|
|
|
|
|
431
|
$len -= $r; |
1186
|
359
|
|
|
|
|
391
|
$off += $r; |
1187
|
359
|
50
|
|
|
|
755
|
last unless $len > 0; |
1188
|
|
|
|
|
|
|
} |
1189
|
|
|
|
|
|
|
elsif ($! == EPIPE) { |
1190
|
0
|
|
|
|
|
0
|
die(qq/Socket closed by remote server: $!\n/); |
1191
|
|
|
|
|
|
|
} |
1192
|
|
|
|
|
|
|
elsif ($! != EINTR) { |
1193
|
0
|
0
|
|
|
|
0
|
if ($self->{fh}->can('errstr')){ |
1194
|
0
|
|
|
|
|
0
|
my $err = $self->{fh}->errstr(); |
1195
|
0
|
|
|
|
|
0
|
die (qq/Could not write to SSL socket: '$err'\n /); |
1196
|
|
|
|
|
|
|
} |
1197
|
|
|
|
|
|
|
else { |
1198
|
0
|
|
|
|
|
0
|
die(qq/Could not write to socket: '$!'\n/); |
1199
|
|
|
|
|
|
|
} |
1200
|
|
|
|
|
|
|
|
1201
|
|
|
|
|
|
|
} |
1202
|
|
|
|
|
|
|
} |
1203
|
359
|
|
|
|
|
3899
|
return $off; |
1204
|
|
|
|
|
|
|
} |
1205
|
|
|
|
|
|
|
|
1206
|
|
|
|
|
|
|
sub read { |
1207
|
674
|
50
|
66
|
674
|
|
1566
|
@_ == 2 || @_ == 3 || die(q/Usage: $handle->read(len [, allow_partial])/ . "\n"); |
1208
|
674
|
|
|
|
|
941
|
my ($self, $len, $allow_partial) = @_; |
1209
|
|
|
|
|
|
|
|
1210
|
674
|
|
|
|
|
828
|
my $buf = ''; |
1211
|
674
|
|
|
|
|
875
|
my $got = length $self->{rbuf}; |
1212
|
|
|
|
|
|
|
|
1213
|
674
|
100
|
|
|
|
951
|
if ($got) { |
1214
|
631
|
100
|
|
|
|
868
|
my $take = ($got < $len) ? $got : $len; |
1215
|
631
|
|
|
|
|
1347
|
$buf = substr($self->{rbuf}, 0, $take, ''); |
1216
|
631
|
|
|
|
|
835
|
$len -= $take; |
1217
|
|
|
|
|
|
|
} |
1218
|
|
|
|
|
|
|
|
1219
|
|
|
|
|
|
|
# Ignore SIGPIPE because SSL reads can result in writes that might error. |
1220
|
|
|
|
|
|
|
# See "Expecting exactly the same behavior as plain sockets" in |
1221
|
|
|
|
|
|
|
# https://metacpan.org/dist/IO-Socket-SSL/view/lib/IO/Socket/SSL.pod#Common-Usage-Errors |
1222
|
674
|
|
|
|
|
7027
|
local $SIG{PIPE} = 'IGNORE'; |
1223
|
|
|
|
|
|
|
|
1224
|
674
|
|
|
|
|
1673
|
while ($len > 0) { |
1225
|
466
|
50
|
|
|
|
930
|
$self->can_read |
1226
|
|
|
|
|
|
|
or die(q/Timed out while waiting for socket to become ready for reading/ . "\n"); |
1227
|
466
|
|
|
|
|
2298
|
my $r = sysread($self->{fh}, $buf, $len, length $buf); |
1228
|
466
|
50
|
|
|
|
180831
|
if (defined $r) { |
|
|
0
|
|
|
|
|
|
1229
|
466
|
100
|
|
|
|
811
|
last unless $r; |
1230
|
462
|
|
|
|
|
851
|
$len -= $r; |
1231
|
|
|
|
|
|
|
} |
1232
|
|
|
|
|
|
|
elsif ($! != EINTR) { |
1233
|
0
|
0
|
|
|
|
0
|
if ($self->{fh}->can('errstr')){ |
1234
|
0
|
|
|
|
|
0
|
my $err = $self->{fh}->errstr(); |
1235
|
0
|
|
|
|
|
0
|
die (qq/Could not read from SSL socket: '$err'\n /); |
1236
|
|
|
|
|
|
|
} |
1237
|
|
|
|
|
|
|
else { |
1238
|
0
|
|
|
|
|
0
|
die(qq/Could not read from socket: '$!'\n/); |
1239
|
|
|
|
|
|
|
} |
1240
|
|
|
|
|
|
|
} |
1241
|
|
|
|
|
|
|
} |
1242
|
674
|
50
|
66
|
|
|
1151
|
if ($len && !$allow_partial) { |
1243
|
0
|
|
|
|
|
0
|
die(qq/Unexpected end of stream\n/); |
1244
|
|
|
|
|
|
|
} |
1245
|
674
|
|
|
|
|
7282
|
return $buf; |
1246
|
|
|
|
|
|
|
} |
1247
|
|
|
|
|
|
|
|
1248
|
|
|
|
|
|
|
sub readline { |
1249
|
1226
|
50
|
|
1226
|
|
1992
|
@_ == 1 || die(q/Usage: $handle->readline()/ . "\n"); |
1250
|
1226
|
|
|
|
|
1585
|
my ($self) = @_; |
1251
|
|
|
|
|
|
|
|
1252
|
1226
|
|
|
|
|
1323
|
while () { |
1253
|
1426
|
100
|
|
|
|
6836
|
if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) { |
1254
|
1226
|
|
|
|
|
3642
|
return $1; |
1255
|
|
|
|
|
|
|
} |
1256
|
200
|
50
|
|
|
|
457
|
if (length $self->{rbuf} >= $self->{max_line_size}) { |
1257
|
0
|
|
|
|
|
0
|
die(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}\n/); |
1258
|
|
|
|
|
|
|
} |
1259
|
|
|
|
|
|
|
$self->can_read |
1260
|
200
|
50
|
|
|
|
388
|
or die(qq/Timed out while waiting for socket to become ready for reading\n/); |
1261
|
200
|
|
|
|
|
3304
|
my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf}); |
1262
|
200
|
50
|
|
|
|
22495
|
if (defined $r) { |
|
|
0
|
|
|
|
|
|
1263
|
200
|
50
|
|
|
|
552
|
last unless $r; |
1264
|
|
|
|
|
|
|
} |
1265
|
|
|
|
|
|
|
elsif ($! != EINTR) { |
1266
|
0
|
0
|
|
|
|
0
|
if ($self->{fh}->can('errstr')){ |
1267
|
0
|
|
|
|
|
0
|
my $err = $self->{fh}->errstr(); |
1268
|
0
|
|
|
|
|
0
|
die (qq/Could not read from SSL socket: '$err'\n /); |
1269
|
|
|
|
|
|
|
} |
1270
|
|
|
|
|
|
|
else { |
1271
|
0
|
|
|
|
|
0
|
die(qq/Could not read from socket: '$!'\n/); |
1272
|
|
|
|
|
|
|
} |
1273
|
|
|
|
|
|
|
} |
1274
|
|
|
|
|
|
|
} |
1275
|
0
|
|
|
|
|
0
|
die(qq/Unexpected end of stream while looking for line\n/); |
1276
|
|
|
|
|
|
|
} |
1277
|
|
|
|
|
|
|
|
1278
|
|
|
|
|
|
|
sub read_header_lines { |
1279
|
168
|
50
|
66
|
168
|
|
499
|
@_ == 1 || @_ == 2 || die(q/Usage: $handle->read_header_lines([headers])/ . "\n"); |
1280
|
168
|
|
|
|
|
302
|
my ($self, $headers) = @_; |
1281
|
168
|
|
100
|
|
|
678
|
$headers ||= {}; |
1282
|
168
|
|
|
|
|
290
|
my $lines = 0; |
1283
|
168
|
|
|
|
|
199
|
my $val; |
1284
|
|
|
|
|
|
|
|
1285
|
168
|
|
|
|
|
232
|
while () { |
1286
|
782
|
|
|
|
|
1278
|
my $line = $self->readline; |
1287
|
|
|
|
|
|
|
|
1288
|
782
|
50
|
|
|
|
3498
|
if (++$lines >= $self->{max_header_lines}) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
1289
|
0
|
|
|
|
|
0
|
die(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}\n/); |
1290
|
|
|
|
|
|
|
} |
1291
|
|
|
|
|
|
|
elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) { |
1292
|
611
|
|
|
|
|
1262
|
my ($field_name) = lc $1; |
1293
|
611
|
100
|
|
|
|
1017
|
if (exists $headers->{$field_name}) { |
1294
|
19
|
|
|
|
|
58
|
for ($headers->{$field_name}) { |
1295
|
19
|
100
|
|
|
|
73
|
$_ = [$_] unless ref $_ eq "ARRAY"; |
1296
|
19
|
|
|
|
|
60
|
push @$_, $2; |
1297
|
19
|
|
|
|
|
65
|
$val = \$_->[-1]; |
1298
|
|
|
|
|
|
|
} |
1299
|
|
|
|
|
|
|
} |
1300
|
|
|
|
|
|
|
else { |
1301
|
592
|
|
|
|
|
1700
|
$val = \($headers->{$field_name} = $2); |
1302
|
|
|
|
|
|
|
} |
1303
|
|
|
|
|
|
|
} |
1304
|
|
|
|
|
|
|
elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) { |
1305
|
3
|
50
|
|
|
|
7
|
$val |
1306
|
|
|
|
|
|
|
or die(qq/Unexpected header continuation line\n/); |
1307
|
3
|
100
|
|
|
|
9
|
next unless length $1; |
1308
|
2
|
100
|
|
|
|
4
|
$$val .= ' ' if length $$val; |
1309
|
2
|
|
|
|
|
4
|
$$val .= $1; |
1310
|
|
|
|
|
|
|
} |
1311
|
|
|
|
|
|
|
elsif ($line =~ /\A \x0D?\x0A \z/x) { |
1312
|
168
|
|
|
|
|
282
|
last; |
1313
|
|
|
|
|
|
|
} |
1314
|
|
|
|
|
|
|
else { |
1315
|
0
|
|
|
|
|
0
|
die(q/Malformed header line: / . $Printable->($line) . "\n"); |
1316
|
|
|
|
|
|
|
} |
1317
|
|
|
|
|
|
|
} |
1318
|
168
|
|
|
|
|
935
|
return $headers; |
1319
|
|
|
|
|
|
|
} |
1320
|
|
|
|
|
|
|
|
1321
|
|
|
|
|
|
|
sub write_request { |
1322
|
8
|
50
|
|
8
|
|
98
|
@_ == 2 || die(q/Usage: $handle->write_request(request)/ . "\n"); |
1323
|
8
|
|
|
|
|
34
|
my($self, $request) = @_; |
1324
|
8
|
|
|
|
|
26
|
$self->write_request_header(@{$request}{qw/method uri headers header_case/}); |
|
8
|
|
|
|
|
63
|
|
1325
|
8
|
50
|
|
|
|
44
|
$self->write_body($request) if $request->{cb}; |
1326
|
8
|
|
|
|
|
20
|
return; |
1327
|
|
|
|
|
|
|
} |
1328
|
|
|
|
|
|
|
|
1329
|
|
|
|
|
|
|
# Standard request header names/case from HTTP/1.1 RFCs |
1330
|
|
|
|
|
|
|
my @rfc_request_headers = qw( |
1331
|
|
|
|
|
|
|
Accept Accept-Charset Accept-Encoding Accept-Language Authorization |
1332
|
|
|
|
|
|
|
Cache-Control Connection Content-Length Expect From Host |
1333
|
|
|
|
|
|
|
If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since |
1334
|
|
|
|
|
|
|
Max-Forwards Pragma Proxy-Authorization Range Referer TE Trailer |
1335
|
|
|
|
|
|
|
Transfer-Encoding Upgrade User-Agent Via |
1336
|
|
|
|
|
|
|
); |
1337
|
|
|
|
|
|
|
|
1338
|
|
|
|
|
|
|
my @other_request_headers = qw( |
1339
|
|
|
|
|
|
|
Content-Encoding Content-MD5 Content-Type Cookie DNT Date Origin |
1340
|
|
|
|
|
|
|
X-XSS-Protection |
1341
|
|
|
|
|
|
|
); |
1342
|
|
|
|
|
|
|
|
1343
|
|
|
|
|
|
|
my %HeaderCase = map { lc($_) => $_ } @rfc_request_headers, @other_request_headers; |
1344
|
|
|
|
|
|
|
|
1345
|
|
|
|
|
|
|
# to avoid multiple small writes and hence nagle, you can pass the method line or anything else to |
1346
|
|
|
|
|
|
|
# combine writes. |
1347
|
|
|
|
|
|
|
sub write_header_lines { |
1348
|
148
|
50
|
33
|
148
|
|
1358
|
(@_ >= 2 && @_ <= 4 && ref $_[1] eq 'HASH') || die(q/Usage: $handle->write_header_lines(headers, [header_case, prefix])/ . "\n"); |
|
|
|
33
|
|
|
|
|
1349
|
148
|
|
|
|
|
292
|
my($self, $headers, $header_case, $prefix_data) = @_; |
1350
|
148
|
|
100
|
|
|
466
|
$header_case ||= {}; |
1351
|
|
|
|
|
|
|
|
1352
|
148
|
100
|
|
|
|
329
|
my $buf = (defined $prefix_data ? $prefix_data : ''); |
1353
|
|
|
|
|
|
|
|
1354
|
|
|
|
|
|
|
# Per RFC, control fields should be listed first |
1355
|
148
|
|
|
|
|
178
|
my %seen; |
1356
|
148
|
|
|
|
|
250
|
for my $k ( qw/host cache-control expect max-forwards pragma range te/ ) { |
1357
|
1036
|
100
|
|
|
|
1640
|
next unless exists $headers->{$k}; |
1358
|
144
|
|
|
|
|
248
|
$seen{$k}++; |
1359
|
144
|
|
|
|
|
360
|
my $field_name = $HeaderCase{$k}; |
1360
|
144
|
|
|
|
|
210
|
my $v = $headers->{$k}; |
1361
|
144
|
50
|
|
|
|
293
|
for (ref $v eq 'ARRAY' ? @$v : $v) { |
1362
|
144
|
50
|
|
|
|
266
|
$_ = '' unless defined $_; |
1363
|
144
|
|
|
|
|
351
|
$buf .= "$field_name: $_\x0D\x0A"; |
1364
|
|
|
|
|
|
|
} |
1365
|
|
|
|
|
|
|
} |
1366
|
|
|
|
|
|
|
|
1367
|
|
|
|
|
|
|
# Other headers sent in arbitrary order |
1368
|
148
|
|
|
|
|
530
|
while (my ($k, $v) = each %$headers) { |
1369
|
515
|
|
|
|
|
762
|
my $field_name = lc $k; |
1370
|
515
|
100
|
|
|
|
1055
|
next if $seen{$field_name}; |
1371
|
371
|
100
|
|
|
|
629
|
if (exists $HeaderCase{$field_name}) { |
1372
|
360
|
|
|
|
|
491
|
$field_name = $HeaderCase{$field_name}; |
1373
|
|
|
|
|
|
|
} |
1374
|
|
|
|
|
|
|
else { |
1375
|
11
|
100
|
|
|
|
37
|
if (exists $header_case->{$field_name}) { |
1376
|
5
|
|
|
|
|
8
|
$field_name = $header_case->{$field_name}; |
1377
|
|
|
|
|
|
|
} |
1378
|
|
|
|
|
|
|
else { |
1379
|
6
|
|
|
|
|
50
|
$field_name =~ s/\b(\w)/\u$1/g; |
1380
|
|
|
|
|
|
|
} |
1381
|
11
|
100
|
|
|
|
155
|
$field_name =~ /\A $Token+ \z/xo |
1382
|
|
|
|
|
|
|
or die(q/Invalid HTTP header field name: / . $Printable->($field_name) . "\n"); |
1383
|
10
|
|
|
|
|
30
|
$HeaderCase{lc $field_name} = $field_name; |
1384
|
|
|
|
|
|
|
} |
1385
|
370
|
100
|
|
|
|
1888
|
for (ref $v eq 'ARRAY' ? @$v : $v) { |
1386
|
|
|
|
|
|
|
# unwrap a field value if pre-wrapped by user |
1387
|
373
|
|
|
|
|
580
|
s/\x0D?\x0A\s+/ /g; |
1388
|
373
|
50
|
66
|
|
|
2659
|
die(qq/Invalid HTTP header field value ($field_name): / . $Printable->($_). "\n") |
1389
|
|
|
|
|
|
|
unless $_ eq '' || /\A $Field_Content \z/xo; |
1390
|
373
|
50
|
|
|
|
635
|
$_ = '' unless defined $_; |
1391
|
373
|
|
|
|
|
1278
|
$buf .= "$field_name: $_\x0D\x0A"; |
1392
|
|
|
|
|
|
|
} |
1393
|
|
|
|
|
|
|
} |
1394
|
147
|
|
|
|
|
216
|
$buf .= "\x0D\x0A"; |
1395
|
147
|
|
|
|
|
319
|
return $self->write($buf); |
1396
|
|
|
|
|
|
|
} |
1397
|
|
|
|
|
|
|
|
1398
|
|
|
|
|
|
|
# return value indicates whether message length was defined; this is generally |
1399
|
|
|
|
|
|
|
# true unless there was no content-length header and we just read until EOF. |
1400
|
|
|
|
|
|
|
# Other message length errors are thrown as exceptions |
1401
|
|
|
|
|
|
|
sub read_body { |
1402
|
139
|
50
|
|
139
|
|
309
|
@_ == 3 || die(q/Usage: $handle->read_body(callback, response)/ . "\n"); |
1403
|
139
|
|
|
|
|
215
|
my ($self, $cb, $response) = @_; |
1404
|
139
|
|
100
|
|
|
409
|
my $te = $response->{headers}{'transfer-encoding'} || ''; |
1405
|
139
|
100
|
|
|
|
381
|
my $chunked = grep { /chunked/i } ( ref $te eq 'ARRAY' ? @$te : $te ) ; |
|
140
|
|
|
|
|
428
|
|
1406
|
139
|
100
|
|
|
|
409
|
return $chunked |
1407
|
|
|
|
|
|
|
? $self->read_chunked_body($cb, $response) |
1408
|
|
|
|
|
|
|
: $self->read_content_body($cb, $response); |
1409
|
|
|
|
|
|
|
} |
1410
|
|
|
|
|
|
|
|
1411
|
|
|
|
|
|
|
sub write_body { |
1412
|
26
|
50
|
|
26
|
|
48
|
@_ == 2 || die(q/Usage: $handle->write_body(request)/ . "\n"); |
1413
|
26
|
|
|
|
|
45
|
my ($self, $request) = @_; |
1414
|
26
|
100
|
|
|
|
48
|
if (exists $request->{headers}{'content-length'}) { |
1415
|
23
|
100
|
|
|
|
38
|
return unless $request->{headers}{'content-length'}; |
1416
|
22
|
|
|
|
|
52
|
return $self->write_content_body($request); |
1417
|
|
|
|
|
|
|
} |
1418
|
|
|
|
|
|
|
else { |
1419
|
3
|
|
|
|
|
6
|
return $self->write_chunked_body($request); |
1420
|
|
|
|
|
|
|
} |
1421
|
|
|
|
|
|
|
} |
1422
|
|
|
|
|
|
|
|
1423
|
|
|
|
|
|
|
sub read_content_body { |
1424
|
403
|
50
|
66
|
403
|
|
1680
|
@_ == 3 || @_ == 4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ . "\n"); |
1425
|
403
|
|
|
|
|
617
|
my ($self, $cb, $response, $content_length) = @_; |
1426
|
403
|
|
100
|
|
|
832
|
$content_length ||= $response->{headers}{'content-length'}; |
1427
|
|
|
|
|
|
|
|
1428
|
403
|
100
|
|
|
|
608
|
if ( defined $content_length ) { |
1429
|
401
|
|
|
|
|
444
|
my $len = $content_length; |
1430
|
401
|
|
|
|
|
764
|
while ($len > 0) { |
1431
|
393
|
100
|
|
|
|
596
|
my $read = ($len > BUFSIZE) ? BUFSIZE : $len; |
1432
|
393
|
|
|
|
|
634
|
$cb->($self->read($read, 0), $response); |
1433
|
392
|
|
|
|
|
967
|
$len -= $read; |
1434
|
|
|
|
|
|
|
} |
1435
|
400
|
|
|
|
|
1132
|
return length($self->{rbuf}) == 0; |
1436
|
|
|
|
|
|
|
} |
1437
|
|
|
|
|
|
|
|
1438
|
2
|
|
|
|
|
4
|
my $chunk; |
1439
|
2
|
|
|
|
|
10
|
$cb->($chunk, $response) while length( $chunk = $self->read(BUFSIZE, 1) ); |
1440
|
|
|
|
|
|
|
|
1441
|
2
|
|
|
|
|
12
|
return; |
1442
|
|
|
|
|
|
|
} |
1443
|
|
|
|
|
|
|
|
1444
|
|
|
|
|
|
|
sub write_content_body { |
1445
|
23
|
50
|
|
23
|
|
54
|
@_ == 2 || die(q/Usage: $handle->write_content_body(request)/ . "\n"); |
1446
|
23
|
|
|
|
|
33
|
my ($self, $request) = @_; |
1447
|
|
|
|
|
|
|
|
1448
|
23
|
|
|
|
|
40
|
my ($len, $content_length) = (0, $request->{headers}{'content-length'}); |
1449
|
23
|
|
|
|
|
24
|
while () { |
1450
|
173
|
|
|
|
|
435
|
my $data = $request->{cb}->(); |
1451
|
|
|
|
|
|
|
|
1452
|
173
|
100
|
100
|
|
|
689
|
defined $data && length $data |
1453
|
|
|
|
|
|
|
or last; |
1454
|
|
|
|
|
|
|
|
1455
|
150
|
50
|
|
|
|
258
|
if ( $] ge '5.008' ) { |
1456
|
150
|
50
|
|
|
|
281
|
utf8::downgrade($data, 1) |
1457
|
|
|
|
|
|
|
or die(qq/Wide character in write_content()\n/); |
1458
|
|
|
|
|
|
|
} |
1459
|
|
|
|
|
|
|
|
1460
|
150
|
|
|
|
|
568
|
$len += $self->write($data); |
1461
|
|
|
|
|
|
|
} |
1462
|
|
|
|
|
|
|
|
1463
|
23
|
50
|
|
|
|
47
|
$len == $content_length |
1464
|
|
|
|
|
|
|
or die(qq/Content-Length mismatch (got: $len expected: $content_length)\n/); |
1465
|
|
|
|
|
|
|
|
1466
|
23
|
|
|
|
|
44
|
return $len; |
1467
|
|
|
|
|
|
|
} |
1468
|
|
|
|
|
|
|
|
1469
|
|
|
|
|
|
|
sub read_chunked_body { |
1470
|
16
|
50
|
|
16
|
|
98
|
@_ == 3 || die(q/Usage: $handle->read_chunked_body(callback, $response)/ . "\n"); |
1471
|
16
|
|
|
|
|
52
|
my ($self, $cb, $response) = @_; |
1472
|
|
|
|
|
|
|
|
1473
|
16
|
|
|
|
|
29
|
while () { |
1474
|
293
|
|
|
|
|
680
|
my $head = $self->readline; |
1475
|
|
|
|
|
|
|
|
1476
|
293
|
50
|
|
|
|
842
|
$head =~ /\A ([A-Fa-f0-9]+)/x |
1477
|
|
|
|
|
|
|
or die(q/Malformed chunk head: / . $Printable->($head) . "\n"); |
1478
|
|
|
|
|
|
|
|
1479
|
293
|
100
|
|
|
|
644
|
my $len = hex($1) |
1480
|
|
|
|
|
|
|
or last; |
1481
|
|
|
|
|
|
|
|
1482
|
277
|
|
|
|
|
616
|
$self->read_content_body($cb, $response, $len); |
1483
|
|
|
|
|
|
|
|
1484
|
277
|
50
|
|
|
|
458
|
$self->read(2) eq "\x0D\x0A" |
1485
|
|
|
|
|
|
|
or die(qq/Malformed chunk: missing CRLF after chunk data\n/); |
1486
|
|
|
|
|
|
|
} |
1487
|
16
|
|
|
|
|
75
|
$self->read_header_lines($response->{headers}); |
1488
|
16
|
|
|
|
|
142
|
return 1; |
1489
|
|
|
|
|
|
|
} |
1490
|
|
|
|
|
|
|
|
1491
|
|
|
|
|
|
|
sub write_chunked_body { |
1492
|
5
|
50
|
|
5
|
|
62
|
@_ == 2 || die(q/Usage: $handle->write_chunked_body(request)/ . "\n"); |
1493
|
5
|
|
|
|
|
10
|
my ($self, $request) = @_; |
1494
|
|
|
|
|
|
|
|
1495
|
5
|
|
|
|
|
6
|
my $len = 0; |
1496
|
5
|
|
|
|
|
5
|
while () { |
1497
|
59
|
|
|
|
|
205
|
my $data = $request->{cb}->(); |
1498
|
|
|
|
|
|
|
|
1499
|
59
|
100
|
100
|
|
|
260
|
defined $data && length $data |
1500
|
|
|
|
|
|
|
or last; |
1501
|
|
|
|
|
|
|
|
1502
|
54
|
50
|
|
|
|
81
|
if ( $] ge '5.008' ) { |
1503
|
54
|
50
|
|
|
|
106
|
utf8::downgrade($data, 1) |
1504
|
|
|
|
|
|
|
or die(qq/Wide character in write_chunked_body()\n/); |
1505
|
|
|
|
|
|
|
} |
1506
|
|
|
|
|
|
|
|
1507
|
54
|
|
|
|
|
58
|
$len += length $data; |
1508
|
|
|
|
|
|
|
|
1509
|
54
|
|
|
|
|
118
|
my $chunk = sprintf '%X', length $data; |
1510
|
54
|
|
|
|
|
76
|
$chunk .= "\x0D\x0A"; |
1511
|
54
|
|
|
|
|
110
|
$chunk .= $data; |
1512
|
54
|
|
|
|
|
69
|
$chunk .= "\x0D\x0A"; |
1513
|
|
|
|
|
|
|
|
1514
|
54
|
|
|
|
|
82
|
$self->write($chunk); |
1515
|
|
|
|
|
|
|
} |
1516
|
5
|
|
|
|
|
13
|
$self->write("0\x0D\x0A"); |
1517
|
5
|
100
|
|
|
|
19
|
if ( ref $request->{trailer_cb} eq 'CODE' ) { |
1518
|
2
|
|
|
|
|
17
|
$self->write_header_lines($request->{trailer_cb}->()) |
1519
|
|
|
|
|
|
|
} |
1520
|
|
|
|
|
|
|
else { |
1521
|
3
|
|
|
|
|
7
|
$self->write("\x0D\x0A"); |
1522
|
|
|
|
|
|
|
} |
1523
|
5
|
|
|
|
|
19
|
return $len; |
1524
|
|
|
|
|
|
|
} |
1525
|
|
|
|
|
|
|
|
1526
|
|
|
|
|
|
|
sub read_response_header { |
1527
|
151
|
50
|
|
151
|
|
368
|
@_ == 1 || die(q/Usage: $handle->read_response_header()/ . "\n"); |
1528
|
151
|
|
|
|
|
263
|
my ($self) = @_; |
1529
|
|
|
|
|
|
|
|
1530
|
151
|
|
|
|
|
301
|
my $line = $self->readline; |
1531
|
|
|
|
|
|
|
|
1532
|
151
|
100
|
|
|
|
852
|
$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) (?: [\x09\x20]+ ([^\x0D\x0A]*) )? \x0D?\x0A/x |
1533
|
|
|
|
|
|
|
or die(q/Malformed Status-Line: / . $Printable->($line). "\n"); |
1534
|
|
|
|
|
|
|
|
1535
|
149
|
|
|
|
|
626
|
my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4); |
1536
|
149
|
100
|
|
|
|
335
|
$reason = "" unless defined $reason; |
1537
|
|
|
|
|
|
|
|
1538
|
149
|
100
|
|
|
|
553
|
die (qq/Unsupported HTTP protocol: $protocol\n/) |
1539
|
|
|
|
|
|
|
unless $version =~ /0*1\.0*[01]/; |
1540
|
|
|
|
|
|
|
|
1541
|
|
|
|
|
|
|
return { |
1542
|
147
|
|
|
|
|
388
|
status => $status, |
1543
|
|
|
|
|
|
|
reason => $reason, |
1544
|
|
|
|
|
|
|
headers => $self->read_header_lines, |
1545
|
|
|
|
|
|
|
protocol => $protocol, |
1546
|
|
|
|
|
|
|
}; |
1547
|
|
|
|
|
|
|
} |
1548
|
|
|
|
|
|
|
|
1549
|
|
|
|
|
|
|
sub write_request_header { |
1550
|
144
|
50
|
|
144
|
|
272
|
@_ == 5 || die(q/Usage: $handle->write_request_header(method, request_uri, headers, header_case)/ . "\n"); |
1551
|
144
|
|
|
|
|
255
|
my ($self, $method, $request_uri, $headers, $header_case) = @_; |
1552
|
|
|
|
|
|
|
|
1553
|
144
|
|
|
|
|
409
|
return $self->write_header_lines($headers, $header_case, "$method $request_uri HTTP/1.1\x0D\x0A"); |
1554
|
|
|
|
|
|
|
} |
1555
|
|
|
|
|
|
|
|
1556
|
|
|
|
|
|
|
sub _do_timeout { |
1557
|
472
|
|
|
472
|
|
841
|
my ($self, $type, $timeout) = @_; |
1558
|
|
|
|
|
|
|
$timeout = $self->{timeout} |
1559
|
472
|
50
|
33
|
|
|
950
|
unless defined $timeout && $timeout >= 0; |
1560
|
|
|
|
|
|
|
|
1561
|
472
|
|
|
|
|
1110
|
my $fd = fileno $self->{fh}; |
1562
|
472
|
50
|
33
|
|
|
5118
|
defined $fd && $fd >= 0 |
1563
|
|
|
|
|
|
|
or die(qq/select(2): 'Bad file descriptor'\n/); |
1564
|
|
|
|
|
|
|
|
1565
|
472
|
|
|
|
|
637
|
my $initial = time; |
1566
|
472
|
|
|
|
|
599
|
my $pending = $timeout; |
1567
|
472
|
|
|
|
|
519
|
my $nfound; |
1568
|
|
|
|
|
|
|
|
1569
|
472
|
|
|
|
|
1449
|
vec(my $fdset = '', $fd, 1) = 1; |
1570
|
|
|
|
|
|
|
|
1571
|
472
|
|
|
|
|
736
|
while () { |
1572
|
472
|
100
|
|
|
|
1046745
|
$nfound = ($type eq 'read') |
1573
|
|
|
|
|
|
|
? select($fdset, undef, undef, $pending) |
1574
|
|
|
|
|
|
|
: select(undef, $fdset, undef, $pending) ; |
1575
|
472
|
50
|
|
|
|
1700
|
if ($nfound == -1) { |
1576
|
0
|
0
|
|
|
|
0
|
$! == EINTR |
1577
|
|
|
|
|
|
|
or die(qq/select(2): '$!'\n/); |
1578
|
0
|
0
|
0
|
|
|
0
|
redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0; |
1579
|
0
|
|
|
|
|
0
|
$nfound = 0; |
1580
|
|
|
|
|
|
|
} |
1581
|
472
|
|
|
|
|
663
|
last; |
1582
|
|
|
|
|
|
|
} |
1583
|
472
|
|
|
|
|
936
|
$! = 0; |
1584
|
472
|
|
|
|
|
1183
|
return $nfound; |
1585
|
|
|
|
|
|
|
} |
1586
|
|
|
|
|
|
|
|
1587
|
|
|
|
|
|
|
sub can_read { |
1588
|
510
|
50
|
33
|
510
|
|
1039
|
@_ == 1 || @_ == 2 || die(q/Usage: $handle->can_read([timeout])/ . "\n"); |
1589
|
510
|
|
|
|
|
700
|
my $self = shift; |
1590
|
510
|
100
|
|
|
|
1240
|
if ( ref($self->{fh}) eq 'IO::Socket::SSL' ) { |
1591
|
502
|
100
|
|
|
|
1125
|
return 1 if $self->{fh}->pending; |
1592
|
|
|
|
|
|
|
} |
1593
|
464
|
|
|
|
|
4614
|
return $self->_do_timeout('read', @_) |
1594
|
|
|
|
|
|
|
} |
1595
|
|
|
|
|
|
|
|
1596
|
|
|
|
|
|
|
sub can_write { |
1597
|
8
|
50
|
33
|
8
|
|
40
|
@_ == 1 || @_ == 2 || die(q/Usage: $handle->can_write([timeout])/ . "\n"); |
1598
|
8
|
|
|
|
|
22
|
my $self = shift; |
1599
|
8
|
|
|
|
|
32
|
return $self->_do_timeout('write', @_) |
1600
|
|
|
|
|
|
|
} |
1601
|
|
|
|
|
|
|
|
1602
|
|
|
|
|
|
|
sub _assert_ssl { |
1603
|
9
|
|
|
9
|
|
55
|
my($ok, $reason) = HTTP::Tiny->can_ssl(); |
1604
|
9
|
50
|
|
|
|
29
|
die $reason unless $ok; |
1605
|
|
|
|
|
|
|
} |
1606
|
|
|
|
|
|
|
|
1607
|
|
|
|
|
|
|
sub can_reuse { |
1608
|
13
|
|
|
13
|
|
23
|
my ($self,$scheme,$host,$port,$peer) = @_; |
1609
|
|
|
|
|
|
|
return 0 if |
1610
|
|
|
|
|
|
|
$self->{pid} != $$ |
1611
|
|
|
|
|
|
|
|| $self->{tid} != _get_tid() |
1612
|
|
|
|
|
|
|
|| length($self->{rbuf}) |
1613
|
|
|
|
|
|
|
|| $scheme ne $self->{scheme} |
1614
|
|
|
|
|
|
|
|| $host ne $self->{host} |
1615
|
|
|
|
|
|
|
|| $port ne $self->{port} |
1616
|
|
|
|
|
|
|
|| $peer ne $self->{peer} |
1617
|
13
|
100
|
33
|
|
|
44
|
|| eval { $self->can_read(0) } |
|
10
|
|
33
|
|
|
22
|
|
|
|
|
66
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
66
|
|
|
|
|
1618
|
|
|
|
|
|
|
|| $@ ; |
1619
|
3
|
|
|
|
|
19
|
return 1; |
1620
|
|
|
|
|
|
|
} |
1621
|
|
|
|
|
|
|
|
1622
|
|
|
|
|
|
|
# Try to find a CA bundle to validate the SSL cert, |
1623
|
|
|
|
|
|
|
# prefer Mozilla::CA or fallback to a system file |
1624
|
|
|
|
|
|
|
sub _find_CA_file { |
1625
|
5
|
|
|
5
|
|
17
|
my $self = shift(); |
1626
|
|
|
|
|
|
|
|
1627
|
|
|
|
|
|
|
my $ca_file = |
1628
|
|
|
|
|
|
|
defined( $self->{SSL_options}->{SSL_ca_file} ) |
1629
|
|
|
|
|
|
|
? $self->{SSL_options}->{SSL_ca_file} |
1630
|
5
|
100
|
|
|
|
49
|
: $ENV{SSL_CERT_FILE}; |
1631
|
|
|
|
|
|
|
|
1632
|
5
|
100
|
|
|
|
44
|
if ( defined $ca_file ) { |
1633
|
1
|
50
|
|
|
|
43
|
unless ( -r $ca_file ) { |
1634
|
1
|
|
|
|
|
21
|
die qq/SSL_ca_file '$ca_file' not found or not readable\n/; |
1635
|
|
|
|
|
|
|
} |
1636
|
0
|
|
|
|
|
0
|
return $ca_file; |
1637
|
|
|
|
|
|
|
} |
1638
|
|
|
|
|
|
|
|
1639
|
4
|
|
|
|
|
33
|
local @INC = @INC; |
1640
|
4
|
100
|
|
|
|
27
|
pop @INC if $INC[-1] eq '.'; |
1641
|
|
|
|
|
|
|
return Mozilla::CA::SSL_ca_file() |
1642
|
4
|
50
|
|
|
|
10
|
if eval { require Mozilla::CA; 1 }; |
|
4
|
|
|
|
|
31
|
|
|
4
|
|
|
|
|
35
|
|
1643
|
|
|
|
|
|
|
|
1644
|
|
|
|
|
|
|
# cert list copied from golang src/crypto/x509/root_unix.go |
1645
|
0
|
|
|
|
|
0
|
foreach my $ca_bundle ( |
1646
|
|
|
|
|
|
|
"/etc/ssl/certs/ca-certificates.crt", # Debian/Ubuntu/Gentoo etc. |
1647
|
|
|
|
|
|
|
"/etc/pki/tls/certs/ca-bundle.crt", # Fedora/RHEL |
1648
|
|
|
|
|
|
|
"/etc/ssl/ca-bundle.pem", # OpenSUSE |
1649
|
|
|
|
|
|
|
"/etc/openssl/certs/ca-certificates.crt", # NetBSD |
1650
|
|
|
|
|
|
|
"/etc/ssl/cert.pem", # OpenBSD |
1651
|
|
|
|
|
|
|
"/usr/local/share/certs/ca-root-nss.crt", # FreeBSD/DragonFly |
1652
|
|
|
|
|
|
|
"/etc/pki/tls/cacert.pem", # OpenELEC |
1653
|
|
|
|
|
|
|
"/etc/certs/ca-certificates.crt", # Solaris 11.2+ |
1654
|
|
|
|
|
|
|
) { |
1655
|
0
|
0
|
|
|
|
0
|
return $ca_bundle if -e $ca_bundle; |
1656
|
|
|
|
|
|
|
} |
1657
|
|
|
|
|
|
|
|
1658
|
0
|
|
|
|
|
0
|
die qq/Couldn't find a CA bundle with which to verify the SSL certificate.\n/ |
1659
|
|
|
|
|
|
|
. qq/Try installing Mozilla::CA from CPAN\n/; |
1660
|
|
|
|
|
|
|
} |
1661
|
|
|
|
|
|
|
|
1662
|
|
|
|
|
|
|
# for thread safety, we need to know thread id if threads are loaded |
1663
|
|
|
|
|
|
|
sub _get_tid { |
1664
|
29
|
|
|
29
|
|
213
|
no warnings 'reserved'; # for 'threads' |
|
29
|
|
|
|
|
80
|
|
|
29
|
|
|
|
|
7122
|
|
1665
|
155
|
50
|
|
155
|
|
2326
|
return threads->can("tid") ? threads->tid : 0; |
1666
|
|
|
|
|
|
|
} |
1667
|
|
|
|
|
|
|
|
1668
|
|
|
|
|
|
|
sub _ssl_args { |
1669
|
9
|
|
|
9
|
|
29
|
my ($self, $host) = @_; |
1670
|
|
|
|
|
|
|
|
1671
|
9
|
|
|
|
|
20
|
my %ssl_args; |
1672
|
|
|
|
|
|
|
|
1673
|
|
|
|
|
|
|
# This test reimplements IO::Socket::SSL::can_client_sni(), which wasn't |
1674
|
|
|
|
|
|
|
# added until IO::Socket::SSL 1.84 |
1675
|
9
|
50
|
|
|
|
374
|
if ( Net::SSLeay::OPENSSL_VERSION_NUMBER() >= 0x01000000 ) { |
1676
|
9
|
|
|
|
|
90
|
$ssl_args{SSL_hostname} = $host, # Sane SNI support |
1677
|
|
|
|
|
|
|
} |
1678
|
|
|
|
|
|
|
|
1679
|
9
|
100
|
|
|
|
66
|
if ($self->{verify_SSL}) { |
1680
|
3
|
|
|
|
|
13
|
$ssl_args{SSL_verifycn_scheme} = 'http'; # enable CN validation |
1681
|
3
|
|
|
|
|
8
|
$ssl_args{SSL_verifycn_name} = $host; # set validation hostname |
1682
|
3
|
|
|
|
|
9
|
$ssl_args{SSL_verify_mode} = 0x01; # enable cert validation |
1683
|
3
|
|
|
|
|
11
|
$ssl_args{SSL_ca_file} = $self->_find_CA_file; |
1684
|
|
|
|
|
|
|
} |
1685
|
|
|
|
|
|
|
else { |
1686
|
6
|
|
|
|
|
33
|
$ssl_args{SSL_verifycn_scheme} = 'none'; # disable CN validation |
1687
|
6
|
|
|
|
|
19
|
$ssl_args{SSL_verify_mode} = 0x00; # disable cert validation |
1688
|
|
|
|
|
|
|
} |
1689
|
|
|
|
|
|
|
|
1690
|
|
|
|
|
|
|
# user options override settings from verify_SSL |
1691
|
9
|
|
|
|
|
333
|
for my $k ( keys %{$self->{SSL_options}} ) { |
|
9
|
|
|
|
|
60
|
|
1692
|
18
|
50
|
|
|
|
129
|
$ssl_args{$k} = $self->{SSL_options}{$k} if $k =~ m/^SSL_/; |
1693
|
|
|
|
|
|
|
} |
1694
|
|
|
|
|
|
|
|
1695
|
9
|
|
|
|
|
37
|
return \%ssl_args; |
1696
|
|
|
|
|
|
|
} |
1697
|
|
|
|
|
|
|
|
1698
|
|
|
|
|
|
|
1; |
1699
|
|
|
|
|
|
|
|
1700
|
|
|
|
|
|
|
__END__ |