1# vim: ts=4 sts=4 sw=4 et:
2package HTTP::Tiny;
3use strict;
4use warnings;
5# ABSTRACT: A small, simple, correct HTTP/1.1 client
6
7our $VERSION = '0.088';
8
9sub _croak { require Carp; Carp::croak(@_) }
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<agent> — A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If
19#pod   C<agent> — ends in a space character, the default user-agent string is
20#pod   appended.
21#pod * C<cookie_jar> — An instance of L<HTTP::CookieJar> — or equivalent class
22#pod   that supports the C<add> and C<cookie_header> methods
23#pod * C<default_headers> — A hashref of default headers to apply to requests
24#pod * C<local_address> — The local IP address to bind to
25#pod * C<keep_alive> — Whether to reuse the last connection (if for the same
26#pod   scheme, host and port) (defaults to 1)
27#pod * C<max_redirect> — Maximum number of redirects allowed (defaults to 5)
28#pod * C<max_size> — 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<http_proxy> — URL of a proxy server to use for HTTP connections
32#pod   (default is C<$ENV{http_proxy}> — if set)
33#pod * C<https_proxy> — URL of a proxy server to use for HTTPS connections
34#pod   (default is C<$ENV{https_proxy}> — if set)
35#pod * C<proxy> — 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<no_proxy> — 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<timeout> — 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<verify_SSL> — A boolean that indicates whether to validate the TLS/SSL
44#pod   certificate of an C<https> — connection (default is true). Changed from false
45#pod   to true in version 0.083.
46#pod * C<SSL_options> — A hashref of C<SSL_*> — options to pass through to
47#pod   L<IO::Socket::SSL>
48#pod * C<$ENV{PERL_HTTP_TINY_SSL_INSECURE_BY_DEFAULT}> - Changes the default
49#pod   certificate verification behavior to not check server identity if set to 1.
50#pod   Only effective if C<verify_SSL> is not set. Added in version 0.083.
51#pod
52#pod
53#pod An accessor/mutator method exists for each attribute.
54#pod
55#pod Passing an explicit C<undef> for C<proxy>, C<http_proxy> or C<https_proxy> will
56#pod prevent getting the corresponding proxies from the environment.
57#pod
58#pod Errors during request execution will result in a pseudo-HTTP status code of 599
59#pod and a reason of "Internal Exception". The content field in the response will
60#pod contain the text of the error.
61#pod
62#pod The C<keep_alive> parameter enables a persistent connection, but only to a
63#pod single destination scheme, host and port.  If any connection-relevant
64#pod attributes are modified via accessor, or if the process ID or thread ID change,
65#pod the persistent connection will be dropped.  If you want persistent connections
66#pod across multiple destinations, use multiple HTTP::Tiny objects.
67#pod
68#pod See L</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes.
69#pod
70#pod =cut
71
72my @attributes;
73BEGIN {
74    @attributes = qw(
75        cookie_jar default_headers http_proxy https_proxy keep_alive
76        local_address max_redirect max_size proxy no_proxy
77        SSL_options verify_SSL
78    );
79    my %persist_ok = map {; $_ => 1 } qw(
80        cookie_jar default_headers max_redirect max_size
81    );
82    no strict 'refs';
83    no warnings 'uninitialized';
84    for my $accessor ( @attributes ) {
85        *{$accessor} = sub {
86            @_ > 1
87                ? do {
88                    delete $_[0]->{handle} if !$persist_ok{$accessor} && $_[1] ne $_[0]->{$accessor};
89                    $_[0]->{$accessor} = $_[1]
90                }
91                : $_[0]->{$accessor};
92        };
93    }
94}
95
96sub agent {
97    my($self, $agent) = @_;
98    if( @_ > 1 ){
99        $self->{agent} =
100            (defined $agent && $agent =~ / $/) ? $agent . $self->_agent : $agent;
101    }
102    return $self->{agent};
103}
104
105sub timeout {
106    my ($self, $timeout) = @_;
107    if ( @_ > 1 ) {
108        $self->{timeout} = $timeout;
109        if ($self->{handle}) {
110            $self->{handle}->timeout($timeout);
111        }
112    }
113    return $self->{timeout};
114}
115
116sub new {
117    my($class, %args) = @_;
118
119    # Support lower case verify_ssl argument, but only if verify_SSL is not
120    # true.
121    if ( exists $args{verify_ssl} ) {
122        $args{verify_SSL}  ||= $args{verify_ssl};
123    }
124
125    my $self = {
126        max_redirect => 5,
127        timeout      => defined $args{timeout} ? $args{timeout} : 60,
128        keep_alive   => 1,
129        verify_SSL   => defined $args{verify_SSL} ? $args{verify_SSL} : _verify_SSL_default(),
130        no_proxy     => $ENV{no_proxy},
131    };
132
133    bless $self, $class;
134
135    $class->_validate_cookie_jar( $args{cookie_jar} ) if $args{cookie_jar};
136
137    for my $key ( @attributes ) {
138        $self->{$key} = $args{$key} if exists $args{$key}
139    }
140
141    $self->agent( exists $args{agent} ? $args{agent} : $class->_agent );
142
143    $self->_set_proxies;
144
145    return $self;
146}
147
148sub _verify_SSL_default {
149    my ($self) = @_;
150    # Check if insecure default certificate verification behaviour has been
151    # changed by the user by setting PERL_HTTP_TINY_SSL_INSECURE_BY_DEFAULT=1
152    return (($ENV{PERL_HTTP_TINY_SSL_INSECURE_BY_DEFAULT} || '') eq '1') ? 0 : 1;
153}
154
155sub _set_proxies {
156    my ($self) = @_;
157
158    # get proxies from %ENV only if not provided; explicit undef will disable
159    # getting proxies from the environment
160
161    # generic proxy
162    if (! exists $self->{proxy} ) {
163        $self->{proxy} = $ENV{all_proxy} || $ENV{ALL_PROXY};
164    }
165
166    if ( defined $self->{proxy} ) {
167        $self->_split_proxy( 'generic proxy' => $self->{proxy} ); # validate
168    }
169    else {
170        delete $self->{proxy};
171    }
172
173    # http proxy
174    if (! exists $self->{http_proxy} ) {
175        # under CGI, bypass HTTP_PROXY as request sets it from Proxy header
176        local $ENV{HTTP_PROXY} = ($ENV{CGI_HTTP_PROXY} || "") if $ENV{REQUEST_METHOD};
177        $self->{http_proxy} = $ENV{http_proxy} || $ENV{HTTP_PROXY} || $self->{proxy};
178    }
179
180    if ( defined $self->{http_proxy} ) {
181        $self->_split_proxy( http_proxy => $self->{http_proxy} ); # validate
182        $self->{_has_proxy}{http} = 1;
183    }
184    else {
185        delete $self->{http_proxy};
186    }
187
188    # https proxy
189    if (! exists $self->{https_proxy} ) {
190        $self->{https_proxy} = $ENV{https_proxy} || $ENV{HTTPS_PROXY} || $self->{proxy};
191    }
192
193    if ( $self->{https_proxy} ) {
194        $self->_split_proxy( https_proxy => $self->{https_proxy} ); # validate
195        $self->{_has_proxy}{https} = 1;
196    }
197    else {
198        delete $self->{https_proxy};
199    }
200
201    # Split no_proxy to array reference if not provided as such
202    unless ( ref $self->{no_proxy} eq 'ARRAY' ) {
203        $self->{no_proxy} =
204            (defined $self->{no_proxy}) ? [ split /\s*,\s*/, $self->{no_proxy} ] : [];
205    }
206
207    return;
208}
209
210#pod =method get|head|put|post|patch|delete
211#pod
212#pod     $response = $http->get($url);
213#pod     $response = $http->get($url, \%options);
214#pod     $response = $http->head($url);
215#pod
216#pod These methods are shorthand for calling C<request()> for the given method.  The
217#pod URL must have unsafe characters escaped and international domain names encoded.
218#pod See C<request()> for valid options and a description of the response.
219#pod
220#pod The C<success> field of the response will be true if the status code is 2XX.
221#pod
222#pod =cut
223
224for my $sub_name ( qw/get head put post patch delete/ ) {
225    my $req_method = uc $sub_name;
226    no strict 'refs';
227    eval <<"HERE"; ## no critic
228    sub $sub_name {
229        my (\$self, \$url, \$args) = \@_;
230        \@_ == 2 || (\@_ == 3 && ref \$args eq 'HASH')
231        or _croak(q/Usage: \$http->$sub_name(URL, [HASHREF])/ . "\n");
232        return \$self->request('$req_method', \$url, \$args || {});
233    }
234HERE
235}
236
237#pod =method post_form
238#pod
239#pod     $response = $http->post_form($url, $form_data);
240#pod     $response = $http->post_form($url, $form_data, \%options);
241#pod
242#pod This method executes a C<POST> request and sends the key/value pairs from a
243#pod form data hash or array reference to the given URL with a C<content-type> of
244#pod C<application/x-www-form-urlencoded>.  If data is provided as an array
245#pod reference, the order is preserved; if provided as a hash reference, the terms
246#pod are sorted on key and value for consistency.  See documentation for the
247#pod C<www_form_urlencode> method for details on the encoding.
248#pod
249#pod The URL must have unsafe characters escaped and international domain names
250#pod encoded.  See C<request()> for valid options and a description of the response.
251#pod Any C<content-type> header or content in the options hashref will be ignored.
252#pod
253#pod The C<success> field of the response will be true if the status code is 2XX.
254#pod
255#pod =cut
256
257sub post_form {
258    my ($self, $url, $data, $args) = @_;
259    (@_ == 3 || @_ == 4 && ref $args eq 'HASH')
260        or _croak(q/Usage: $http->post_form(URL, DATAREF, [HASHREF])/ . "\n");
261
262    my $headers = {};
263    while ( my ($key, $value) = each %{$args->{headers} || {}} ) {
264        $headers->{lc $key} = $value;
265    }
266
267    return $self->request('POST', $url, {
268            # Any existing 'headers' key in $args will be overridden with a
269            # normalized version below.
270            %$args,
271            content => $self->www_form_urlencode($data),
272            headers => {
273                %$headers,
274                'content-type' => 'application/x-www-form-urlencoded'
275            },
276        }
277    );
278}
279
280#pod =method mirror
281#pod
282#pod     $response = $http->mirror($url, $file, \%options)
283#pod     if ( $response->{success} ) {
284#pod         print "$file is up to date\n";
285#pod     }
286#pod
287#pod Executes a C<GET> request for the URL and saves the response body to the file
288#pod name provided.  The URL must have unsafe characters escaped and international
289#pod domain names encoded.  If the file already exists, the request will include an
290#pod C<If-Modified-Since> header with the modification timestamp of the file.  You
291#pod may specify a different C<If-Modified-Since> header yourself in the C<<
292#pod $options->{headers} >> hash.
293#pod
294#pod The C<success> field of the response will be true if the status code is 2XX
295#pod or if the status code is 304 (unmodified).
296#pod
297#pod If the file was modified and the server response includes a properly
298#pod formatted C<Last-Modified> header, the file modification time will
299#pod be updated accordingly.
300#pod
301#pod =cut
302
303sub mirror {
304    my ($self, $url, $file, $args) = @_;
305    @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
306      or _croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ . "\n");
307
308    if ( exists $args->{headers} ) {
309        my $headers = {};
310        while ( my ($key, $value) = each %{$args->{headers} || {}} ) {
311            $headers->{lc $key} = $value;
312        }
313        $args->{headers} = $headers;
314    }
315
316    if ( -e $file and my $mtime = (stat($file))[9] ) {
317        $args->{headers}{'if-modified-since'} ||= $self->_http_date($mtime);
318    }
319    my $tempfile = $file . int(rand(2**31));
320
321    require Fcntl;
322    sysopen my $fh, $tempfile, Fcntl::O_CREAT()|Fcntl::O_EXCL()|Fcntl::O_WRONLY()
323       or _croak(qq/Error: Could not create temporary file $tempfile for downloading: $!\n/);
324    binmode $fh;
325    $args->{data_callback} = sub { print {$fh} $_[0] };
326    my $response = $self->request('GET', $url, $args);
327    close $fh
328        or _croak(qq/Error: Caught error closing temporary file $tempfile: $!\n/);
329
330    if ( $response->{success} ) {
331        rename $tempfile, $file
332            or _croak(qq/Error replacing $file with $tempfile: $!\n/);
333        my $lm = $response->{headers}{'last-modified'};
334        if ( $lm and my $mtime = $self->_parse_http_date($lm) ) {
335            utime $mtime, $mtime, $file;
336        }
337    }
338    $response->{success} ||= $response->{status} eq '304';
339    unlink $tempfile;
340    return $response;
341}
342
343#pod =method request
344#pod
345#pod     $response = $http->request($method, $url);
346#pod     $response = $http->request($method, $url, \%options);
347#pod
348#pod Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST',
349#pod 'PUT', etc.) on the given URL.  The URL must have unsafe characters escaped and
350#pod international domain names encoded.
351#pod
352#pod B<NOTE>: Method names are B<case-sensitive> per the HTTP/1.1 specification.
353#pod Don't use C<get> when you really want C<GET>.  See L<LIMITATIONS> for
354#pod how this applies to redirection.
355#pod
356#pod If the URL includes a "user:password" stanza, they will be used for Basic-style
357#pod authorization headers.  (Authorization headers will not be included in a
358#pod redirected request.) For example:
359#pod
360#pod     $http->request('GET', 'http://Aladdin:open sesame@example.com/');
361#pod
362#pod If the "user:password" stanza contains reserved characters, they must
363#pod be percent-escaped:
364#pod
365#pod     $http->request('GET', 'http://john%40example.com:password@example.com/');
366#pod
367#pod A hashref of options may be appended to modify the request.
368#pod
369#pod Valid options are:
370#pod
371#pod =for :list
372#pod * C<headers> —
373#pod     A hashref containing headers to include with the request.  If the value for
374#pod     a header is an array reference, the header will be output multiple times with
375#pod     each value in the array.  These headers over-write any default headers.
376#pod * C<content> —
377#pod     A scalar to include as the body of the request OR a code reference
378#pod     that will be called iteratively to produce the body of the request
379#pod * C<trailer_callback> —
380#pod     A code reference that will be called if it exists to provide a hashref
381#pod     of trailing headers (only used with chunked transfer-encoding)
382#pod * C<data_callback> —
383#pod     A code reference that will be called for each chunks of the response
384#pod     body received.
385#pod * C<peer> —
386#pod     Override host resolution and force all connections to go only to a
387#pod     specific peer address, regardless of the URL of the request.  This will
388#pod     include any redirections!  This options should be used with extreme
389#pod     caution (e.g. debugging or very special circumstances). It can be given as
390#pod     either a scalar or a code reference that will receive the hostname and
391#pod     whose response will be taken as the address.
392#pod
393#pod The C<Host> header is generated from the URL in accordance with RFC 2616.  It
394#pod is a fatal error to specify C<Host> in the C<headers> option.  Other headers
395#pod may be ignored or overwritten if necessary for transport compliance.
396#pod
397#pod If the C<content> option is a code reference, it will be called iteratively
398#pod to provide the content body of the request.  It should return the empty
399#pod string or undef when the iterator is exhausted.
400#pod
401#pod If the C<content> option is the empty string, no C<content-type> or
402#pod C<content-length> headers will be generated.
403#pod
404#pod If the C<data_callback> option is provided, it will be called iteratively until
405#pod the entire response body is received.  The first argument will be a string
406#pod containing a chunk of the response body, the second argument will be the
407#pod in-progress response hash reference, as described below.  (This allows
408#pod customizing the action of the callback based on the C<status> or C<headers>
409#pod received prior to the content body.)
410#pod
411#pod Content data in the request/response is handled as "raw bytes".  Any
412#pod encoding/decoding (with associated headers) are the responsibility of the
413#pod caller.
414#pod
415#pod The C<request> method returns a hashref containing the response.  The hashref
416#pod will have the following keys:
417#pod
418#pod =for :list
419#pod * C<success> —
420#pod     Boolean indicating whether the operation returned a 2XX status code
421#pod * C<url> —
422#pod     URL that provided the response. This is the URL of the request unless
423#pod     there were redirections, in which case it is the last URL queried
424#pod     in a redirection chain
425#pod * C<status> —
426#pod     The HTTP status code of the response
427#pod * C<reason> —
428#pod     The response phrase returned by the server
429#pod * C<content> —
430#pod     The body of the response.  If the response does not have any content
431#pod     or if a data callback is provided to consume the response body,
432#pod     this will be the empty string
433#pod * C<headers> —
434#pod     A hashref of header fields.  All header field names will be normalized
435#pod     to be lower case. If a header is repeated, the value will be an arrayref;
436#pod     it will otherwise be a scalar string containing the value
437#pod * C<protocol> -
438#pod     If this field exists, it is the protocol of the response
439#pod     such as HTTP/1.0 or HTTP/1.1
440#pod * C<redirects>
441#pod     If this field exists, it is an arrayref of response hash references from
442#pod     redirects in the same order that redirections occurred.  If it does
443#pod     not exist, then no redirections occurred.
444#pod
445#pod On an error during the execution of the request, the C<status> field will
446#pod contain 599, and the C<content> field will contain the text of the error.
447#pod
448#pod =cut
449
450my %idempotent = map { $_ => 1 } qw/GET HEAD PUT DELETE OPTIONS TRACE/;
451
452sub request {
453    my ($self, $method, $url, $args) = @_;
454    @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
455      or _croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/ . "\n");
456    $args ||= {}; # we keep some state in this during _request
457
458    # RFC 2616 Section 8.1.4 mandates a single retry on broken socket
459    my $response;
460    for ( 0 .. 1 ) {
461        $response = eval { $self->_request($method, $url, $args) };
462        last unless $@ && $idempotent{$method}
463            && $@ =~ m{^(?:Socket closed|Unexpected end|SSL read error)};
464    }
465
466    if (my $e = $@) {
467        # maybe we got a response hash thrown from somewhere deep
468        if ( ref $e eq 'HASH' && exists $e->{status} ) {
469            $e->{redirects} = delete $args->{_redirects} if @{ $args->{_redirects} || []};
470            return $e;
471        }
472
473        # otherwise, stringify it
474        $e = "$e";
475        $response = {
476            url     => $url,
477            success => q{},
478            status  => 599,
479            reason  => 'Internal Exception',
480            content => $e,
481            headers => {
482                'content-type'   => 'text/plain',
483                'content-length' => length $e,
484            },
485            ( @{$args->{_redirects} || []} ? (redirects => delete $args->{_redirects}) : () ),
486        };
487    }
488    return $response;
489}
490
491#pod =method www_form_urlencode
492#pod
493#pod     $params = $http->www_form_urlencode( $data );
494#pod     $response = $http->get("http://example.com/query?$params");
495#pod
496#pod This method converts the key/value pairs from a data hash or array reference
497#pod into a C<x-www-form-urlencoded> string.  The keys and values from the data
498#pod reference will be UTF-8 encoded and escaped per RFC 3986.  If a value is an
499#pod array reference, the key will be repeated with each of the values of the array
500#pod reference.  If data is provided as a hash reference, the key/value pairs in the
501#pod resulting string will be sorted by key and value for consistent ordering.
502#pod
503#pod =cut
504
505sub www_form_urlencode {
506    my ($self, $data) = @_;
507    (@_ == 2 && ref $data)
508        or _croak(q/Usage: $http->www_form_urlencode(DATAREF)/ . "\n");
509    (ref $data eq 'HASH' || ref $data eq 'ARRAY')
510        or _croak("form data must be a hash or array reference\n");
511
512    my @params = ref $data eq 'HASH' ? %$data : @$data;
513    @params % 2 == 0
514        or _croak("form data reference must have an even number of terms\n");
515
516    my @terms;
517    while( @params ) {
518        my ($key, $value) = splice(@params, 0, 2);
519        _croak("form data keys must not be undef")
520            if !defined($key);
521        if ( ref $value eq 'ARRAY' ) {
522            unshift @params, map { $key => $_ } @$value;
523        }
524        else {
525            push @terms, join("=", map { $self->_uri_escape($_) } $key, $value);
526        }
527    }
528
529    return join("&", (ref $data eq 'ARRAY') ? (@terms) : (sort @terms) );
530}
531
532#pod =method can_ssl
533#pod
534#pod     $ok         = HTTP::Tiny->can_ssl;
535#pod     ($ok, $why) = HTTP::Tiny->can_ssl;
536#pod     ($ok, $why) = $http->can_ssl;
537#pod
538#pod Indicates if SSL support is available.  When called as a class object, it
539#pod checks for the correct version of L<Net::SSLeay> and L<IO::Socket::SSL>.
540#pod When called as an object methods, if C<SSL_verify> is true or if C<SSL_verify_mode>
541#pod is set in C<SSL_options>, it checks that a CA file is available.
542#pod
543#pod In scalar context, returns a boolean indicating if SSL is available.
544#pod In list context, returns the boolean and a (possibly multi-line) string of
545#pod errors indicating why SSL isn't available.
546#pod
547#pod =cut
548
549sub can_ssl {
550    my ($self) = @_;
551
552    my($ok, $reason) = (1, '');
553
554    # Need IO::Socket::SSL 1.42 for SSL_create_ctx_callback
555    local @INC = @INC;
556    pop @INC if $INC[-1] eq '.';
557    unless (eval {require IO::Socket::SSL; IO::Socket::SSL->VERSION(1.42)}) {
558        $ok = 0;
559        $reason .= qq/IO::Socket::SSL 1.42 must be installed for https support\n/;
560    }
561
562    # Need Net::SSLeay 1.49 for MODE_AUTO_RETRY
563    unless (eval {require Net::SSLeay; Net::SSLeay->VERSION(1.49)}) {
564        $ok = 0;
565        $reason .= qq/Net::SSLeay 1.49 must be installed for https support\n/;
566    }
567
568    # If an object, check that SSL config lets us get a CA if necessary
569    if ( ref($self) && ( $self->{verify_SSL} || $self->{SSL_options}{SSL_verify_mode} ) ) {
570        my $handle = HTTP::Tiny::Handle->new(
571            SSL_options => $self->{SSL_options},
572            verify_SSL  => $self->{verify_SSL},
573        );
574        unless ( eval { $handle->_find_CA_file; 1 } ) {
575            $ok = 0;
576            $reason .= "$@";
577        }
578    }
579
580    wantarray ? ($ok, $reason) : $ok;
581}
582
583#pod =method connected
584#pod
585#pod     $host = $http->connected;
586#pod     ($host, $port) = $http->connected;
587#pod
588#pod Indicates if a connection to a peer is being kept alive, per the C<keep_alive>
589#pod option.
590#pod
591#pod In scalar context, returns the peer host and port, joined with a colon, or
592#pod C<undef> (if no peer is connected).
593#pod In list context, returns the peer host and port or an empty list (if no peer
594#pod is connected).
595#pod
596#pod B<Note>: This method cannot reliably be used to discover whether the remote
597#pod host has closed its end of the socket.
598#pod
599#pod =cut
600
601sub connected {
602    my ($self) = @_;
603
604    if ( $self->{handle} ) {
605        return $self->{handle}->connected;
606    }
607    return;
608}
609
610#--------------------------------------------------------------------------#
611# private methods
612#--------------------------------------------------------------------------#
613
614my %DefaultPort = (
615    http => 80,
616    https => 443,
617);
618
619sub _agent {
620    my $class = ref($_[0]) || $_[0];
621    (my $default_agent = $class) =~ s{::}{-}g;
622    my $version = $class->VERSION;
623    $default_agent .= "/$version" if defined $version;
624    return $default_agent;
625}
626
627sub _request {
628    my ($self, $method, $url, $args) = @_;
629
630    my ($scheme, $host, $port, $path_query, $auth) = $self->_split_url($url);
631
632    if ($scheme ne 'http' && $scheme ne 'https') {
633      die(qq/Unsupported URL scheme '$scheme'\n/);
634    }
635
636    my $request = {
637        method    => $method,
638        scheme    => $scheme,
639        host      => $host,
640        port      => $port,
641        host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
642        uri       => $path_query,
643        headers   => {},
644    };
645
646    my $peer = $args->{peer} || $host;
647
648    # Allow 'peer' to be a coderef.
649    if ('CODE' eq ref $peer) {
650        $peer = $peer->($host);
651    }
652
653    # We remove the cached handle so it is not reused in the case of redirect.
654    # If all is well, it will be recached at the end of _request.  We only
655    # reuse for the same scheme, host and port
656    my $handle = delete $self->{handle};
657    if ( $handle ) {
658        unless ( $handle->can_reuse( $scheme, $host, $port, $peer ) ) {
659            $handle->close;
660            undef $handle;
661        }
662    }
663    $handle ||= $self->_open_handle( $request, $scheme, $host, $port, $peer );
664
665    $self->_prepare_headers_and_cb($request, $args, $url, $auth);
666    $handle->write_request($request);
667
668    my $response;
669    do { $response = $handle->read_response_header }
670        until (substr($response->{status},0,1) ne '1');
671
672    $self->_update_cookie_jar( $url, $response ) if $self->{cookie_jar};
673    my @redir_args = $self->_maybe_redirect($request, $response, $args);
674
675    my $known_message_length;
676    if ($method eq 'HEAD' || $response->{status} =~ /^[23]04/) {
677        # response has no message body
678        $known_message_length = 1;
679    }
680    else {
681        # Ignore any data callbacks during redirection.
682        my $cb_args = @redir_args ? +{} : $args;
683        my $data_cb = $self->_prepare_data_cb($response, $cb_args);
684        $known_message_length = $handle->read_body($data_cb, $response);
685    }
686
687    if ( $self->{keep_alive}
688        && $handle->connected
689        && $known_message_length
690        && $response->{protocol} eq 'HTTP/1.1'
691        && ($response->{headers}{connection} || '') ne 'close'
692    ) {
693        $self->{handle} = $handle;
694    }
695    else {
696        $handle->close;
697    }
698
699    $response->{success} = substr( $response->{status}, 0, 1 ) eq '2';
700    $response->{url} = $url;
701
702    # Push the current response onto the stack of redirects if redirecting.
703    if (@redir_args) {
704        push @{$args->{_redirects}}, $response;
705        return $self->_request(@redir_args, $args);
706    }
707
708    # Copy the stack of redirects into the response before returning.
709    $response->{redirects} = delete $args->{_redirects}
710      if @{$args->{_redirects}};
711    return $response;
712}
713
714sub _open_handle {
715    my ($self, $request, $scheme, $host, $port, $peer) = @_;
716
717    my $handle  = HTTP::Tiny::Handle->new(
718        timeout         => $self->{timeout},
719        SSL_options     => $self->{SSL_options},
720        verify_SSL      => $self->{verify_SSL},
721        local_address   => $self->{local_address},
722        keep_alive      => $self->{keep_alive}
723    );
724
725    if ($self->{_has_proxy}{$scheme} && ! grep { $host =~ /\Q$_\E$/ } @{$self->{no_proxy}}) {
726        return $self->_proxy_connect( $request, $handle );
727    }
728    else {
729        return $handle->connect($scheme, $host, $port, $peer);
730    }
731}
732
733sub _proxy_connect {
734    my ($self, $request, $handle) = @_;
735
736    my @proxy_vars;
737    if ( $request->{scheme} eq 'https' ) {
738        _croak(qq{No https_proxy defined}) unless $self->{https_proxy};
739        @proxy_vars = $self->_split_proxy( https_proxy => $self->{https_proxy} );
740        if ( $proxy_vars[0] eq 'https' ) {
741            _croak(qq{Can't proxy https over https: $request->{uri} via $self->{https_proxy}});
742        }
743    }
744    else {
745        _croak(qq{No http_proxy defined}) unless $self->{http_proxy};
746        @proxy_vars = $self->_split_proxy( http_proxy => $self->{http_proxy} );
747    }
748
749    my ($p_scheme, $p_host, $p_port, $p_auth) = @proxy_vars;
750
751    if ( length $p_auth && ! defined $request->{headers}{'proxy-authorization'} ) {
752        $self->_add_basic_auth_header( $request, 'proxy-authorization' => $p_auth );
753    }
754
755    $handle->connect($p_scheme, $p_host, $p_port, $p_host);
756
757    if ($request->{scheme} eq 'https') {
758        $self->_create_proxy_tunnel( $request, $handle );
759    }
760    else {
761        # non-tunneled proxy requires absolute URI
762        $request->{uri} = "$request->{scheme}://$request->{host_port}$request->{uri}";
763    }
764
765    return $handle;
766}
767
768sub _split_proxy {
769    my ($self, $type, $proxy) = @_;
770
771    my ($scheme, $host, $port, $path_query, $auth) = eval { $self->_split_url($proxy) };
772
773    unless(
774        defined($scheme) && length($scheme) && length($host) && length($port)
775        && $path_query eq '/'
776    ) {
777        _croak(qq{$type URL must be in format http[s]://[auth@]<host>:<port>/\n});
778    }
779
780    return ($scheme, $host, $port, $auth);
781}
782
783sub _create_proxy_tunnel {
784    my ($self, $request, $handle) = @_;
785
786    $handle->_assert_ssl;
787
788    my $agent = exists($request->{headers}{'user-agent'})
789        ? $request->{headers}{'user-agent'} : $self->{agent};
790
791    my $connect_request = {
792        method    => 'CONNECT',
793        uri       => "$request->{host}:$request->{port}",
794        headers   => {
795            host => "$request->{host}:$request->{port}",
796            'user-agent' => $agent,
797        }
798    };
799
800    if ( $request->{headers}{'proxy-authorization'} ) {
801        $connect_request->{headers}{'proxy-authorization'} =
802            delete $request->{headers}{'proxy-authorization'};
803    }
804
805    $handle->write_request($connect_request);
806    my $response;
807    do { $response = $handle->read_response_header }
808        until (substr($response->{status},0,1) ne '1');
809
810    # if CONNECT failed, throw the response so it will be
811    # returned from the original request() method;
812    unless (substr($response->{status},0,1) eq '2') {
813        die $response;
814    }
815
816    # tunnel established, so start SSL handshake
817    $handle->start_ssl( $request->{host} );
818
819    return;
820}
821
822sub _prepare_headers_and_cb {
823    my ($self, $request, $args, $url, $auth) = @_;
824
825    for ($self->{default_headers}, $args->{headers}) {
826        next unless defined;
827        while (my ($k, $v) = each %$_) {
828            $request->{headers}{lc $k} = $v;
829            $request->{header_case}{lc $k} = $k;
830        }
831    }
832
833    if (exists $request->{headers}{'host'}) {
834        die(qq/The 'Host' header must not be provided as header option\n/);
835    }
836
837    $request->{headers}{'host'}         = $request->{host_port};
838    $request->{headers}{'user-agent'} ||= $self->{agent};
839    $request->{headers}{'connection'}   = "close"
840        unless $self->{keep_alive};
841
842    # Some servers error on an empty-body PUT/POST without a content-length
843    if ( $request->{method} eq 'PUT' || $request->{method} eq 'POST' ) {
844        if (!defined($args->{content}) || !length($args->{content}) ) {
845            $request->{headers}{'content-length'} = 0;
846        }
847    }
848
849    if ( defined $args->{content} ) {
850        if ( ref $args->{content} eq 'CODE' ) {
851            if ( exists $request->{'content-length'} && $request->{'content-length'} == 0 ) {
852                $request->{cb} = sub { "" };
853            }
854            else {
855                $request->{headers}{'content-type'} ||= "application/octet-stream";
856                $request->{headers}{'transfer-encoding'} = 'chunked'
857                  unless exists $request->{headers}{'content-length'}
858                  || $request->{headers}{'transfer-encoding'};
859                $request->{cb} = $args->{content};
860            }
861        }
862        elsif ( length $args->{content} ) {
863            my $content = $args->{content};
864            if ( $] ge '5.008' ) {
865                utf8::downgrade($content, 1)
866                    or die(qq/Wide character in request message body\n/);
867            }
868            $request->{headers}{'content-type'} ||= "application/octet-stream";
869            $request->{headers}{'content-length'} = length $content
870              unless $request->{headers}{'content-length'}
871                  || $request->{headers}{'transfer-encoding'};
872            $request->{cb} = sub { substr $content, 0, length $content, '' };
873        }
874        $request->{trailer_cb} = $args->{trailer_callback}
875            if ref $args->{trailer_callback} eq 'CODE';
876    }
877
878    ### If we have a cookie jar, then maybe add relevant cookies
879    if ( $self->{cookie_jar} ) {
880        my $cookies = $self->cookie_jar->cookie_header( $url );
881        $request->{headers}{cookie} = $cookies if length $cookies;
882    }
883
884    # if we have Basic auth parameters, add them
885    if ( length $auth && ! defined $request->{headers}{authorization} ) {
886        $self->_add_basic_auth_header( $request, 'authorization' => $auth );
887    }
888
889    return;
890}
891
892sub _add_basic_auth_header {
893    my ($self, $request, $header, $auth) = @_;
894    require MIME::Base64;
895    $request->{headers}{$header} =
896        "Basic " . MIME::Base64::encode_base64($auth, "");
897    return;
898}
899
900sub _prepare_data_cb {
901    my ($self, $response, $args) = @_;
902    my $data_cb = $args->{data_callback};
903    $response->{content} = '';
904
905    if (!$data_cb || $response->{status} !~ /^2/) {
906        if (defined $self->{max_size}) {
907            $data_cb = sub {
908                $_[1]->{content} .= $_[0];
909                die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/)
910                  if length $_[1]->{content} > $self->{max_size};
911            };
912        }
913        else {
914            $data_cb = sub { $_[1]->{content} .= $_[0] };
915        }
916    }
917    return $data_cb;
918}
919
920sub _update_cookie_jar {
921    my ($self, $url, $response) = @_;
922
923    my $cookies = $response->{headers}->{'set-cookie'};
924    return unless defined $cookies;
925
926    my @cookies = ref $cookies ? @$cookies : $cookies;
927
928    $self->cookie_jar->add( $url, $_ ) for @cookies;
929
930    return;
931}
932
933sub _validate_cookie_jar {
934    my ($class, $jar) = @_;
935
936    # duck typing
937    for my $method ( qw/add cookie_header/ ) {
938        _croak(qq/Cookie jar must provide the '$method' method\n/)
939            unless ref($jar) && ref($jar)->can($method);
940    }
941
942    return;
943}
944
945sub _maybe_redirect {
946    my ($self, $request, $response, $args) = @_;
947    my $headers = $response->{headers};
948    my ($status, $method) = ($response->{status}, $request->{method});
949    $args->{_redirects} ||= [];
950
951    if (($status eq '303' or ($status =~ /^30[1278]/ && $method =~ /^GET|HEAD$/))
952        and $headers->{location}
953        and @{$args->{_redirects}} < $self->{max_redirect}
954    ) {
955        my $location = ($headers->{location} =~ /^\//)
956            ? "$request->{scheme}://$request->{host_port}$headers->{location}"
957            : $headers->{location} ;
958        return (($status eq '303' ? 'GET' : $method), $location);
959    }
960    return;
961}
962
963sub _split_url {
964    my $url = pop;
965
966    # URI regex adapted from the URI module
967    my ($scheme, $host, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
968      or die(qq/Cannot parse URL: '$url'\n/);
969
970    $scheme     = lc $scheme;
971    $path_query = "/$path_query" unless $path_query =~ m<\A/>;
972
973    my $auth = '';
974    if ( (my $i = index $host, '@') != -1 ) {
975        # user:pass@host
976        $auth = substr $host, 0, $i, ''; # take up to the @ for auth
977        substr $host, 0, 1, '';          # knock the @ off the host
978
979        # userinfo might be percent escaped, so recover real auth info
980        $auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
981    }
982    my $port = $host =~ s/:(\d*)\z// && length $1 ? $1
983             : $scheme eq 'http'                  ? 80
984             : $scheme eq 'https'                 ? 443
985             : undef;
986
987    return ($scheme, (length $host ? lc $host : "localhost") , $port, $path_query, $auth);
988}
989
990# Date conversions adapted from HTTP::Date
991my $DoW = "Sun|Mon|Tue|Wed|Thu|Fri|Sat";
992my $MoY = "Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec";
993sub _http_date {
994    my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($_[1]);
995    return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
996        substr($DoW,$wday*4,3),
997        $mday, substr($MoY,$mon*4,3), $year+1900,
998        $hour, $min, $sec
999    );
1000}
1001
1002sub _parse_http_date {
1003    my ($self, $str) = @_;
1004    require Time::Local;
1005    my @tl_parts;
1006    if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) {
1007        @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
1008    }
1009    elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) {
1010        @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
1011    }
1012    elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) {
1013        @tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6);
1014    }
1015    return eval {
1016        my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1;
1017        $t < 0 ? undef : $t;
1018    };
1019}
1020
1021# URI escaping adapted from URI::Escape
1022# c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1
1023# perl 5.6 ready UTF-8 encoding adapted from JSON::PP
1024my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
1025$escapes{' '}="+";
1026my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/;
1027
1028sub _uri_escape {
1029    my ($self, $str) = @_;
1030    return "" if !defined $str;
1031    if ( $] ge '5.008' ) {
1032        utf8::encode($str);
1033    }
1034    else {
1035        $str = pack("U*", unpack("C*", $str)) # UTF-8 encode a byte string
1036            if ( length $str == do { use bytes; length $str } );
1037        $str = pack("C*", unpack("C*", $str)); # clear UTF-8 flag
1038    }
1039    $str =~ s/($unsafe_char)/$escapes{$1}/g;
1040    return $str;
1041}
1042
1043package
1044    HTTP::Tiny::Handle; # hide from PAUSE/indexers
1045use strict;
1046use warnings;
1047
1048use Errno      qw[EINTR EPIPE];
1049use IO::Socket qw[SOCK_STREAM];
1050use Socket     qw[SOL_SOCKET SO_KEEPALIVE];
1051
1052# PERL_HTTP_TINY_IPV4_ONLY is a private environment variable to force old
1053# behavior if someone is unable to boostrap CPAN from a new perl install; it is
1054# not intended for general, per-client use and may be removed in the future
1055my $SOCKET_CLASS =
1056    $ENV{PERL_HTTP_TINY_IPV4_ONLY} ? 'IO::Socket::INET' :
1057    eval { require IO::Socket::IP; IO::Socket::IP->VERSION(0.32) } ? 'IO::Socket::IP' :
1058    'IO::Socket::INET';
1059
1060sub BUFSIZE () { 32768 } ## no critic
1061
1062my $Printable = sub {
1063    local $_ = shift;
1064    s/\r/\\r/g;
1065    s/\n/\\n/g;
1066    s/\t/\\t/g;
1067    s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
1068    $_;
1069};
1070
1071my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
1072my $Field_Content = qr/[[:print:]]+ (?: [\x20\x09]+ [[:print:]]+ )*/x;
1073
1074sub new {
1075    my ($class, %args) = @_;
1076    return bless {
1077        rbuf             => '',
1078        timeout          => 60,
1079        max_line_size    => 16384,
1080        max_header_lines => 64,
1081        verify_SSL       => HTTP::Tiny::_verify_SSL_default(),
1082        SSL_options      => {},
1083        %args
1084    }, $class;
1085}
1086
1087sub timeout {
1088    my ($self, $timeout) = @_;
1089    if ( @_ > 1 ) {
1090        $self->{timeout} = $timeout;
1091        if ( $self->{fh} && $self->{fh}->can('timeout') ) {
1092            $self->{fh}->timeout($timeout);
1093        }
1094    }
1095    return $self->{timeout};
1096}
1097
1098sub connect {
1099    @_ == 5 || die(q/Usage: $handle->connect(scheme, host, port, peer)/ . "\n");
1100    my ($self, $scheme, $host, $port, $peer) = @_;
1101
1102    if ( $scheme eq 'https' ) {
1103        $self->_assert_ssl;
1104    }
1105
1106    $self->{fh} = $SOCKET_CLASS->new(
1107        PeerHost  => $peer,
1108        PeerPort  => $port,
1109        $self->{local_address} ?
1110            ( LocalAddr => $self->{local_address} ) : (),
1111        Proto     => 'tcp',
1112        Type      => SOCK_STREAM,
1113        Timeout   => $self->{timeout},
1114    ) or die(qq/Could not connect to '$host:$port': $@\n/);
1115
1116    binmode($self->{fh})
1117      or die(qq/Could not binmode() socket: '$!'\n/);
1118
1119    if ( $self->{keep_alive} ) {
1120        unless ( defined( $self->{fh}->setsockopt( SOL_SOCKET, SO_KEEPALIVE, 1 ) ) ) {
1121            CORE::close($self->{fh});
1122            die(qq/Could not set SO_KEEPALIVE on socket: '$!'\n/);
1123        }
1124    }
1125
1126    $self->start_ssl($host) if $scheme eq 'https';
1127
1128    $self->{scheme} = $scheme;
1129    $self->{host} = $host;
1130    $self->{peer} = $peer;
1131    $self->{port} = $port;
1132    $self->{pid} = $$;
1133    $self->{tid} = _get_tid();
1134
1135    return $self;
1136}
1137
1138sub connected {
1139    my ($self) = @_;
1140    if ( $self->{fh} && $self->{fh}->connected ) {
1141        return wantarray
1142          ? ( $self->{fh}->peerhost, $self->{fh}->peerport )
1143          : join( ':', $self->{fh}->peerhost, $self->{fh}->peerport );
1144    }
1145    return;
1146}
1147
1148sub start_ssl {
1149    my ($self, $host) = @_;
1150
1151    # As this might be used via CONNECT after an SSL session
1152    # to a proxy, we shut down any existing SSL before attempting
1153    # the handshake
1154    if ( ref($self->{fh}) eq 'IO::Socket::SSL' ) {
1155        unless ( $self->{fh}->stop_SSL ) {
1156            my $ssl_err = IO::Socket::SSL->errstr;
1157            die(qq/Error halting prior SSL connection: $ssl_err/);
1158        }
1159    }
1160
1161    my $ssl_args = $self->_ssl_args($host);
1162    IO::Socket::SSL->start_SSL(
1163        $self->{fh},
1164        %$ssl_args,
1165        SSL_create_ctx_callback => sub {
1166            my $ctx = shift;
1167            Net::SSLeay::CTX_set_mode($ctx, Net::SSLeay::MODE_AUTO_RETRY());
1168        },
1169    );
1170
1171    unless ( ref($self->{fh}) eq 'IO::Socket::SSL' ) {
1172        my $ssl_err = IO::Socket::SSL->errstr;
1173        die(qq/SSL connection failed for $host: $ssl_err\n/);
1174    }
1175}
1176
1177sub close {
1178    @_ == 1 || die(q/Usage: $handle->close()/ . "\n");
1179    my ($self) = @_;
1180    CORE::close($self->{fh})
1181      or die(qq/Could not close socket: '$!'\n/);
1182}
1183
1184sub write {
1185    @_ == 2 || die(q/Usage: $handle->write(buf)/ . "\n");
1186    my ($self, $buf) = @_;
1187
1188    if ( $] ge '5.008' ) {
1189        utf8::downgrade($buf, 1)
1190            or die(qq/Wide character in write()\n/);
1191    }
1192
1193    my $len = length $buf;
1194    my $off = 0;
1195
1196    local $SIG{PIPE} = 'IGNORE';
1197
1198    while () {
1199        $self->can_write
1200          or die(qq/Timed out while waiting for socket to become ready for writing\n/);
1201        my $r = syswrite($self->{fh}, $buf, $len, $off);
1202        if (defined $r) {
1203            $len -= $r;
1204            $off += $r;
1205            last unless $len > 0;
1206        }
1207        elsif ($! == EPIPE) {
1208            die(qq/Socket closed by remote server: $!\n/);
1209        }
1210        elsif ($! != EINTR) {
1211            if ($self->{fh}->can('errstr')){
1212                my $err = $self->{fh}->errstr();
1213                die (qq/Could not write to SSL socket: '$err'\n /);
1214            }
1215            else {
1216                die(qq/Could not write to socket: '$!'\n/);
1217            }
1218
1219        }
1220    }
1221    return $off;
1222}
1223
1224sub read {
1225    @_ == 2 || @_ == 3 || die(q/Usage: $handle->read(len [, allow_partial])/ . "\n");
1226    my ($self, $len, $allow_partial) = @_;
1227
1228    my $buf  = '';
1229    my $got = length $self->{rbuf};
1230
1231    if ($got) {
1232        my $take = ($got < $len) ? $got : $len;
1233        $buf  = substr($self->{rbuf}, 0, $take, '');
1234        $len -= $take;
1235    }
1236
1237    # Ignore SIGPIPE because SSL reads can result in writes that might error.
1238    # See "Expecting exactly the same behavior as plain sockets" in
1239    # https://metacpan.org/dist/IO-Socket-SSL/view/lib/IO/Socket/SSL.pod#Common-Usage-Errors
1240    local $SIG{PIPE} = 'IGNORE';
1241
1242    while ($len > 0) {
1243        $self->can_read
1244          or die(q/Timed out while waiting for socket to become ready for reading/ . "\n");
1245        my $r = sysread($self->{fh}, $buf, $len, length $buf);
1246        if (defined $r) {
1247            last unless $r;
1248            $len -= $r;
1249        }
1250        elsif ($! != EINTR) {
1251            if ($self->{fh}->can('errstr')){
1252                my $err = $self->{fh}->errstr();
1253                die (qq/Could not read from SSL socket: '$err'\n /);
1254            }
1255            else {
1256                die(qq/Could not read from socket: '$!'\n/);
1257            }
1258        }
1259    }
1260    if ($len && !$allow_partial) {
1261        die(qq/Unexpected end of stream\n/);
1262    }
1263    return $buf;
1264}
1265
1266sub readline {
1267    @_ == 1 || die(q/Usage: $handle->readline()/ . "\n");
1268    my ($self) = @_;
1269
1270    while () {
1271        if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
1272            return $1;
1273        }
1274        if (length $self->{rbuf} >= $self->{max_line_size}) {
1275            die(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}\n/);
1276        }
1277        $self->can_read
1278          or die(qq/Timed out while waiting for socket to become ready for reading\n/);
1279        my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
1280        if (defined $r) {
1281            last unless $r;
1282        }
1283        elsif ($! != EINTR) {
1284            if ($self->{fh}->can('errstr')){
1285                my $err = $self->{fh}->errstr();
1286                die (qq/Could not read from SSL socket: '$err'\n /);
1287            }
1288            else {
1289                die(qq/Could not read from socket: '$!'\n/);
1290            }
1291        }
1292    }
1293    die(qq/Unexpected end of stream while looking for line\n/);
1294}
1295
1296sub read_header_lines {
1297    @_ == 1 || @_ == 2 || die(q/Usage: $handle->read_header_lines([headers])/ . "\n");
1298    my ($self, $headers) = @_;
1299    $headers ||= {};
1300    my $lines   = 0;
1301    my $val;
1302
1303    while () {
1304         my $line = $self->readline;
1305
1306         if (++$lines >= $self->{max_header_lines}) {
1307             die(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}\n/);
1308         }
1309         elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
1310             my ($field_name) = lc $1;
1311             if (exists $headers->{$field_name}) {
1312                 for ($headers->{$field_name}) {
1313                     $_ = [$_] unless ref $_ eq "ARRAY";
1314                     push @$_, $2;
1315                     $val = \$_->[-1];
1316                 }
1317             }
1318             else {
1319                 $val = \($headers->{$field_name} = $2);
1320             }
1321         }
1322         elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
1323             $val
1324               or die(qq/Unexpected header continuation line\n/);
1325             next unless length $1;
1326             $$val .= ' ' if length $$val;
1327             $$val .= $1;
1328         }
1329         elsif ($line =~ /\A \x0D?\x0A \z/x) {
1330            last;
1331         }
1332         else {
1333            die(q/Malformed header line: / . $Printable->($line) . "\n");
1334         }
1335    }
1336    return $headers;
1337}
1338
1339sub write_request {
1340    @_ == 2 || die(q/Usage: $handle->write_request(request)/ . "\n");
1341    my($self, $request) = @_;
1342    $self->write_request_header(@{$request}{qw/method uri headers header_case/});
1343    $self->write_body($request) if $request->{cb};
1344    return;
1345}
1346
1347# Standard request header names/case from HTTP/1.1 RFCs
1348my @rfc_request_headers = qw(
1349  Accept Accept-Charset Accept-Encoding Accept-Language Authorization
1350  Cache-Control Connection Content-Length Expect From Host
1351  If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since
1352  Max-Forwards Pragma Proxy-Authorization Range Referer TE Trailer
1353  Transfer-Encoding Upgrade User-Agent Via
1354);
1355
1356my @other_request_headers = qw(
1357  Content-Encoding Content-MD5 Content-Type Cookie DNT Date Origin
1358  X-XSS-Protection
1359);
1360
1361my %HeaderCase = map { lc($_) => $_ } @rfc_request_headers, @other_request_headers;
1362
1363# to avoid multiple small writes and hence nagle, you can pass the method line or anything else to
1364# combine writes.
1365sub write_header_lines {
1366    (@_ >= 2 && @_ <= 4 && ref $_[1] eq 'HASH') || die(q/Usage: $handle->write_header_lines(headers, [header_case, prefix])/ . "\n");
1367    my($self, $headers, $header_case, $prefix_data) = @_;
1368    $header_case ||= {};
1369
1370    my $buf = (defined $prefix_data ? $prefix_data : '');
1371
1372    # Per RFC, control fields should be listed first
1373    my %seen;
1374    for my $k ( qw/host cache-control expect max-forwards pragma range te/ ) {
1375        next unless exists $headers->{$k};
1376        $seen{$k}++;
1377        my $field_name = $HeaderCase{$k};
1378        my $v = $headers->{$k};
1379        for (ref $v eq 'ARRAY' ? @$v : $v) {
1380            $_ = '' unless defined $_;
1381            $buf .= "$field_name: $_\x0D\x0A";
1382        }
1383    }
1384
1385    # Other headers sent in arbitrary order
1386    while (my ($k, $v) = each %$headers) {
1387        my $field_name = lc $k;
1388        next if $seen{$field_name};
1389        if (exists $HeaderCase{$field_name}) {
1390            $field_name = $HeaderCase{$field_name};
1391        }
1392        else {
1393            if (exists $header_case->{$field_name}) {
1394                $field_name = $header_case->{$field_name};
1395            }
1396            else {
1397                $field_name =~ s/\b(\w)/\u$1/g;
1398            }
1399            $field_name =~ /\A $Token+ \z/xo
1400              or die(q/Invalid HTTP header field name: / . $Printable->($field_name) . "\n");
1401            $HeaderCase{lc $field_name} = $field_name;
1402        }
1403        for (ref $v eq 'ARRAY' ? @$v : $v) {
1404            # unwrap a field value if pre-wrapped by user
1405            s/\x0D?\x0A\s+/ /g;
1406            die(qq/Invalid HTTP header field value ($field_name): / . $Printable->($_). "\n")
1407              unless $_ eq '' || /\A $Field_Content \z/xo;
1408            $_ = '' unless defined $_;
1409            $buf .= "$field_name: $_\x0D\x0A";
1410        }
1411    }
1412    $buf .= "\x0D\x0A";
1413    return $self->write($buf);
1414}
1415
1416# return value indicates whether message length was defined; this is generally
1417# true unless there was no content-length header and we just read until EOF.
1418# Other message length errors are thrown as exceptions
1419sub read_body {
1420    @_ == 3 || die(q/Usage: $handle->read_body(callback, response)/ . "\n");
1421    my ($self, $cb, $response) = @_;
1422    my $te = $response->{headers}{'transfer-encoding'} || '';
1423    my $chunked = grep { /chunked/i } ( ref $te eq 'ARRAY' ? @$te : $te ) ;
1424    return $chunked
1425        ? $self->read_chunked_body($cb, $response)
1426        : $self->read_content_body($cb, $response);
1427}
1428
1429sub write_body {
1430    @_ == 2 || die(q/Usage: $handle->write_body(request)/ . "\n");
1431    my ($self, $request) = @_;
1432    if (exists $request->{headers}{'content-length'}) {
1433        return unless $request->{headers}{'content-length'};
1434        return $self->write_content_body($request);
1435    }
1436    else {
1437        return $self->write_chunked_body($request);
1438    }
1439}
1440
1441sub read_content_body {
1442    @_ == 3 || @_ == 4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ . "\n");
1443    my ($self, $cb, $response, $content_length) = @_;
1444    $content_length ||= $response->{headers}{'content-length'};
1445
1446    if ( defined $content_length ) {
1447        my $len = $content_length;
1448        while ($len > 0) {
1449            my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
1450            $cb->($self->read($read, 0), $response);
1451            $len -= $read;
1452        }
1453        return length($self->{rbuf}) == 0;
1454    }
1455
1456    my $chunk;
1457    $cb->($chunk, $response) while length( $chunk = $self->read(BUFSIZE, 1) );
1458
1459    return;
1460}
1461
1462sub write_content_body {
1463    @_ == 2 || die(q/Usage: $handle->write_content_body(request)/ . "\n");
1464    my ($self, $request) = @_;
1465
1466    my ($len, $content_length) = (0, $request->{headers}{'content-length'});
1467    while () {
1468        my $data = $request->{cb}->();
1469
1470        defined $data && length $data
1471          or last;
1472
1473        if ( $] ge '5.008' ) {
1474            utf8::downgrade($data, 1)
1475                or die(qq/Wide character in write_content()\n/);
1476        }
1477
1478        $len += $self->write($data);
1479    }
1480
1481    $len == $content_length
1482      or die(qq/Content-Length mismatch (got: $len expected: $content_length)\n/);
1483
1484    return $len;
1485}
1486
1487sub read_chunked_body {
1488    @_ == 3 || die(q/Usage: $handle->read_chunked_body(callback, $response)/ . "\n");
1489    my ($self, $cb, $response) = @_;
1490
1491    while () {
1492        my $head = $self->readline;
1493
1494        $head =~ /\A ([A-Fa-f0-9]+)/x
1495          or die(q/Malformed chunk head: / . $Printable->($head) . "\n");
1496
1497        my $len = hex($1)
1498          or last;
1499
1500        $self->read_content_body($cb, $response, $len);
1501
1502        $self->read(2) eq "\x0D\x0A"
1503          or die(qq/Malformed chunk: missing CRLF after chunk data\n/);
1504    }
1505    $self->read_header_lines($response->{headers});
1506    return 1;
1507}
1508
1509sub write_chunked_body {
1510    @_ == 2 || die(q/Usage: $handle->write_chunked_body(request)/ . "\n");
1511    my ($self, $request) = @_;
1512
1513    my $len = 0;
1514    while () {
1515        my $data = $request->{cb}->();
1516
1517        defined $data && length $data
1518          or last;
1519
1520        if ( $] ge '5.008' ) {
1521            utf8::downgrade($data, 1)
1522                or die(qq/Wide character in write_chunked_body()\n/);
1523        }
1524
1525        $len += length $data;
1526
1527        my $chunk  = sprintf '%X', length $data;
1528           $chunk .= "\x0D\x0A";
1529           $chunk .= $data;
1530           $chunk .= "\x0D\x0A";
1531
1532        $self->write($chunk);
1533    }
1534    $self->write("0\x0D\x0A");
1535    if ( ref $request->{trailer_cb} eq 'CODE' ) {
1536        $self->write_header_lines($request->{trailer_cb}->())
1537    }
1538    else {
1539        $self->write("\x0D\x0A");
1540    }
1541    return $len;
1542}
1543
1544sub read_response_header {
1545    @_ == 1 || die(q/Usage: $handle->read_response_header()/ . "\n");
1546    my ($self) = @_;
1547
1548    my $line = $self->readline;
1549
1550    $line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) (?: [\x09\x20]+ ([^\x0D\x0A]*) )? \x0D?\x0A/x
1551      or die(q/Malformed Status-Line: / . $Printable->($line). "\n");
1552
1553    my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
1554    $reason = "" unless defined $reason;
1555
1556    die (qq/Unsupported HTTP protocol: $protocol\n/)
1557        unless $version =~ /0*1\.0*[01]/;
1558
1559    return {
1560        status       => $status,
1561        reason       => $reason,
1562        headers      => $self->read_header_lines,
1563        protocol     => $protocol,
1564    };
1565}
1566
1567sub write_request_header {
1568    @_ == 5 || die(q/Usage: $handle->write_request_header(method, request_uri, headers, header_case)/ . "\n");
1569    my ($self, $method, $request_uri, $headers, $header_case) = @_;
1570
1571    return $self->write_header_lines($headers, $header_case, "$method $request_uri HTTP/1.1\x0D\x0A");
1572}
1573
1574sub _do_timeout {
1575    my ($self, $type, $timeout) = @_;
1576    $timeout = $self->{timeout}
1577        unless defined $timeout && $timeout >= 0;
1578
1579    my $fd = fileno $self->{fh};
1580    defined $fd && $fd >= 0
1581      or die(qq/select(2): 'Bad file descriptor'\n/);
1582
1583    my $initial = time;
1584    my $pending = $timeout;
1585    my $nfound;
1586
1587    vec(my $fdset = '', $fd, 1) = 1;
1588
1589    while () {
1590        $nfound = ($type eq 'read')
1591            ? select($fdset, undef, undef, $pending)
1592            : select(undef, $fdset, undef, $pending) ;
1593        if ($nfound == -1) {
1594            $! == EINTR
1595              or die(qq/select(2): '$!'\n/);
1596            redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
1597            $nfound = 0;
1598        }
1599        last;
1600    }
1601    $! = 0;
1602    return $nfound;
1603}
1604
1605sub can_read {
1606    @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_read([timeout])/ . "\n");
1607    my $self = shift;
1608    if ( ref($self->{fh}) eq 'IO::Socket::SSL' ) {
1609        return 1 if $self->{fh}->pending;
1610    }
1611    return $self->_do_timeout('read', @_)
1612}
1613
1614sub can_write {
1615    @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_write([timeout])/ . "\n");
1616    my $self = shift;
1617    return $self->_do_timeout('write', @_)
1618}
1619
1620sub _assert_ssl {
1621    my($ok, $reason) = HTTP::Tiny->can_ssl();
1622    die $reason unless $ok;
1623}
1624
1625sub can_reuse {
1626    my ($self,$scheme,$host,$port,$peer) = @_;
1627    return 0 if
1628        $self->{pid} != $$
1629        || $self->{tid} != _get_tid()
1630        || length($self->{rbuf})
1631        || $scheme ne $self->{scheme}
1632        || $host ne $self->{host}
1633        || $port ne $self->{port}
1634        || $peer ne $self->{peer}
1635        || eval { $self->can_read(0) }
1636        || $@ ;
1637        return 1;
1638}
1639
1640# Try to find a CA bundle to validate the SSL cert,
1641# prefer Mozilla::CA or fallback to a system file
1642sub _find_CA_file {
1643    my $self = shift();
1644
1645    my $ca_file =
1646      defined( $self->{SSL_options}->{SSL_ca_file} )
1647      ? $self->{SSL_options}->{SSL_ca_file}
1648      : $ENV{SSL_CERT_FILE};
1649
1650    if ( defined $ca_file ) {
1651        unless ( -r $ca_file ) {
1652            die qq/SSL_ca_file '$ca_file' not found or not readable\n/;
1653        }
1654        return $ca_file;
1655    }
1656
1657    local @INC = @INC;
1658    pop @INC if $INC[-1] eq '.';
1659    return Mozilla::CA::SSL_ca_file()
1660        if eval { require Mozilla::CA; 1 };
1661
1662    # cert list copied from golang src/crypto/x509/root_unix.go
1663    foreach my $ca_bundle (
1664        "/etc/ssl/certs/ca-certificates.crt",     # Debian/Ubuntu/Gentoo etc.
1665        "/etc/pki/tls/certs/ca-bundle.crt",       # Fedora/RHEL
1666        "/etc/ssl/ca-bundle.pem",                 # OpenSUSE
1667        "/etc/openssl/certs/ca-certificates.crt", # NetBSD
1668        "/etc/ssl/cert.pem",                      # OpenBSD
1669        "/usr/local/share/certs/ca-root-nss.crt", # FreeBSD/DragonFly
1670        "/etc/pki/tls/cacert.pem",                # OpenELEC
1671        "/etc/certs/ca-certificates.crt",         # Solaris 11.2+
1672    ) {
1673        return $ca_bundle if -e $ca_bundle;
1674    }
1675
1676    die qq/Couldn't find a CA bundle with which to verify the SSL certificate.\n/
1677      . qq/Try installing Mozilla::CA from CPAN\n/;
1678}
1679
1680# for thread safety, we need to know thread id if threads are loaded
1681sub _get_tid {
1682    no warnings 'reserved'; # for 'threads'
1683    return threads->can("tid") ? threads->tid : 0;
1684}
1685
1686sub _ssl_args {
1687    my ($self, $host) = @_;
1688
1689    my %ssl_args;
1690
1691    # This test reimplements IO::Socket::SSL::can_client_sni(), which wasn't
1692    # added until IO::Socket::SSL 1.84
1693    if ( Net::SSLeay::OPENSSL_VERSION_NUMBER() >= 0x01000000 ) {
1694        $ssl_args{SSL_hostname} = $host,          # Sane SNI support
1695    }
1696
1697    if ($self->{verify_SSL}) {
1698        $ssl_args{SSL_verifycn_scheme}  = 'http'; # enable CN validation
1699        $ssl_args{SSL_verifycn_name}    = $host;  # set validation hostname
1700        $ssl_args{SSL_verify_mode}      = 0x01;   # enable cert validation
1701        $ssl_args{SSL_ca_file}          = $self->_find_CA_file;
1702    }
1703    else {
1704        $ssl_args{SSL_verifycn_scheme}  = 'none'; # disable CN validation
1705        $ssl_args{SSL_verify_mode}      = 0x00;   # disable cert validation
1706    }
1707
1708    # user options override settings from verify_SSL
1709    for my $k ( keys %{$self->{SSL_options}} ) {
1710        $ssl_args{$k} = $self->{SSL_options}{$k} if $k =~ m/^SSL_/;
1711    }
1712
1713    return \%ssl_args;
1714}
1715
17161;
1717
1718__END__
1719
1720=pod
1721
1722=encoding UTF-8
1723
1724=head1 NAME
1725
1726HTTP::Tiny - A small, simple, correct HTTP/1.1 client
1727
1728=head1 VERSION
1729
1730version 0.088
1731
1732=head1 SYNOPSIS
1733
1734    use HTTP::Tiny;
1735
1736    my $response = HTTP::Tiny->new->get('http://example.com/');
1737
1738    die "Failed!\n" unless $response->{success};
1739
1740    print "$response->{status} $response->{reason}\n";
1741
1742    while (my ($k, $v) = each %{$response->{headers}}) {
1743        for (ref $v eq 'ARRAY' ? @$v : $v) {
1744            print "$k: $_\n";
1745        }
1746    }
1747
1748    print $response->{content} if length $response->{content};
1749
1750=head1 DESCRIPTION
1751
1752This is a very simple HTTP/1.1 client, designed for doing simple
1753requests without the overhead of a large framework like L<LWP::UserAgent>.
1754
1755It is more correct and more complete than L<HTTP::Lite>.  It supports
1756proxies and redirection.  It also correctly resumes after EINTR.
1757
1758If L<IO::Socket::IP> 0.25 or later is installed, HTTP::Tiny will use it instead
1759of L<IO::Socket::INET> for transparent support for both IPv4 and IPv6.
1760
1761Cookie support requires L<HTTP::CookieJar> or an equivalent class.
1762
1763=head1 METHODS
1764
1765=head2 new
1766
1767    $http = HTTP::Tiny->new( %attributes );
1768
1769This constructor returns a new HTTP::Tiny object.  Valid attributes include:
1770
1771=over 4
1772
1773=item *
1774
1775C<agent> — A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If C<agent> — ends in a space character, the default user-agent string is appended.
1776
1777=item *
1778
1779C<cookie_jar> — An instance of L<HTTP::CookieJar> — or equivalent class that supports the C<add> and C<cookie_header> methods
1780
1781=item *
1782
1783C<default_headers> — A hashref of default headers to apply to requests
1784
1785=item *
1786
1787C<local_address> — The local IP address to bind to
1788
1789=item *
1790
1791C<keep_alive> — Whether to reuse the last connection (if for the same scheme, host and port) (defaults to 1)
1792
1793=item *
1794
1795C<max_redirect> — Maximum number of redirects allowed (defaults to 5)
1796
1797=item *
1798
1799C<max_size> — Maximum response size in bytes (only when not using a data callback).  If defined, requests with responses larger than this will return a 599 status code.
1800
1801=item *
1802
1803C<http_proxy> — URL of a proxy server to use for HTTP connections (default is C<$ENV{http_proxy}> — if set)
1804
1805=item *
1806
1807C<https_proxy> — URL of a proxy server to use for HTTPS connections (default is C<$ENV{https_proxy}> — if set)
1808
1809=item *
1810
1811C<proxy> — URL of a generic proxy server for both HTTP and HTTPS connections (default is C<$ENV{all_proxy}> — if set)
1812
1813=item *
1814
1815C<no_proxy> — List of domain suffixes that should not be proxied.  Must be a comma-separated string or an array reference. (default is C<$ENV{no_proxy}> —)
1816
1817=item *
1818
1819C<timeout> — Request timeout in seconds (default is 60) If a socket open, read or write takes longer than the timeout, the request response status code will be 599.
1820
1821=item *
1822
1823C<verify_SSL> — A boolean that indicates whether to validate the TLS/SSL certificate of an C<https> — connection (default is true). Changed from false to true in version 0.083.
1824
1825=item *
1826
1827C<SSL_options> — A hashref of C<SSL_*> — options to pass through to L<IO::Socket::SSL>
1828
1829=item *
1830
1831C<$ENV{PERL_HTTP_TINY_SSL_INSECURE_BY_DEFAULT}> - Changes the default certificate verification behavior to not check server identity if set to 1. Only effective if C<verify_SSL> is not set. Added in version 0.083.
1832
1833=back
1834
1835An accessor/mutator method exists for each attribute.
1836
1837Passing an explicit C<undef> for C<proxy>, C<http_proxy> or C<https_proxy> will
1838prevent getting the corresponding proxies from the environment.
1839
1840Errors during request execution will result in a pseudo-HTTP status code of 599
1841and a reason of "Internal Exception". The content field in the response will
1842contain the text of the error.
1843
1844The C<keep_alive> parameter enables a persistent connection, but only to a
1845single destination scheme, host and port.  If any connection-relevant
1846attributes are modified via accessor, or if the process ID or thread ID change,
1847the persistent connection will be dropped.  If you want persistent connections
1848across multiple destinations, use multiple HTTP::Tiny objects.
1849
1850See L</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes.
1851
1852=head2 get|head|put|post|patch|delete
1853
1854    $response = $http->get($url);
1855    $response = $http->get($url, \%options);
1856    $response = $http->head($url);
1857
1858These methods are shorthand for calling C<request()> for the given method.  The
1859URL must have unsafe characters escaped and international domain names encoded.
1860See C<request()> for valid options and a description of the response.
1861
1862The C<success> field of the response will be true if the status code is 2XX.
1863
1864=head2 post_form
1865
1866    $response = $http->post_form($url, $form_data);
1867    $response = $http->post_form($url, $form_data, \%options);
1868
1869This method executes a C<POST> request and sends the key/value pairs from a
1870form data hash or array reference to the given URL with a C<content-type> of
1871C<application/x-www-form-urlencoded>.  If data is provided as an array
1872reference, the order is preserved; if provided as a hash reference, the terms
1873are sorted on key and value for consistency.  See documentation for the
1874C<www_form_urlencode> method for details on the encoding.
1875
1876The URL must have unsafe characters escaped and international domain names
1877encoded.  See C<request()> for valid options and a description of the response.
1878Any C<content-type> header or content in the options hashref will be ignored.
1879
1880The C<success> field of the response will be true if the status code is 2XX.
1881
1882=head2 mirror
1883
1884    $response = $http->mirror($url, $file, \%options)
1885    if ( $response->{success} ) {
1886        print "$file is up to date\n";
1887    }
1888
1889Executes a C<GET> request for the URL and saves the response body to the file
1890name provided.  The URL must have unsafe characters escaped and international
1891domain names encoded.  If the file already exists, the request will include an
1892C<If-Modified-Since> header with the modification timestamp of the file.  You
1893may specify a different C<If-Modified-Since> header yourself in the C<<
1894$options->{headers} >> hash.
1895
1896The C<success> field of the response will be true if the status code is 2XX
1897or if the status code is 304 (unmodified).
1898
1899If the file was modified and the server response includes a properly
1900formatted C<Last-Modified> header, the file modification time will
1901be updated accordingly.
1902
1903=head2 request
1904
1905    $response = $http->request($method, $url);
1906    $response = $http->request($method, $url, \%options);
1907
1908Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST',
1909'PUT', etc.) on the given URL.  The URL must have unsafe characters escaped and
1910international domain names encoded.
1911
1912B<NOTE>: Method names are B<case-sensitive> per the HTTP/1.1 specification.
1913Don't use C<get> when you really want C<GET>.  See L<LIMITATIONS> for
1914how this applies to redirection.
1915
1916If the URL includes a "user:password" stanza, they will be used for Basic-style
1917authorization headers.  (Authorization headers will not be included in a
1918redirected request.) For example:
1919
1920    $http->request('GET', 'http://Aladdin:open sesame@example.com/');
1921
1922If the "user:password" stanza contains reserved characters, they must
1923be percent-escaped:
1924
1925    $http->request('GET', 'http://john%40example.com:password@example.com/');
1926
1927A hashref of options may be appended to modify the request.
1928
1929Valid options are:
1930
1931=over 4
1932
1933=item *
1934
1935C<headers> — A hashref containing headers to include with the request.  If the value for a header is an array reference, the header will be output multiple times with each value in the array.  These headers over-write any default headers.
1936
1937=item *
1938
1939C<content> — A scalar to include as the body of the request OR a code reference that will be called iteratively to produce the body of the request
1940
1941=item *
1942
1943C<trailer_callback> — A code reference that will be called if it exists to provide a hashref of trailing headers (only used with chunked transfer-encoding)
1944
1945=item *
1946
1947C<data_callback> — A code reference that will be called for each chunks of the response body received.
1948
1949=item *
1950
1951C<peer> — Override host resolution and force all connections to go only to a specific peer address, regardless of the URL of the request.  This will include any redirections!  This options should be used with extreme caution (e.g. debugging or very special circumstances). It can be given as either a scalar or a code reference that will receive the hostname and whose response will be taken as the address.
1952
1953=back
1954
1955The C<Host> header is generated from the URL in accordance with RFC 2616.  It
1956is a fatal error to specify C<Host> in the C<headers> option.  Other headers
1957may be ignored or overwritten if necessary for transport compliance.
1958
1959If the C<content> option is a code reference, it will be called iteratively
1960to provide the content body of the request.  It should return the empty
1961string or undef when the iterator is exhausted.
1962
1963If the C<content> option is the empty string, no C<content-type> or
1964C<content-length> headers will be generated.
1965
1966If the C<data_callback> option is provided, it will be called iteratively until
1967the entire response body is received.  The first argument will be a string
1968containing a chunk of the response body, the second argument will be the
1969in-progress response hash reference, as described below.  (This allows
1970customizing the action of the callback based on the C<status> or C<headers>
1971received prior to the content body.)
1972
1973Content data in the request/response is handled as "raw bytes".  Any
1974encoding/decoding (with associated headers) are the responsibility of the
1975caller.
1976
1977The C<request> method returns a hashref containing the response.  The hashref
1978will have the following keys:
1979
1980=over 4
1981
1982=item *
1983
1984C<success> — Boolean indicating whether the operation returned a 2XX status code
1985
1986=item *
1987
1988C<url> — URL that provided the response. This is the URL of the request unless there were redirections, in which case it is the last URL queried in a redirection chain
1989
1990=item *
1991
1992C<status> — The HTTP status code of the response
1993
1994=item *
1995
1996C<reason> — The response phrase returned by the server
1997
1998=item *
1999
2000C<content> — The body of the response.  If the response does not have any content or if a data callback is provided to consume the response body, this will be the empty string
2001
2002=item *
2003
2004C<headers> — A hashref of header fields.  All header field names will be normalized to be lower case. If a header is repeated, the value will be an arrayref; it will otherwise be a scalar string containing the value
2005
2006=item *
2007
2008C<protocol> - If this field exists, it is the protocol of the response such as HTTP/1.0 or HTTP/1.1
2009
2010=item *
2011
2012C<redirects> If this field exists, it is an arrayref of response hash references from redirects in the same order that redirections occurred.  If it does not exist, then no redirections occurred.
2013
2014=back
2015
2016On an error during the execution of the request, the C<status> field will
2017contain 599, and the C<content> field will contain the text of the error.
2018
2019=head2 www_form_urlencode
2020
2021    $params = $http->www_form_urlencode( $data );
2022    $response = $http->get("http://example.com/query?$params");
2023
2024This method converts the key/value pairs from a data hash or array reference
2025into a C<x-www-form-urlencoded> string.  The keys and values from the data
2026reference will be UTF-8 encoded and escaped per RFC 3986.  If a value is an
2027array reference, the key will be repeated with each of the values of the array
2028reference.  If data is provided as a hash reference, the key/value pairs in the
2029resulting string will be sorted by key and value for consistent ordering.
2030
2031=head2 can_ssl
2032
2033    $ok         = HTTP::Tiny->can_ssl;
2034    ($ok, $why) = HTTP::Tiny->can_ssl;
2035    ($ok, $why) = $http->can_ssl;
2036
2037Indicates if SSL support is available.  When called as a class object, it
2038checks for the correct version of L<Net::SSLeay> and L<IO::Socket::SSL>.
2039When called as an object methods, if C<SSL_verify> is true or if C<SSL_verify_mode>
2040is set in C<SSL_options>, it checks that a CA file is available.
2041
2042In scalar context, returns a boolean indicating if SSL is available.
2043In list context, returns the boolean and a (possibly multi-line) string of
2044errors indicating why SSL isn't available.
2045
2046=head2 connected
2047
2048    $host = $http->connected;
2049    ($host, $port) = $http->connected;
2050
2051Indicates if a connection to a peer is being kept alive, per the C<keep_alive>
2052option.
2053
2054In scalar context, returns the peer host and port, joined with a colon, or
2055C<undef> (if no peer is connected).
2056In list context, returns the peer host and port or an empty list (if no peer
2057is connected).
2058
2059B<Note>: This method cannot reliably be used to discover whether the remote
2060host has closed its end of the socket.
2061
2062=for Pod::Coverage SSL_options
2063agent
2064cookie_jar
2065default_headers
2066http_proxy
2067https_proxy
2068keep_alive
2069local_address
2070max_redirect
2071max_size
2072no_proxy
2073proxy
2074timeout
2075verify_SSL
2076
2077=head1 TLS/SSL SUPPORT
2078
2079Direct C<https> connections are supported only if L<IO::Socket::SSL> 1.56 or
2080greater and L<Net::SSLeay> 1.49 or greater are installed. An error will occur
2081if new enough versions of these modules are not installed or if the TLS
2082encryption fails. You can also use C<HTTP::Tiny::can_ssl()> utility function
2083that returns boolean to see if the required modules are installed.
2084
2085An C<https> connection may be made via an C<http> proxy that supports the CONNECT
2086command (i.e. RFC 2817).  You may not proxy C<https> via a proxy that itself
2087requires C<https> to communicate.
2088
2089TLS/SSL provides two distinct capabilities:
2090
2091=over 4
2092
2093=item *
2094
2095Encrypted communication channel
2096
2097=item *
2098
2099Verification of server identity
2100
2101=back
2102
2103B<By default, HTTP::Tiny verifies server identity>.
2104
2105This was changed in version 0.083 due to security concerns. The previous default
2106behavior can be enabled by setting C<$ENV{PERL_HTTP_TINY_SSL_INSECURE_BY_DEFAULT}>
2107to 1.
2108
2109Verification is done by checking that that the TLS/SSL connection has a valid
2110certificate corresponding to the host name of the connection and that the
2111certificate has been verified by a CA. Assuming you trust the CA, this will
2112protect against L<machine-in-the-middle
2113attacks|http://en.wikipedia.org/wiki/Machine-in-the-middle_attack>.
2114
2115Certificate verification requires a file containing trusted CA certificates.
2116
2117If the environment variable C<SSL_CERT_FILE> is present, HTTP::Tiny
2118will try to find a CA certificate file in that location.
2119
2120If the L<Mozilla::CA> module is installed, HTTP::Tiny will use the CA file
2121included with it as a source of trusted CA's.
2122
2123If that module is not available, then HTTP::Tiny will search several
2124system-specific default locations for a CA certificate file:
2125
2126=over 4
2127
2128=item *
2129
2130/etc/ssl/certs/ca-certificates.crt
2131
2132=item *
2133
2134/etc/pki/tls/certs/ca-bundle.crt
2135
2136=item *
2137
2138/etc/ssl/ca-bundle.pem
2139
2140=item *
2141
2142/etc/openssl/certs/ca-certificates.crt
2143
2144=item *
2145
2146/etc/ssl/cert.pem
2147
2148=item *
2149
2150/usr/local/share/certs/ca-root-nss.crt
2151
2152=item *
2153
2154/etc/pki/tls/cacert.pem
2155
2156=item *
2157
2158/etc/certs/ca-certificates.crt
2159
2160=back
2161
2162An error will be occur if C<verify_SSL> is true and no CA certificate file
2163is available.
2164
2165If you desire complete control over TLS/SSL connections, the C<SSL_options>
2166attribute lets you provide a hash reference that will be passed through to
2167C<IO::Socket::SSL::start_SSL()>, overriding any options set by HTTP::Tiny. For
2168example, to provide your own trusted CA file:
2169
2170    SSL_options => {
2171        SSL_ca_file => $file_path,
2172    }
2173
2174The C<SSL_options> attribute could also be used for such things as providing a
2175client certificate for authentication to a server or controlling the choice of
2176cipher used for the TLS/SSL connection. See L<IO::Socket::SSL> documentation for
2177details.
2178
2179=head1 PROXY SUPPORT
2180
2181HTTP::Tiny can proxy both C<http> and C<https> requests.  Only Basic proxy
2182authorization is supported and it must be provided as part of the proxy URL:
2183C<http://user:pass@proxy.example.com/>.
2184
2185HTTP::Tiny supports the following proxy environment variables:
2186
2187=over 4
2188
2189=item *
2190
2191http_proxy or HTTP_PROXY
2192
2193=item *
2194
2195https_proxy or HTTPS_PROXY
2196
2197=item *
2198
2199all_proxy or ALL_PROXY
2200
2201=back
2202
2203If the C<REQUEST_METHOD> environment variable is set, then this might be a CGI
2204process and C<HTTP_PROXY> would be set from the C<Proxy:> header, which is a
2205security risk.  If C<REQUEST_METHOD> is set, C<HTTP_PROXY> (the upper case
2206variant only) is ignored, but C<CGI_HTTP_PROXY> is considered instead.
2207
2208Tunnelling C<https> over an C<http> proxy using the CONNECT method is
2209supported.  If your proxy uses C<https> itself, you can not tunnel C<https>
2210over it.
2211
2212Be warned that proxying an C<https> connection opens you to the risk of a
2213man-in-the-middle attack by the proxy server.
2214
2215The C<no_proxy> environment variable is supported in the format of a
2216comma-separated list of domain extensions proxy should not be used for.
2217
2218Proxy arguments passed to C<new> will override their corresponding
2219environment variables.
2220
2221=head1 LIMITATIONS
2222
2223HTTP::Tiny is I<conditionally compliant> with the
2224L<HTTP/1.1 specifications|http://www.w3.org/Protocols/>:
2225
2226=over 4
2227
2228=item *
2229
2230"Message Syntax and Routing" [RFC7230]
2231
2232=item *
2233
2234"Semantics and Content" [RFC7231]
2235
2236=item *
2237
2238"Conditional Requests" [RFC7232]
2239
2240=item *
2241
2242"Range Requests" [RFC7233]
2243
2244=item *
2245
2246"Caching" [RFC7234]
2247
2248=item *
2249
2250"Authentication" [RFC7235]
2251
2252=back
2253
2254It attempts to meet all "MUST" requirements of the specification, but does not
2255implement all "SHOULD" requirements.  (Note: it was developed against the
2256earlier RFC 2616 specification and may not yet meet the revised RFC 7230-7235
2257spec.) Additionally, HTTP::Tiny supports the C<PATCH> method of RFC 5789.
2258
2259Some particular limitations of note include:
2260
2261=over
2262
2263=item *
2264
2265HTTP::Tiny focuses on correct transport.  Users are responsible for ensuring
2266that user-defined headers and content are compliant with the HTTP/1.1
2267specification.
2268
2269=item *
2270
2271Users must ensure that URLs are properly escaped for unsafe characters and that
2272international domain names are properly encoded to ASCII. See L<URI::Escape>,
2273L<URI::_punycode> and L<Net::IDN::Encode>.
2274
2275=item *
2276
2277Redirection is very strict against the specification.  Redirection is only
2278automatic for response codes 301, 302, 307 and 308 if the request method is
2279'GET' or 'HEAD'.  Response code 303 is always converted into a 'GET'
2280redirection, as mandated by the specification.  There is no automatic support
2281for status 305 ("Use proxy") redirections.
2282
2283=item *
2284
2285There is no provision for delaying a request body using an C<Expect> header.
2286Unexpected C<1XX> responses are silently ignored as per the specification.
2287
2288=item *
2289
2290Only 'chunked' C<Transfer-Encoding> is supported.
2291
2292=item *
2293
2294There is no support for a Request-URI of '*' for the 'OPTIONS' request.
2295
2296=item *
2297
2298Headers mentioned in the RFCs and some other, well-known headers are
2299generated with their canonical case.  Other headers are sent in the
2300case provided by the user.  Except for control headers (which are sent first),
2301headers are sent in arbitrary order.
2302
2303=back
2304
2305Despite the limitations listed above, HTTP::Tiny is considered
2306feature-complete.  New feature requests should be directed to
2307L<HTTP::Tiny::UA>.
2308
2309=head1 SEE ALSO
2310
2311=over 4
2312
2313=item *
2314
2315L<HTTP::Tiny::UA> - Higher level UA features for HTTP::Tiny
2316
2317=item *
2318
2319L<HTTP::Thin> - HTTP::Tiny wrapper with L<HTTP::Request>/L<HTTP::Response> compatibility
2320
2321=item *
2322
2323L<HTTP::Tiny::Mech> - Wrap L<WWW::Mechanize> instance in HTTP::Tiny compatible interface
2324
2325=item *
2326
2327L<IO::Socket::IP> - Required for IPv6 support
2328
2329=item *
2330
2331L<IO::Socket::SSL> - Required for SSL support
2332
2333=item *
2334
2335L<LWP::UserAgent> - If HTTP::Tiny isn't enough for you, this is the "standard" way to do things
2336
2337=item *
2338
2339L<Mozilla::CA> - Required if you want to validate SSL certificates
2340
2341=item *
2342
2343L<Net::SSLeay> - Required for SSL support
2344
2345=back
2346
2347=for :stopwords cpan testmatrix url bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
2348
2349=head1 SUPPORT
2350
2351=head2 Bugs / Feature Requests
2352
2353Please report any bugs or feature requests through the issue tracker
2354at L<https://github.com/Perl-Toolchain-Gang/HTTP-Tiny/issues>.
2355You will be notified automatically of any progress on your issue.
2356
2357=head2 Source Code
2358
2359This is open source software.  The code repository is available for
2360public review and contribution under the terms of the license.
2361
2362L<https://github.com/Perl-Toolchain-Gang/HTTP-Tiny>
2363
2364  git clone https://github.com/Perl-Toolchain-Gang/HTTP-Tiny.git
2365
2366=head1 AUTHORS
2367
2368=over 4
2369
2370=item *
2371
2372Christian Hansen <chansen@cpan.org>
2373
2374=item *
2375
2376David Golden <dagolden@cpan.org>
2377
2378=back
2379
2380=head1 CONTRIBUTORS
2381
2382=for stopwords Alan Gardner Alessandro Ghedini A. Sinan Unur Brad Gilbert brian m. carlson Chris Nehren Weyl Claes Jakobsson Clinton Gormley Craig Berry David Golden Mitchell Dean Pearce Edward Zborowski Felipe Gasper Graham Knop Greg Kennedy James E Keenan Raspass Jeremy Mates Jess Robinson Karen Etheridge Lukas Eklund Martin J. Evans Martin-Louis Bright Matthew Horsfall Michael R. Davis Mike Doherty Nicolas Rochelemagne Olaf Alders Olivier Mengué Petr Písař sanjay-cpu Serguei Trouchelle Shoichi Kaji SkyMarshal Sören Kornetzki Steve Grazzini Stig Palmquist Syohei YOSHIDA Tatsuhiko Miyagawa Tom Hukins Tony Cook Xavier Guimard
2383
2384=over 4
2385
2386=item *
2387
2388Alan Gardner <gardner@pythian.com>
2389
2390=item *
2391
2392Alessandro Ghedini <al3xbio@gmail.com>
2393
2394=item *
2395
2396A. Sinan Unur <nanis@cpan.org>
2397
2398=item *
2399
2400Brad Gilbert <bgills@cpan.org>
2401
2402=item *
2403
2404brian m. carlson <sandals@crustytoothpaste.net>
2405
2406=item *
2407
2408Chris Nehren <apeiron@cpan.org>
2409
2410=item *
2411
2412Chris Weyl <cweyl@alumni.drew.edu>
2413
2414=item *
2415
2416Claes Jakobsson <claes@surfar.nu>
2417
2418=item *
2419
2420Clinton Gormley <clint@traveljury.com>
2421
2422=item *
2423
2424Craig A. Berry <craigberry@mac.com>
2425
2426=item *
2427
2428Craig Berry <cberry@cpan.org>
2429
2430=item *
2431
2432David Golden <xdg@xdg.me>
2433
2434=item *
2435
2436David Mitchell <davem@iabyn.com>
2437
2438=item *
2439
2440Dean Pearce <pearce@pythian.com>
2441
2442=item *
2443
2444Edward Zborowski <ed@rubensteintech.com>
2445
2446=item *
2447
2448Felipe Gasper <felipe@felipegasper.com>
2449
2450=item *
2451
2452Graham Knop <haarg@haarg.org>
2453
2454=item *
2455
2456Greg Kennedy <kennedy.greg@gmail.com>
2457
2458=item *
2459
2460James E Keenan <jkeenan@cpan.org>
2461
2462=item *
2463
2464James Raspass <jraspass@gmail.com>
2465
2466=item *
2467
2468Jeremy Mates <jmates@cpan.org>
2469
2470=item *
2471
2472Jess Robinson <castaway@desert-island.me.uk>
2473
2474=item *
2475
2476Karen Etheridge <ether@cpan.org>
2477
2478=item *
2479
2480Lukas Eklund <leklund@gmail.com>
2481
2482=item *
2483
2484Martin J. Evans <mjegh@ntlworld.com>
2485
2486=item *
2487
2488Martin-Louis Bright <mlbright@gmail.com>
2489
2490=item *
2491
2492Matthew Horsfall <wolfsage@gmail.com>
2493
2494=item *
2495
2496Michael R. Davis <mrdvt92@users.noreply.github.com>
2497
2498=item *
2499
2500Mike Doherty <doherty@cpan.org>
2501
2502=item *
2503
2504Nicolas Rochelemagne <rochelemagne@cpanel.net>
2505
2506=item *
2507
2508Olaf Alders <olaf@wundersolutions.com>
2509
2510=item *
2511
2512Olivier Mengué <dolmen@cpan.org>
2513
2514=item *
2515
2516Petr Písař <ppisar@redhat.com>
2517
2518=item *
2519
2520sanjay-cpu <snjkmr32@gmail.com>
2521
2522=item *
2523
2524Serguei Trouchelle <stro@cpan.org>
2525
2526=item *
2527
2528Shoichi Kaji <skaji@cpan.org>
2529
2530=item *
2531
2532SkyMarshal <skymarshal1729@gmail.com>
2533
2534=item *
2535
2536Sören Kornetzki <soeren.kornetzki@delti.com>
2537
2538=item *
2539
2540Steve Grazzini <steve.grazzini@grantstreet.com>
2541
2542=item *
2543
2544Stig Palmquist <git@stig.io>
2545
2546=item *
2547
2548Syohei YOSHIDA <syohex@gmail.com>
2549
2550=item *
2551
2552Tatsuhiko Miyagawa <miyagawa@bulknews.net>
2553
2554=item *
2555
2556Tom Hukins <tom@eborcom.com>
2557
2558=item *
2559
2560Tony Cook <tony@develop-help.com>
2561
2562=item *
2563
2564Xavier Guimard <yadd@debian.org>
2565
2566=back
2567
2568=head1 COPYRIGHT AND LICENSE
2569
2570This software is copyright (c) 2023 by Christian Hansen.
2571
2572This is free software; you can redistribute it and/or modify it under
2573the same terms as the Perl 5 programming language system itself.
2574
2575=cut
2576