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