ok
Direktori : /proc/thread-self/root/usr/share/perl5/vendor_perl/HTTP/ |
Current File : //proc/thread-self/root/usr/share/perl5/vendor_perl/HTTP/Tiny.pm |
# vim: ts=4 sts=4 sw=4 et: package HTTP::Tiny; use strict; use warnings; # ABSTRACT: A small, simple, correct HTTP/1.1 client our $VERSION = '0.033'; # VERSION use Carp (); use Fcntl (); my @attributes; BEGIN { @attributes = qw(cookie_jar default_headers local_address max_redirect max_size proxy no_proxy timeout SSL_options verify_SSL); no strict 'refs'; for my $accessor ( @attributes ) { *{$accessor} = sub { @_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor}; }; } } sub agent { my($self, $agent) = @_; if( @_ > 1 ){ $self->{agent} = (defined $agent && $agent =~ / $/) ? $agent . $self->_agent : $agent; } return $self->{agent}; } sub new { my($class, %args) = @_; my $self = { max_redirect => 5, timeout => 60, verify_SSL => $args{verify_SSL} || $args{verify_ssl} || 0, # no verification by default no_proxy => $ENV{no_proxy}, }; bless $self, $class; $class->_validate_cookie_jar( $args{cookie_jar} ) if $args{cookie_jar}; for my $key ( @attributes ) { $self->{$key} = $args{$key} if exists $args{$key} } $self->agent( exists $args{agent} ? $args{agent} : $class->_agent ); # Never override proxy argument as this breaks backwards compat. if (!exists $self->{proxy} && (my $http_proxy = $ENV{http_proxy})) { if ($http_proxy =~ m{\Ahttp://[^/?#:@]+:\d+/?\z}) { $self->{proxy} = $http_proxy; } else { Carp::croak(qq{Environment 'http_proxy' must be in format http://<host>:<port>/\n}); } } # Split no_proxy to array reference if not provided as such unless ( ref $self->{no_proxy} eq 'ARRAY' ) { $self->{no_proxy} = (defined $self->{no_proxy}) ? [ split /\s*,\s*/, $self->{no_proxy} ] : []; } return $self; } for my $sub_name ( qw/get head put post delete/ ) { my $req_method = uc $sub_name; no strict 'refs'; eval <<"HERE"; ## no critic sub $sub_name { my (\$self, \$url, \$args) = \@_; \@_ == 2 || (\@_ == 3 && ref \$args eq 'HASH') or Carp::croak(q/Usage: \$http->$sub_name(URL, [HASHREF])/ . "\n"); return \$self->request('$req_method', \$url, \$args || {}); } HERE } sub post_form { my ($self, $url, $data, $args) = @_; (@_ == 3 || @_ == 4 && ref $args eq 'HASH') or Carp::croak(q/Usage: $http->post_form(URL, DATAREF, [HASHREF])/ . "\n"); my $headers = {}; while ( my ($key, $value) = each %{$args->{headers} || {}} ) { $headers->{lc $key} = $value; } delete $args->{headers}; return $self->request('POST', $url, { %$args, content => $self->www_form_urlencode($data), headers => { %$headers, 'content-type' => 'application/x-www-form-urlencoded' }, } ); } sub mirror { my ($self, $url, $file, $args) = @_; @_ == 3 || (@_ == 4 && ref $args eq 'HASH') or Carp::croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ . "\n"); if ( -e $file and my $mtime = (stat($file))[9] ) { $args->{headers}{'if-modified-since'} ||= $self->_http_date($mtime); } my $tempfile = $file . int(rand(2**31)); sysopen my $fh, $tempfile, Fcntl::O_CREAT|Fcntl::O_EXCL|Fcntl::O_WRONLY or Carp::croak(qq/Error: Could not create temporary file $tempfile for downloading: $!\n/); binmode $fh; $args->{data_callback} = sub { print {$fh} $_[0] or Carp::croak(qq/Error: Could not write into temporary file $tempfile: $!\n/); }; my $response = $self->request('GET', $url, $args); close $fh or Carp::croak(qq/Error: Could not close temporary file $tempfile: $!\n/); if ( $response->{success} ) { rename $tempfile, $file or Carp::croak(qq/Error replacing $file with $tempfile: $!\n/); my $lm = $response->{headers}{'last-modified'}; if ( $lm and my $mtime = $self->_parse_http_date($lm) ) { utime $mtime, $mtime, $file; } } $response->{success} ||= $response->{status} eq '304'; unlink $tempfile; return $response; } my %idempotent = map { $_ => 1 } qw/GET HEAD PUT DELETE OPTIONS TRACE/; sub request { my ($self, $method, $url, $args) = @_; @_ == 3 || (@_ == 4 && ref $args eq 'HASH') or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/ . "\n"); $args ||= {}; # we keep some state in this during _request # RFC 2616 Section 8.1.4 mandates a single retry on broken socket my $response; for ( 0 .. 1 ) { $response = eval { $self->_request($method, $url, $args) }; last unless $@ && $idempotent{$method} && $@ =~ m{^(?:Socket closed|Unexpected end)}; } if (my $e = "$@") { $response = { url => $url, success => q{}, status => 599, reason => 'Internal Exception', content => $e, headers => { 'content-type' => 'text/plain', 'content-length' => length $e, } }; } return $response; } sub www_form_urlencode { my ($self, $data) = @_; (@_ == 2 && ref $data) or Carp::croak(q/Usage: $http->www_form_urlencode(DATAREF)/ . "\n"); (ref $data eq 'HASH' || ref $data eq 'ARRAY') or Carp::croak("form data must be a hash or array reference\n"); my @params = ref $data eq 'HASH' ? %$data : @$data; @params % 2 == 0 or Carp::croak("form data reference must have an even number of terms\n"); my @terms; while( @params ) { my ($key, $value) = splice(@params, 0, 2); if ( ref $value eq 'ARRAY' ) { unshift @params, map { $key => $_ } @$value; } else { push @terms, join("=", map { $self->_uri_escape($_) } $key, $value); } } return join("&", sort @terms); } #--------------------------------------------------------------------------# # private methods #--------------------------------------------------------------------------# my %DefaultPort = ( http => 80, https => 443, ); sub _agent { my $class = ref($_[0]) || $_[0]; (my $default_agent = $class) =~ s{::}{-}g; return $default_agent . "/" . ($class->VERSION || 0); } sub _request { my ($self, $method, $url, $args) = @_; my ($scheme, $host, $port, $path_query) = $self->_split_url($url); my $request = { method => $method, scheme => $scheme, host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"), uri => $path_query, headers => {}, }; my $handle = HTTP::Tiny::Handle->new( timeout => $self->{timeout}, SSL_options => $self->{SSL_options}, verify_SSL => $self->{verify_SSL}, local_address => $self->{local_address}, ); if ($self->{proxy} && ! grep { $host =~ /\Q$_\E$/ } @{$self->{no_proxy}}) { $request->{uri} = "$scheme://$request->{host_port}$path_query"; die(qq/HTTPS via proxy is not supported\n/) if $request->{scheme} eq 'https'; $handle->connect(($self->_split_url($self->{proxy}))[0..2]); } else { $handle->connect($scheme, $host, $port); } $self->_prepare_headers_and_cb($request, $args, $url); $handle->write_request($request); my $response; do { $response = $handle->read_response_header } until (substr($response->{status},0,1) ne '1'); $self->_update_cookie_jar( $url, $response ) if $self->{cookie_jar}; if ( my @redir_args = $self->_maybe_redirect($request, $response, $args) ) { $handle->close; return $self->_request(@redir_args, $args); } if ($method eq 'HEAD' || $response->{status} =~ /^[23]04/) { # response has no message body } else { my $data_cb = $self->_prepare_data_cb($response, $args); $handle->read_body($data_cb, $response); } $handle->close; $response->{success} = substr($response->{status},0,1) eq '2'; $response->{url} = $url; return $response; } sub _prepare_headers_and_cb { my ($self, $request, $args, $url) = @_; for ($self->{default_headers}, $args->{headers}) { next unless defined; while (my ($k, $v) = each %$_) { $request->{headers}{lc $k} = $v; } } $request->{headers}{'host'} = $request->{host_port}; $request->{headers}{'connection'} = "close"; $request->{headers}{'user-agent'} ||= $self->{agent}; if ( defined $args->{content} ) { if (ref $args->{content} eq 'CODE') { $request->{headers}{'content-type'} ||= "application/octet-stream"; $request->{headers}{'transfer-encoding'} = 'chunked' unless $request->{headers}{'content-length'} || $request->{headers}{'transfer-encoding'}; $request->{cb} = $args->{content}; } elsif ( length $args->{content} ) { my $content = $args->{content}; if ( $] ge '5.008' ) { utf8::downgrade($content, 1) or die(qq/Wide character in request message body\n/); } $request->{headers}{'content-type'} ||= "application/octet-stream"; $request->{headers}{'content-length'} = length $content unless $request->{headers}{'content-length'} || $request->{headers}{'transfer-encoding'}; $request->{cb} = sub { substr $content, 0, length $content, '' }; } $request->{trailer_cb} = $args->{trailer_callback} if ref $args->{trailer_callback} eq 'CODE'; } ### If we have a cookie jar, then maybe add relevant cookies if ( $self->{cookie_jar} ) { my $cookies = $self->cookie_jar->cookie_header( $url ); $request->{headers}{cookie} = $cookies if length $cookies; } return; } sub _prepare_data_cb { my ($self, $response, $args) = @_; my $data_cb = $args->{data_callback}; $response->{content} = ''; if (!$data_cb || $response->{status} !~ /^2/) { if (defined $self->{max_size}) { $data_cb = sub { $_[1]->{content} .= $_[0]; die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/) if length $_[1]->{content} > $self->{max_size}; }; } else { $data_cb = sub { $_[1]->{content} .= $_[0] }; } } return $data_cb; } sub _update_cookie_jar { my ($self, $url, $response) = @_; my $cookies = $response->{headers}->{'set-cookie'}; return unless defined $cookies; my @cookies = ref $cookies ? @$cookies : $cookies; $self->cookie_jar->add( $url, $_ ) for @cookies; return; } sub _validate_cookie_jar { my ($class, $jar) = @_; # duck typing for my $method ( qw/add cookie_header/ ) { Carp::croak(qq/Cookie jar must provide the '$method' method\n/) unless ref($jar) && ref($jar)->can($method); } return; } sub _maybe_redirect { my ($self, $request, $response, $args) = @_; my $headers = $response->{headers}; my ($status, $method) = ($response->{status}, $request->{method}); if (($status eq '303' or ($status =~ /^30[127]/ && $method =~ /^GET|HEAD$/)) and $headers->{location} and ++$args->{redirects} <= $self->{max_redirect} ) { my $location = ($headers->{location} =~ /^\//) ? "$request->{scheme}://$request->{host_port}$headers->{location}" : $headers->{location} ; return (($status eq '303' ? 'GET' : $method), $location); } return; } sub _split_url { my $url = pop; # URI regex adapted from the URI module my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)> or die(qq/Cannot parse URL: '$url'\n/); $scheme = lc $scheme; $path_query = "/$path_query" unless $path_query =~ m<\A/>; my $host = (length($authority)) ? lc $authority : 'localhost'; $host =~ s/\A[^@]*@//; # userinfo my $port = do { $host =~ s/:([0-9]*)\z// && length $1 ? $1 : ($scheme eq 'http' ? 80 : $scheme eq 'https' ? 443 : undef); }; return ($scheme, $host, $port, $path_query); } # Date conversions adapted from HTTP::Date my $DoW = "Sun|Mon|Tue|Wed|Thu|Fri|Sat"; my $MoY = "Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec"; sub _http_date { my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($_[1]); return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT", substr($DoW,$wday*4,3), $mday, substr($MoY,$mon*4,3), $year+1900, $hour, $min, $sec ); } sub _parse_http_date { my ($self, $str) = @_; require Time::Local; my @tl_parts; if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) { @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3); } elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) { @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3); } elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) { @tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6); } return eval { my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1; $t < 0 ? undef : $t; }; } # URI escaping adapted from URI::Escape # c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1 # perl 5.6 ready UTF-8 encoding adapted from JSON::PP my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255; $escapes{' '}="+"; my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/; sub _uri_escape { my ($self, $str) = @_; if ( $] ge '5.008' ) { utf8::encode($str); } else { $str = pack("U*", unpack("C*", $str)) # UTF-8 encode a byte string if ( length $str == do { use bytes; length $str } ); $str = pack("C*", unpack("C*", $str)); # clear UTF-8 flag } $str =~ s/($unsafe_char)/$escapes{$1}/ge; return $str; } package HTTP::Tiny::Handle; # hide from PAUSE/indexers use strict; use warnings; use Errno qw[EINTR EPIPE]; use IO::Socket qw[SOCK_STREAM]; sub BUFSIZE () { 32768 } ## no critic my $Printable = sub { local $_ = shift; s/\r/\\r/g; s/\n/\\n/g; s/\t/\\t/g; s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge; $_; }; my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/; sub new { my ($class, %args) = @_; return bless { rbuf => '', timeout => 60, max_line_size => 16384, max_header_lines => 64, verify_SSL => 0, SSL_options => {}, %args }, $class; } sub connect { @_ == 4 || die(q/Usage: $handle->connect(scheme, host, port)/ . "\n"); my ($self, $scheme, $host, $port) = @_; if ( $scheme eq 'https' ) { # Need IO::Socket::SSL 1.42 for SSL_create_ctx_callback die(qq/IO::Socket::SSL 1.42 must be installed for https support\n/) unless eval {require IO::Socket::SSL; IO::Socket::SSL->VERSION(1.42)}; # Need Net::SSLeay 1.49 for MODE_AUTO_RETRY die(qq/Net::SSLeay 1.49 must be installed for https support\n/) unless eval {require Net::SSLeay; Net::SSLeay->VERSION(1.49)}; } elsif ( $scheme ne 'http' ) { die(qq/Unsupported URL scheme '$scheme'\n/); } $self->{fh} = 'IO::Socket::INET'->new( PeerHost => $host, PeerPort => $port, $self->{local_address} ? ( LocalAddr => $self->{local_address} ) : (), Proto => 'tcp', Type => SOCK_STREAM, Timeout => $self->{timeout} ) or die(qq/Could not connect to '$host:$port': $@\n/); binmode($self->{fh}) or die(qq/Could not binmode() socket: '$!'\n/); if ( $scheme eq 'https') { my $ssl_args = $self->_ssl_args($host); IO::Socket::SSL->start_SSL( $self->{fh}, %$ssl_args, SSL_create_ctx_callback => sub { my $ctx = shift; Net::SSLeay::CTX_set_mode($ctx, Net::SSLeay::MODE_AUTO_RETRY()); }, ); unless ( ref($self->{fh}) eq 'IO::Socket::SSL' ) { my $ssl_err = IO::Socket::SSL->errstr; die(qq/SSL connection failed for $host: $ssl_err\n/); } } $self->{host} = $host; $self->{port} = $port; return $self; } sub close { @_ == 1 || die(q/Usage: $handle->close()/ . "\n"); my ($self) = @_; CORE::close($self->{fh}) or die(qq/Could not close socket: '$!'\n/); } sub write { @_ == 2 || die(q/Usage: $handle->write(buf)/ . "\n"); my ($self, $buf) = @_; if ( $] ge '5.008' ) { utf8::downgrade($buf, 1) or die(qq/Wide character in write()\n/); } my $len = length $buf; my $off = 0; local $SIG{PIPE} = 'IGNORE'; while () { $self->can_write or die(qq/Timed out while waiting for socket to become ready for writing\n/); my $r = syswrite($self->{fh}, $buf, $len, $off); if (defined $r) { $len -= $r; $off += $r; last unless $len > 0; } elsif ($! == EPIPE) { die(qq/Socket closed by remote server: $!\n/); } elsif ($! != EINTR) { if ($self->{fh}->can('errstr')){ my $err = $self->{fh}->errstr(); die (qq/Could not write to SSL socket: '$err'\n /); } else { die(qq/Could not write to socket: '$!'\n/); } } } return $off; } sub read { @_ == 2 || @_ == 3 || die(q/Usage: $handle->read(len [, allow_partial])/ . "\n"); my ($self, $len, $allow_partial) = @_; my $buf = ''; my $got = length $self->{rbuf}; if ($got) { my $take = ($got < $len) ? $got : $len; $buf = substr($self->{rbuf}, 0, $take, ''); $len -= $take; } while ($len > 0) { $self->can_read or die(q/Timed out while waiting for socket to become ready for reading/ . "\n"); my $r = sysread($self->{fh}, $buf, $len, length $buf); if (defined $r) { last unless $r; $len -= $r; } elsif ($! != EINTR) { if ($self->{fh}->can('errstr')){ my $err = $self->{fh}->errstr(); die (qq/Could not read from SSL socket: '$err'\n /); } else { die(qq/Could not read from socket: '$!'\n/); } } } if ($len && !$allow_partial) { die(qq/Unexpected end of stream\n/); } return $buf; } sub readline { @_ == 1 || die(q/Usage: $handle->readline()/ . "\n"); my ($self) = @_; while () { if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) { return $1; } if (length $self->{rbuf} >= $self->{max_line_size}) { die(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}\n/); } $self->can_read or die(qq/Timed out while waiting for socket to become ready for reading\n/); my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf}); if (defined $r) { last unless $r; } elsif ($! != EINTR) { if ($self->{fh}->can('errstr')){ my $err = $self->{fh}->errstr(); die (qq/Could not read from SSL socket: '$err'\n /); } else { die(qq/Could not read from socket: '$!'\n/); } } } die(qq/Unexpected end of stream while looking for line\n/); } sub read_header_lines { @_ == 1 || @_ == 2 || die(q/Usage: $handle->read_header_lines([headers])/ . "\n"); my ($self, $headers) = @_; $headers ||= {}; my $lines = 0; my $val; while () { my $line = $self->readline; if (++$lines >= $self->{max_header_lines}) { die(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}\n/); } elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) { my ($field_name) = lc $1; if (exists $headers->{$field_name}) { for ($headers->{$field_name}) { $_ = [$_] unless ref $_ eq "ARRAY"; push @$_, $2; $val = \$_->[-1]; } } else { $val = \($headers->{$field_name} = $2); } } elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) { $val or die(qq/Unexpected header continuation line\n/); next unless length $1; $$val .= ' ' if length $$val; $$val .= $1; } elsif ($line =~ /\A \x0D?\x0A \z/x) { last; } else { die(q/Malformed header line: / . $Printable->($line) . "\n"); } } return $headers; } sub write_request { @_ == 2 || die(q/Usage: $handle->write_request(request)/ . "\n"); my($self, $request) = @_; $self->write_request_header(@{$request}{qw/method uri headers/}); $self->write_body($request) if $request->{cb}; return; } my %HeaderCase = ( 'content-md5' => 'Content-MD5', 'etag' => 'ETag', 'te' => 'TE', 'www-authenticate' => 'WWW-Authenticate', 'x-xss-protection' => 'X-XSS-Protection', ); sub write_header_lines { (@_ == 2 && ref $_[1] eq 'HASH') || die(q/Usage: $handle->write_header_lines(headers)/ . "\n"); my($self, $headers) = @_; my $buf = ''; while (my ($k, $v) = each %$headers) { my $field_name = lc $k; if (exists $HeaderCase{$field_name}) { $field_name = $HeaderCase{$field_name}; } else { $field_name =~ /\A $Token+ \z/xo or die(q/Invalid HTTP header field name: / . $Printable->($field_name) . "\n"); $field_name =~ s/\b(\w)/\u$1/g; $HeaderCase{lc $field_name} = $field_name; } for (ref $v eq 'ARRAY' ? @$v : $v) { /[^\x0D\x0A]/ or die(qq/Invalid HTTP header field value ($field_name): / . $Printable->($_). "\n"); $buf .= "$field_name: $_\x0D\x0A"; } } $buf .= "\x0D\x0A"; return $self->write($buf); } sub read_body { @_ == 3 || die(q/Usage: $handle->read_body(callback, response)/ . "\n"); my ($self, $cb, $response) = @_; my $te = $response->{headers}{'transfer-encoding'} || ''; if ( grep { /chunked/i } ( ref $te eq 'ARRAY' ? @$te : $te ) ) { $self->read_chunked_body($cb, $response); } else { $self->read_content_body($cb, $response); } return; } sub write_body { @_ == 2 || die(q/Usage: $handle->write_body(request)/ . "\n"); my ($self, $request) = @_; if ($request->{headers}{'content-length'}) { return $self->write_content_body($request); } else { return $self->write_chunked_body($request); } } sub read_content_body { @_ == 3 || @_ == 4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ . "\n"); my ($self, $cb, $response, $content_length) = @_; $content_length ||= $response->{headers}{'content-length'}; if ( defined $content_length ) { my $len = $content_length; while ($len > 0) { my $read = ($len > BUFSIZE) ? BUFSIZE : $len; $cb->($self->read($read, 0), $response); $len -= $read; } } else { my $chunk; $cb->($chunk, $response) while length( $chunk = $self->read(BUFSIZE, 1) ); } return; } sub write_content_body { @_ == 2 || die(q/Usage: $handle->write_content_body(request)/ . "\n"); my ($self, $request) = @_; my ($len, $content_length) = (0, $request->{headers}{'content-length'}); while () { my $data = $request->{cb}->(); defined $data && length $data or last; if ( $] ge '5.008' ) { utf8::downgrade($data, 1) or die(qq/Wide character in write_content()\n/); } $len += $self->write($data); } $len == $content_length or die(qq/Content-Length missmatch (got: $len expected: $content_length)\n/); return $len; } sub read_chunked_body { @_ == 3 || die(q/Usage: $handle->read_chunked_body(callback, $response)/ . "\n"); my ($self, $cb, $response) = @_; while () { my $head = $self->readline; $head =~ /\A ([A-Fa-f0-9]+)/x or die(q/Malformed chunk head: / . $Printable->($head) . "\n"); my $len = hex($1) or last; $self->read_content_body($cb, $response, $len); $self->read(2) eq "\x0D\x0A" or die(qq/Malformed chunk: missing CRLF after chunk data\n/); } $self->read_header_lines($response->{headers}); return; } sub write_chunked_body { @_ == 2 || die(q/Usage: $handle->write_chunked_body(request)/ . "\n"); my ($self, $request) = @_; my $len = 0; while () { my $data = $request->{cb}->(); defined $data && length $data or last; if ( $] ge '5.008' ) { utf8::downgrade($data, 1) or die(qq/Wide character in write_chunked_body()\n/); } $len += length $data; my $chunk = sprintf '%X', length $data; $chunk .= "\x0D\x0A"; $chunk .= $data; $chunk .= "\x0D\x0A"; $self->write($chunk); } $self->write("0\x0D\x0A"); $self->write_header_lines($request->{trailer_cb}->()) if ref $request->{trailer_cb} eq 'CODE'; return $len; } sub read_response_header { @_ == 1 || die(q/Usage: $handle->read_response_header()/ . "\n"); my ($self) = @_; my $line = $self->readline; $line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x or die(q/Malformed Status-Line: / . $Printable->($line). "\n"); my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4); die (qq/Unsupported HTTP protocol: $protocol\n/) unless $version =~ /0*1\.0*[01]/; return { status => $status, reason => $reason, headers => $self->read_header_lines, protocol => $protocol, }; } sub write_request_header { @_ == 4 || die(q/Usage: $handle->write_request_header(method, request_uri, headers)/ . "\n"); my ($self, $method, $request_uri, $headers) = @_; return $self->write("$method $request_uri HTTP/1.1\x0D\x0A") + $self->write_header_lines($headers); } sub _do_timeout { my ($self, $type, $timeout) = @_; $timeout = $self->{timeout} unless defined $timeout && $timeout >= 0; my $fd = fileno $self->{fh}; defined $fd && $fd >= 0 or die(qq/select(2): 'Bad file descriptor'\n/); my $initial = time; my $pending = $timeout; my $nfound; vec(my $fdset = '', $fd, 1) = 1; while () { $nfound = ($type eq 'read') ? select($fdset, undef, undef, $pending) : select(undef, $fdset, undef, $pending) ; if ($nfound == -1) { $! == EINTR or die(qq/select(2): '$!'\n/); redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0; $nfound = 0; } last; } $! = 0; return $nfound; } sub can_read { @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_read([timeout])/ . "\n"); my $self = shift; return $self->_do_timeout('read', @_) } sub can_write { @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_write([timeout])/ . "\n"); my $self = shift; return $self->_do_timeout('write', @_) } # Try to find a CA bundle to validate the SSL cert, # prefer Mozilla::CA or fallback to a system file sub _find_CA_file { my $self = shift(); return $self->{SSL_options}->{SSL_ca_file} if $self->{SSL_options}->{SSL_ca_file} and -e $self->{SSL_options}->{SSL_ca_file}; return Mozilla::CA::SSL_ca_file() if eval { require Mozilla::CA }; foreach my $ca_bundle (qw{ /etc/ssl/certs/ca-certificates.crt /etc/pki/tls/certs/ca-bundle.crt /etc/ssl/ca-bundle.pem } ) { return $ca_bundle if -e $ca_bundle; } die qq/Couldn't find a CA bundle with which to verify the SSL certificate.\n/ . qq/Try installing Mozilla::CA from CPAN\n/; } sub _ssl_args { my ($self, $host) = @_; my %ssl_args; # This test reimplements IO::Socket::SSL::can_client_sni(), which wasn't # added until IO::Socket::SSL 1.84 if ( Net::SSLeay::OPENSSL_VERSION_NUMBER() >= 0x01000000 ) { $ssl_args{SSL_hostname} = $host, # Sane SNI support } if ($self->{verify_SSL}) { $ssl_args{SSL_verifycn_scheme} = 'http'; # enable CN validation $ssl_args{SSL_verifycn_name} = $host; # set validation hostname $ssl_args{SSL_verify_mode} = 0x01; # enable cert validation $ssl_args{SSL_ca_file} = $self->_find_CA_file; } else { $ssl_args{SSL_verifycn_scheme} = 'none'; # disable CN validation $ssl_args{SSL_verify_mode} = 0x00; # disable cert validation } # user options override settings from verify_SSL for my $k ( keys %{$self->{SSL_options}} ) { $ssl_args{$k} = $self->{SSL_options}{$k} if $k =~ m/^SSL_/; } return \%ssl_args; } 1; __END__ =pod =encoding utf-8 =head1 NAME HTTP::Tiny - A small, simple, correct HTTP/1.1 client =head1 VERSION version 0.033 =head1 SYNOPSIS use HTTP::Tiny; my $response = HTTP::Tiny->new->get('http://example.com/'); die "Failed!\n" unless $response->{success}; print "$response->{status} $response->{reason}\n"; while (my ($k, $v) = each %{$response->{headers}}) { for (ref $v eq 'ARRAY' ? @$v : $v) { print "$k: $_\n"; } } print $response->{content} if length $response->{content}; =head1 DESCRIPTION This is a very simple HTTP/1.1 client, designed for doing simple GET requests without the overhead of a large framework like L<LWP::UserAgent>. It is more correct and more complete than L<HTTP::Lite>. It supports proxies (currently only non-authenticating ones) and redirection. It also correctly resumes after EINTR. =head1 METHODS =head2 new $http = HTTP::Tiny->new( %attributes ); This constructor returns a new HTTP::Tiny object. Valid attributes include: =over 4 =item * C<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. =item * C<cookie_jar> An instance of L<HTTP::CookieJar> or equivalent class that supports the C<add> and C<cookie_header> methods =item * C<default_headers> A hashref of default headers to apply to requests =item * C<local_address> The local IP address to bind to =item * C<max_redirect> Maximum number of redirects allowed (defaults to 5) =item * C<max_size> Maximum response size (only when not using a data callback). If defined, responses larger than this will return an exception. =item * C<proxy> URL of a proxy server to use (default is C<$ENV{http_proxy}> if set) =item * C<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}>) =item * C<timeout> Request timeout in seconds (default is 60) =item * C<verify_SSL> A boolean that indicates whether to validate the SSL certificate of an C<https> connection (default is false) =item * C<SSL_options> A hashref of C<SSL_*> options to pass through to L<IO::Socket::SSL> =back Exceptions from C<max_size>, C<timeout> or other errors will result in a pseudo-HTTP status code of 599 and a reason of "Internal Exception". The content field in the response will contain the text of the exception. See L</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes. =head2 get|head|put|post|delete $response = $http->get($url); $response = $http->get($url, \%options); $response = $http->head($url); These methods are shorthand for calling C<request()> for the given method. The URL must have unsafe characters escaped and international domain names encoded. See C<request()> for valid options and a description of the response. The C<success> field of the response will be true if the status code is 2XX. =head2 post_form $response = $http->post_form($url, $form_data); $response = $http->post_form($url, $form_data, \%options); This method executes a C<POST> request and sends the key/value pairs from a form data hash or array reference to the given URL with a C<content-type> of C<application/x-www-form-urlencoded>. See documentation for the C<www_form_urlencode> method for details on the encoding. The URL must have unsafe characters escaped and international domain names encoded. See C<request()> for valid options and a description of the response. Any C<content-type> header or content in the options hashref will be ignored. The C<success> field of the response will be true if the status code is 2XX. =head2 mirror $response = $http->mirror($url, $file, \%options) if ( $response->{success} ) { print "$file is up to date\n"; } Executes a C<GET> request for the URL and saves the response body to the file name provided. The URL must have unsafe characters escaped and international domain names encoded. If the file already exists, the request will include an C<If-Modified-Since> header with the modification timestamp of the file. You may specify a different C<If-Modified-Since> header yourself in the C<< $options->{headers} >> hash. The C<success> field of the response will be true if the status code is 2XX or if the status code is 304 (unmodified). If the file was modified and the server response includes a properly formatted C<Last-Modified> header, the file modification time will be updated accordingly. =head2 request $response = $http->request($method, $url); $response = $http->request($method, $url, \%options); Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST', 'PUT', etc.) on the given URL. The URL must have unsafe characters escaped and international domain names encoded. A hashref of options may be appended to modify the request. Valid options are: =over 4 =item * C<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. =item * C<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 =item * C<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) =item * C<data_callback> A code reference that will be called for each chunks of the response body received. =back If the C<content> option is a code reference, it will be called iteratively to provide the content body of the request. It should return the empty string or undef when the iterator is exhausted. If the C<content> option is the empty string, no C<content-type> or C<content-length> headers will be generated. If the C<data_callback> option is provided, it will be called iteratively until the entire response body is received. The first argument will be a string containing a chunk of the response body, the second argument will be the in-progress response hash reference, as described below. (This allows customizing the action of the callback based on the C<status> or C<headers> received prior to the content body.) The C<request> method returns a hashref containing the response. The hashref will have the following keys: =over 4 =item * C<success> Boolean indicating whether the operation returned a 2XX status code =item * C<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 =item * C<status> The HTTP status code of the response =item * C<reason> The response phrase returned by the server =item * C<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 =item * C<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 =back On an exception during the execution of the request, the C<status> field will contain 599, and the C<content> field will contain the text of the exception. =head2 www_form_urlencode $params = $http->www_form_urlencode( $data ); $response = $http->get("http://example.com/query?$params"); This method converts the key/value pairs from a data hash or array reference into a C<x-www-form-urlencoded> string. The keys and values from the data reference will be UTF-8 encoded and escaped per RFC 3986. If a value is an array reference, the key will be repeated with each of the values of the array reference. The key/value pairs in the resulting string will be sorted by key and value. =for Pod::Coverage agent cookie_jar default_headers local_address max_redirect max_size proxy no_proxy timeout verify_SSL SSL_options =head1 SSL SUPPORT Direct C<https> connections are supported only if L<IO::Socket::SSL> 1.56 or greater and L<Net::SSLeay> 1.49 or greater are installed. An exception will be thrown if a new enough versions of these modules not installed or if the SSL encryption fails. There is no support for C<https> connections via proxy (i.e. RFC 2817). SSL provides two distinct capabilities: =over 4 =item * Encrypted communication channel =item * Verification of server identity =back B<By default, HTTP::Tiny does not verify server identity>. Server identity verification is controversial and potentially tricky because it depends on a (usually paid) third-party Certificate Authority (CA) trust model to validate a certificate as legitimate. This discriminates against servers with self-signed certificates or certificates signed by free, community-driven CA's such as L<CAcert.org|http://cacert.org>. By default, HTTP::Tiny does not make any assumptions about your trust model, threat level or risk tolerance. It just aims to give you an encrypted channel when you need one. Setting the C<verify_SSL> attribute to a true value will make HTTP::Tiny verify that an SSL connection has a valid SSL certificate corresponding to the host name of the connection and that the SSL certificate has been verified by a CA. Assuming you trust the CA, this will protect against a L<man-in-the-middle attack|http://en.wikipedia.org/wiki/Man-in-the-middle_attack>. If you are concerned about security, you should enable this option. Certificate verification requires a file containing trusted CA certificates. If the L<Mozilla::CA> module is installed, HTTP::Tiny will use the CA file included with it as a source of trusted CA's. (This means you trust Mozilla, the author of Mozilla::CA, the CPAN mirror where you got Mozilla::CA, the toolchain used to install it, and your operating system security, right?) If that module is not available, then HTTP::Tiny will search several system-specific default locations for a CA certificate file: =over 4 =item * /etc/ssl/certs/ca-certificates.crt =item * /etc/pki/tls/certs/ca-bundle.crt =item * /etc/ssl/ca-bundle.pem =back An exception will be raised if C<verify_SSL> is true and no CA certificate file is available. If you desire complete control over SSL connections, the C<SSL_options> attribute lets you provide a hash reference that will be passed through to C<IO::Socket::SSL::start_SSL()>, overriding any options set by HTTP::Tiny. For example, to provide your own trusted CA file: SSL_options => { SSL_ca_file => $file_path, } The C<SSL_options> attribute could also be used for such things as providing a client certificate for authentication to a server or controlling the choice of cipher used for the SSL connection. See L<IO::Socket::SSL> documentation for details. =head1 LIMITATIONS HTTP::Tiny is I<conditionally compliant> with the L<HTTP/1.1 specification|http://www.w3.org/Protocols/rfc2616/rfc2616.html>. It attempts to meet all "MUST" requirements of the specification, but does not implement all "SHOULD" requirements. Some particular limitations of note include: =over =item * HTTP::Tiny focuses on correct transport. Users are responsible for ensuring that user-defined headers and content are compliant with the HTTP/1.1 specification. =item * Users must ensure that URLs are properly escaped for unsafe characters and that international domain names are properly encoded to ASCII. See L<URI::Escape>, L<URI::_punycode> and L<Net::IDN::Encode>. =item * Redirection is very strict against the specification. Redirection is only automatic for response codes 301, 302 and 307 if the request method is 'GET' or 'HEAD'. Response code 303 is always converted into a 'GET' redirection, as mandated by the specification. There is no automatic support for status 305 ("Use proxy") redirections. =item * Persistent connections are not supported. The C<Connection> header will always be set to C<close>. =item * Cookie support requires L<HTTP::CookieJar> or an equivalent class. =item * Only the C<http_proxy> environment variable is supported in the format C<http://HOST:PORT/>. If a C<proxy> argument is passed to C<new> (including undef), then the C<http_proxy> environment variable is ignored. =item * C<no_proxy> environment variable is supported in the format comma-separated list of domain extensions proxy should not be used for. If a C<no_proxy> argument is passed to C<new>, then the C<no_proxy> environment variable is ignored. =item * There is no provision for delaying a request body using an C<Expect> header. Unexpected C<1XX> responses are silently ignored as per the specification. =item * Only 'chunked' C<Transfer-Encoding> is supported. =item * There is no support for a Request-URI of '*' for the 'OPTIONS' request. =item * There is no support for IPv6 of any kind. =back =head1 SEE ALSO =over 4 =item * L<HTTP::Thin> - HTTP::Tiny wrapper with L<HTTP::Request>/L<HTTP::Response> compatibility =item * L<HTTP::Tiny::Mech> - Wrap L<WWW::Mechanize> instance in HTTP::Tiny compatible interface =item * L<IO::Socket::SSL> - Required for SSL support =item * L<LWP::UserAgent> - If HTTP::Tiny isn't enough for you, this is the "standard" way to do things =item * L<Mozilla::CA> - Required if you want to validate SSL certificates =item * L<Net::SSLeay> - Required for SSL support =back =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan =head1 SUPPORT =head2 Bugs / Feature Requests Please report any bugs or feature requests through the issue tracker at L<https://github.com/chansen/p5-http-tiny/issues>. You will be notified automatically of any progress on your issue. =head2 Source Code This is open source software. The code repository is available for public review and contribution under the terms of the license. L<https://github.com/chansen/p5-http-tiny> git clone git://github.com/chansen/p5-http-tiny.git =head1 AUTHORS =over 4 =item * Christian Hansen <chansen@cpan.org> =item * David Golden <dagolden@cpan.org> =back =head1 CONTRIBUTORS =over 4 =item * Alan Gardner <gardner@pythian.com> =item * Alessandro Ghedini <al3xbio@gmail.com> =item * Brad Gilbert <bgills@cpan.org> =item * Chris Nehren <apeiron@cpan.org> =item * Chris Weyl <cweyl@alumni.drew.edu> =item * Claes Jakobsson <claes@surfar.nu> =item * Craig Berry <cberry@cpan.org> =item * David Mitchell <davem@iabyn.com> =item * Edward Zborowski <ed@rubensteintech.com> =item * Jess Robinson <castaway@desert-island.me.uk> =item * Lukas Eklund <leklund@gmail.com> =item * Martin-Louis Bright <mlbright@gmail.com> =item * Mike Doherty <doherty@cpan.org> =item * Serguei Trouchelle <stro@cpan.org> =item * Syohei YOSHIDA <syohex@gmail.com> =item * Tony Cook <tony@develop-help.com> =back =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Christian Hansen. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut