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