File Coverage

blib/lib/HTTP/Tiny.pm
Criterion Covered Total %
statement 611 688 88.8
branch 331 478 69.2
condition 191 293 65.1
subroutine 76 81 93.8
pod 13 15 86.6
total 1222 1555 78.5


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__