cpan/HTTP-Tiny/lib/HTTP/Tiny.pm

   1 # vim: ts=4 sts=4 sw=4 et:
   2 package HTTP::Tiny;
   3 use strict;
   4 use warnings;
   5 # ABSTRACT: A small, simple, correct HTTP/1.1 client
   6 our $VERSION = '0.016'; # VERSION
   7
   8 use Carp ();
   9
  10
  11 my @attributes;
  12 BEGIN {
  13     @attributes = qw(agent default_headers max_redirect max_size proxy timeout);
  14     no strict 'refs';
  15     for my $accessor ( @attributes ) {
  16         *{$accessor} = sub {
  17             @_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor};
  18         };
  19     }
  20 }
  21
  22 sub new {
  23     my($class, %args) = @_;
  24     (my $agent = $class) =~ s{::}{-}g;
  25     my $self = {
  26         agent        => $agent . "/" . ($class->VERSION || 0),
  27         max_redirect => 5,
  28         timeout      => 60,
  29     };
  30     for my $key ( @attributes ) {
  31         $self->{$key} = $args{$key} if exists $args{$key}
  32     }
  33
  34     # Never override proxy argument as this breaks backwards compat.
  35     if (!exists $self->{proxy} && (my $http_proxy = $ENV{http_proxy})) {
  36         if ($http_proxy =~ m{\Ahttp://[^/?#:@]+:\d+/?\z}) {
  37             $self->{proxy} = $http_proxy;
  38         }
  39         else {
  40             Carp::croak(qq{Environment 'http_proxy' must be in format http://<host>:<port>/\n});
  41         }
  42     }
  43
  44     return bless $self, $class;
  45 }
  46
  47
  48 for my $sub_name ( qw/get head put post delete/ ) {
  49     my $req_method = uc $sub_name;
  50     no strict 'refs';
  51     eval <<"HERE";
  52     sub $sub_name {
  53         my (\$self, \$url, \$args) = \@_;
  54         \@_ == 2 || (\@_ == 3 && ref \$args eq 'HASH')
  55         or Carp::croak(q/Usage: \$http->$sub_name(URL, [HASHREF])/ . "\n");
  56         return \$self->request('$req_method', \$url, \$args || {});
  57     }
  58 HERE
  59 }
  60
  61
  62 sub post_form {
  63     my ($self, $url, $data, $args) = @_;
  64     (@_ == 3 || @_ == 4 && ref $args eq 'HASH')
  65         or Carp::croak(q/Usage: $http->post_form(URL, DATAREF, [HASHREF])/ . "\n");
  66
  67     my $headers = {};
  68     while ( my ($key, $value) = each %{$args->{headers} || {}} ) {
  69         $headers->{lc $key} = $value;
  70     }
  71     delete $args->{headers};
  72
  73     return $self->request('POST', $url, {
  74             %$args,
  75             content => $self->www_form_urlencode($data),
  76             headers => {
  77                 %$headers,
  78                 'content-type' => 'application/x-www-form-urlencoded'
  79             },
  80         }
  81     );
  82 }
  83
  84
  85 sub mirror {
  86     my ($self, $url, $file, $args) = @_;
  87     @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
  88       or Carp::croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ . "\n");
  89     if ( -e $file and my $mtime = (stat($file))[9] ) {
  90         $args->{headers}{'if-modified-since'} ||= $self->_http_date($mtime);
  91     }
  92     my $tempfile = $file . int(rand(2**31));
  93     open my $fh, ">", $tempfile
  94         or Carp::croak(qq/Error: Could not open temporary file $tempfile for downloading: $!\n/);
  95     binmode $fh;
  96     $args->{data_callback} = sub { print {$fh} $_[0] };
  97     my $response = $self->request('GET', $url, $args);
  98     close $fh
  99         or Carp::croak(qq/Error: Could not close temporary file $tempfile: $!\n/);
 100     if ( $response->{success} ) {
 101         rename $tempfile, $file
 102             or Carp::croak(qq/Error replacing $file with $tempfile: $!\n/);
 103         my $lm = $response->{headers}{'last-modified'};
 104         if ( $lm and my $mtime = $self->_parse_http_date($lm) ) {
 105             utime $mtime, $mtime, $file;
 106         }
 107     }
 108     $response->{success} ||= $response->{status} eq '304';
 109     unlink $tempfile;
 110     return $response;
 111 }
 112
 113
 114 my %idempotent = map { $_ => 1 } qw/GET HEAD PUT DELETE OPTIONS TRACE/;
 115
 116 sub request {
 117     my ($self, $method, $url, $args) = @_;
 118     @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
 119       or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/ . "\n");
 120     $args ||= {}; # we keep some state in this during _request
 121
 122     # RFC 2616 Section 8.1.4 mandates a single retry on broken socket
 123     my $response;
 124     for ( 0 .. 1 ) {
 125         $response = eval { $self->_request($method, $url, $args) };
 126         last unless $@ && $idempotent{$method}
 127             && $@ =~ m{^(?:Socket closed|Unexpected end)};
 128     }
 129
 130     if (my $e = "$@") {
 131         $response = {
 132             success => q{},
 133             status  => 599,
 134             reason  => 'Internal Exception',
 135             content => $e,
 136             headers => {
 137                 'content-type'   => 'text/plain',
 138                 'content-length' => length $e,
 139             }
 140         };
 141     }
 142     return $response;
 143 }
 144
 145
 146 sub www_form_urlencode {
 147     my ($self, $data) = @_;
 148     (@_ == 2 && ref $data)
 149         or Carp::croak(q/Usage: $http->www_form_urlencode(DATAREF)/ . "\n");
 150     (ref $data eq 'HASH' || ref $data eq 'ARRAY')
 151         or Carp::croak("form data must be a hash or array reference");
 152
 153     my @params = ref $data eq 'HASH' ? %$data : @$data;
 154     @params % 2 == 0
 155         or Carp::croak("form data reference must have an even number of terms\n");
 156
 157     my @terms;
 158     while( @params ) {
 159         my ($key, $value) = splice(@params, 0, 2);
 160         if ( ref $value eq 'ARRAY' ) {
 161             unshift @params, map { $key => $_ } @$value;
 162         }
 163         else {
 164             push @terms, join("=", map { $self->_uri_escape($_) } $key, $value);
 165         }
 166     }
 167
 168     return join("&", sort @terms);
 169 }
 170
 171 #--------------------------------------------------------------------------#
 172 # private methods
 173 #--------------------------------------------------------------------------#
 174
 175 my %DefaultPort = (
 176     http => 80,
 177     https => 443,
 178 );
 179
 180 sub _request {
 181     my ($self, $method, $url, $args) = @_;
 182
 183     my ($scheme, $host, $port, $path_query) = $self->_split_url($url);
 184
 185     my $request = {
 186         method    => $method,
 187         scheme    => $scheme,
 188         host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
 189         uri       => $path_query,
 190         headers   => {},
 191     };
 192
 193     my $handle  = HTTP::Tiny::Handle->new(timeout => $self->{timeout});
 194
 195     if ($self->{proxy}) {
 196         $request->{uri} = "$scheme://$request->{host_port}$path_query";
 197         die(qq/HTTPS via proxy is not supported\n/)
 198             if $request->{scheme} eq 'https';
 199         $handle->connect(($self->_split_url($self->{proxy}))[0..2]);
 200     }
 201     else {
 202         $handle->connect($scheme, $host, $port);
 203     }
 204
 205     $self->_prepare_headers_and_cb($request, $args);
 206     $handle->write_request($request);
 207
 208     my $response;
 209     do { $response = $handle->read_response_header }
 210         until (substr($response->{status},0,1) ne '1');
 211
 212     if ( my @redir_args = $self->_maybe_redirect($request, $response, $args) ) {
 213         $handle->close;
 214         return $self->_request(@redir_args, $args);
 215     }
 216
 217     if ($method eq 'HEAD' || $response->{status} =~ /^[23]04/) {
 218         # response has no message body
 219     }
 220     else {
 221         my $data_cb = $self->_prepare_data_cb($response, $args);
 222         $handle->read_body($data_cb, $response);
 223     }
 224
 225     $handle->close;
 226     $response->{success} = substr($response->{status},0,1) eq '2';
 227     return $response;
 228 }
 229
 230 sub _prepare_headers_and_cb {
 231     my ($self, $request, $args) = @_;
 232
 233     for ($self->{default_headers}, $args->{headers}) {
 234         next unless defined;
 235         while (my ($k, $v) = each %$_) {
 236             $request->{headers}{lc $k} = $v;
 237         }
 238     }
 239     $request->{headers}{'host'}         = $request->{host_port};
 240     $request->{headers}{'connection'}   = "close";
 241     $request->{headers}{'user-agent'} ||= $self->{agent};
 242
 243     if (defined $args->{content}) {
 244         $request->{headers}{'content-type'} ||= "application/octet-stream";
 245         if (ref $args->{content} eq 'CODE') {
 246             $request->{headers}{'transfer-encoding'} = 'chunked'
 247               unless $request->{headers}{'content-length'}
 248                   || $request->{headers}{'transfer-encoding'};
 249             $request->{cb} = $args->{content};
 250         }
 251         else {
 252             my $content = $args->{content};
 253             if ( $] ge '5.008' ) {
 254                 utf8::downgrade($content, 1)
 255                     or die(qq/Wide character in request message body\n/);
 256             }
 257             $request->{headers}{'content-length'} = length $content
 258               unless $request->{headers}{'content-length'}
 259                   || $request->{headers}{'transfer-encoding'};
 260             $request->{cb} = sub { substr $content, 0, length $content, '' };
 261         }
 262         $request->{trailer_cb} = $args->{trailer_callback}
 263             if ref $args->{trailer_callback} eq 'CODE';
 264     }
 265     return;
 266 }
 267
 268 sub _prepare_data_cb {
 269     my ($self, $response, $args) = @_;
 270     my $data_cb = $args->{data_callback};
 271     $response->{content} = '';
 272
 273     if (!$data_cb || $response->{status} !~ /^2/) {
 274         if (defined $self->{max_size}) {
 275             $data_cb = sub {
 276                 $_[1]->{content} .= $_[0];
 277                 die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/)
 278                   if length $_[1]->{content} > $self->{max_size};
 279             };
 280         }
 281         else {
 282             $data_cb = sub { $_[1]->{content} .= $_[0] };
 283         }
 284     }
 285     return $data_cb;
 286 }
 287
 288 sub _maybe_redirect {
 289     my ($self, $request, $response, $args) = @_;
 290     my $headers = $response->{headers};
 291     my ($status, $method) = ($response->{status}, $request->{method});
 292     if (($status eq '303' or ($status =~ /^30[127]/ && $method =~ /^GET|HEAD$/))
 293         and $headers->{location}
 294         and ++$args->{redirects} <= $self->{max_redirect}
 295     ) {
 296         my $location = ($headers->{location} =~ /^\//)
 297             ? "$request->{scheme}://$request->{host_port}$headers->{location}"
 298             : $headers->{location} ;
 299         return (($status eq '303' ? 'GET' : $method), $location);
 300     }
 301     return;
 302 }
 303
 304 sub _split_url {
 305     my $url = pop;
 306
 307     # URI regex adapted from the URI module
 308     my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
 309       or die(qq/Cannot parse URL: '$url'\n/);
 310
 311     $scheme     = lc $scheme;
 312     $path_query = "/$path_query" unless $path_query =~ m<\A/>;
 313
 314     my $host = (length($authority)) ? lc $authority : 'localhost';
 315        $host =~ s/\A[^@]*@//;   # userinfo
 316     my $port = do {
 317        $host =~ s/:([0-9]*)\z// && length $1
 318          ? $1
 319          : ($scheme eq 'http' ? 80 : $scheme eq 'https' ? 443 : undef);
 320     };
 321
 322     return ($scheme, $host, $port, $path_query);
 323 }
 324
 325 # Date conversions adapted from HTTP::Date
 326 my $DoW = "Sun|Mon|Tue|Wed|Thu|Fri|Sat";
 327 my $MoY = "Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec";
 328 sub _http_date {
 329     my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($_[1]);
 330     return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
 331         substr($DoW,$wday*4,3),
 332         $mday, substr($MoY,$mon*4,3), $year+1900,
 333         $hour, $min, $sec
 334     );
 335 }
 336
 337 sub _parse_http_date {
 338     my ($self, $str) = @_;
 339     require Time::Local;
 340     my @tl_parts;
 341     if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) {
 342         @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
 343     }
 344     elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) {
 345         @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
 346     }
 347     elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) {
 348         @tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6);
 349     }
 350     return eval {
 351         my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1;
 352         $t < 0 ? undef : $t;
 353     };
 354 }
 355
 356 # URI escaping adapted from URI::Escape
 357 # c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1
 358 # perl 5.6 ready UTF-8 encoding adapted from JSON::PP
 359 my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
 360 $escapes{' '}="+";
 361 my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/;
 362
 363 sub _uri_escape {
 364     my ($self, $str) = @_;
 365     if ( $] ge '5.008' ) {
 366         utf8::encode($str);
 367     }
 368     else {
 369         $str = pack("U*", unpack("C*", $str)) # UTF-8 encode a byte string
 370             if ( length $str == do { use bytes; length $str } );
 371         $str = pack("C*", unpack("C*", $str)); # clear UTF-8 flag
 372     }
 373     $str =~ s/($unsafe_char)/$escapes{$1}/ge;
 374     return $str;
 375 }
 376
 377 package
 378     HTTP::Tiny::Handle; # hide from PAUSE/indexers
 379 use strict;
 380 use warnings;
 381
 382 use Errno      qw[EINTR EPIPE];
 383 use IO::Socket qw[SOCK_STREAM];
 384
 385 sub BUFSIZE () { 32768 }
 386
 387 my $Printable = sub {
 388     local $_ = shift;
 389     s/\r/\\r/g;
 390     s/\n/\\n/g;
 391     s/\t/\\t/g;
 392     s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
 393     $_;
 394 };
 395
 396 my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
 397
 398 sub new {
 399     my ($class, %args) = @_;
 400     return bless {
 401         rbuf             => '',
 402         timeout          => 60,
 403         max_line_size    => 16384,
 404         max_header_lines => 64,
 405         %args
 406     }, $class;
 407 }
 408
 409 my $ssl_verify_args = {
 410     check_cn => "when_only",
 411     wildcards_in_alt => "anywhere",
 412     wildcards_in_cn => "anywhere"
 413 };
 414
 415 sub connect {
 416     @_ == 4 || die(q/Usage: $handle->connect(scheme, host, port)/ . "\n");
 417     my ($self, $scheme, $host, $port) = @_;
 418
 419     if ( $scheme eq 'https' ) {
 420         eval "require IO::Socket::SSL"
 421             unless exists $INC{'IO/Socket/SSL.pm'};
 422         die(qq/IO::Socket::SSL must be installed for https support\n/)
 423             unless $INC{'IO/Socket/SSL.pm'};
 424     }
 425     elsif ( $scheme ne 'http' ) {
 426       die(qq/Unsupported URL scheme '$scheme'\n/);
 427     }
 428
 429     $self->{fh} = 'IO::Socket::INET'->new(
 430         PeerHost  => $host,
 431         PeerPort  => $port,
 432         Proto     => 'tcp',
 433         Type      => SOCK_STREAM,
 434         Timeout   => $self->{timeout}
 435     ) or die(qq/Could not connect to '$host:$port': $@\n/);
 436
 437     binmode($self->{fh})
 438       or die(qq/Could not binmode() socket: '$!'\n/);
 439
 440     if ( $scheme eq 'https') {
 441         IO::Socket::SSL->start_SSL($self->{fh});
 442         ref($self->{fh}) eq 'IO::Socket::SSL'
 443             or die(qq/SSL connection failed for $host\n/);
 444         $self->{fh}->verify_hostname( $host, $ssl_verify_args )
 445             or die(qq/SSL certificate not valid for $host\n/);
 446     }
 447
 448     $self->{host} = $host;
 449     $self->{port} = $port;
 450
 451     return $self;
 452 }
 453
 454 sub close {
 455     @_ == 1 || die(q/Usage: $handle->close()/ . "\n");
 456     my ($self) = @_;
 457     CORE::close($self->{fh})
 458       or die(qq/Could not close socket: '$!'\n/);
 459 }
 460
 461 sub write {
 462     @_ == 2 || die(q/Usage: $handle->write(buf)/ . "\n");
 463     my ($self, $buf) = @_;
 464
 465     if ( $] ge '5.008' ) {
 466         utf8::downgrade($buf, 1)
 467             or die(qq/Wide character in write()\n/);
 468     }
 469
 470     my $len = length $buf;
 471     my $off = 0;
 472
 473     local $SIG{PIPE} = 'IGNORE';
 474
 475     while () {
 476         $self->can_write
 477           or die(qq/Timed out while waiting for socket to become ready for writing\n/);
 478         my $r = syswrite($self->{fh}, $buf, $len, $off);
 479         if (defined $r) {
 480             $len -= $r;
 481             $off += $r;
 482             last unless $len > 0;
 483         }
 484         elsif ($! == EPIPE) {
 485             die(qq/Socket closed by remote server: $!\n/);
 486         }
 487         elsif ($! != EINTR) {
 488             die(qq/Could not write to socket: '$!'\n/);
 489         }
 490     }
 491     return $off;
 492 }
 493
 494 sub read {
 495     @_ == 2 || @_ == 3 || die(q/Usage: $handle->read(len [, allow_partial])/ . "\n");
 496     my ($self, $len, $allow_partial) = @_;
 497
 498     my $buf  = '';
 499     my $got = length $self->{rbuf};
 500
 501     if ($got) {
 502         my $take = ($got < $len) ? $got : $len;
 503         $buf  = substr($self->{rbuf}, 0, $take, '');
 504         $len -= $take;
 505     }
 506
 507     while ($len > 0) {
 508         $self->can_read
 509           or die(q/Timed out while waiting for socket to become ready for reading/ . "\n");
 510         my $r = sysread($self->{fh}, $buf, $len, length $buf);
 511         if (defined $r) {
 512             last unless $r;
 513             $len -= $r;
 514         }
 515         elsif ($! != EINTR) {
 516             die(qq/Could not read from socket: '$!'\n/);
 517         }
 518     }
 519     if ($len && !$allow_partial) {
 520         die(qq/Unexpected end of stream\n/);
 521     }
 522     return $buf;
 523 }
 524
 525 sub readline {
 526     @_ == 1 || die(q/Usage: $handle->readline()/ . "\n");
 527     my ($self) = @_;
 528
 529     while () {
 530         if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
 531             return $1;
 532         }
 533         if (length $self->{rbuf} >= $self->{max_line_size}) {
 534             die(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}\n/);
 535         }
 536         $self->can_read
 537           or die(qq/Timed out while waiting for socket to become ready for reading\n/);
 538         my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
 539         if (defined $r) {
 540             last unless $r;
 541         }
 542         elsif ($! != EINTR) {
 543             die(qq/Could not read from socket: '$!'\n/);
 544         }
 545     }
 546     die(qq/Unexpected end of stream while looking for line\n/);
 547 }
 548
 549 sub read_header_lines {
 550     @_ == 1 || @_ == 2 || die(q/Usage: $handle->read_header_lines([headers])/ . "\n");
 551     my ($self, $headers) = @_;
 552     $headers ||= {};
 553     my $lines   = 0;
 554     my $val;
 555
 556     while () {
 557          my $line = $self->readline;
 558
 559          if (++$lines >= $self->{max_header_lines}) {
 560              die(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}\n/);
 561          }
 562          elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
 563              my ($field_name) = lc $1;
 564              if (exists $headers->{$field_name}) {
 565                  for ($headers->{$field_name}) {
 566                      $_ = [$_] unless ref $_ eq "ARRAY";
 567                      push @$_, $2;
 568                      $val = \$_->[-1];
 569                  }
 570              }
 571              else {
 572                  $val = \($headers->{$field_name} = $2);
 573              }
 574          }
 575          elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
 576              $val
 577                or die(qq/Unexpected header continuation line\n/);
 578              next unless length $1;
 579              $$val .= ' ' if length $$val;
 580              $$val .= $1;
 581          }
 582          elsif ($line =~ /\A \x0D?\x0A \z/x) {
 583             last;
 584          }
 585          else {
 586             die(q/Malformed header line: / . $Printable->($line) . "\n");
 587          }
 588     }
 589     return $headers;
 590 }
 591
 592 sub write_request {
 593     @_ == 2 || die(q/Usage: $handle->write_request(request)/ . "\n");
 594     my($self, $request) = @_;
 595     $self->write_request_header(@{$request}{qw/method uri headers/});
 596     $self->write_body($request) if $request->{cb};
 597     return;
 598 }
 599
 600 my %HeaderCase = (
 601     'content-md5'      => 'Content-MD5',
 602     'etag'             => 'ETag',
 603     'te'               => 'TE',
 604     'www-authenticate' => 'WWW-Authenticate',
 605     'x-xss-protection' => 'X-XSS-Protection',
 606 );
 607
 608 sub write_header_lines {
 609     (@_ == 2 && ref $_[1] eq 'HASH') || die(q/Usage: $handle->write_header_lines(headers)/ . "\n");
 610     my($self, $headers) = @_;
 611
 612     my $buf = '';
 613     while (my ($k, $v) = each %$headers) {
 614         my $field_name = lc $k;
 615         if (exists $HeaderCase{$field_name}) {
 616             $field_name = $HeaderCase{$field_name};
 617         }
 618         else {
 619             $field_name =~ /\A $Token+ \z/xo
 620               or die(q/Invalid HTTP header field name: / . $Printable->($field_name) . "\n");
 621             $field_name =~ s/\b(\w)/\u$1/g;
 622             $HeaderCase{lc $field_name} = $field_name;
 623         }
 624         for (ref $v eq 'ARRAY' ? @$v : $v) {
 625             /[^\x0D\x0A]/
 626               or die(qq/Invalid HTTP header field value ($field_name): / . $Printable->($_). "\n");
 627             $buf .= "$field_name: $_\x0D\x0A";
 628         }
 629     }
 630     $buf .= "\x0D\x0A";
 631     return $self->write($buf);
 632 }
 633
 634 sub read_body {
 635     @_ == 3 || die(q/Usage: $handle->read_body(callback, response)/ . "\n");
 636     my ($self, $cb, $response) = @_;
 637     my $te = $response->{headers}{'transfer-encoding'} || '';
 638     if ( grep { /chunked/i } ( ref $te eq 'ARRAY' ? @$te : $te ) ) {
 639         $self->read_chunked_body($cb, $response);
 640     }
 641     else {
 642         $self->read_content_body($cb, $response);
 643     }
 644     return;
 645 }
 646
 647 sub write_body {
 648     @_ == 2 || die(q/Usage: $handle->write_body(request)/ . "\n");
 649     my ($self, $request) = @_;
 650     if ($request->{headers}{'content-length'}) {
 651         return $self->write_content_body($request);
 652     }
 653     else {
 654         return $self->write_chunked_body($request);
 655     }
 656 }
 657
 658 sub read_content_body {
 659     @_ == 3 || @_ == 4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ . "\n");
 660     my ($self, $cb, $response, $content_length) = @_;
 661     $content_length ||= $response->{headers}{'content-length'};
 662
 663     if ( $content_length ) {
 664         my $len = $content_length;
 665         while ($len > 0) {
 666             my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
 667             $cb->($self->read($read, 0), $response);
 668             $len -= $read;
 669         }
 670     }
 671     else {
 672         my $chunk;
 673         $cb->($chunk, $response) while length( $chunk = $self->read(BUFSIZE, 1) );
 674     }
 675
 676     return;
 677 }
 678
 679 sub write_content_body {
 680     @_ == 2 || die(q/Usage: $handle->write_content_body(request)/ . "\n");
 681     my ($self, $request) = @_;
 682
 683     my ($len, $content_length) = (0, $request->{headers}{'content-length'});
 684     while () {
 685         my $data = $request->{cb}->();
 686
 687         defined $data && length $data
 688           or last;
 689
 690         if ( $] ge '5.008' ) {
 691             utf8::downgrade($data, 1)
 692                 or die(qq/Wide character in write_content()\n/);
 693         }
 694
 695         $len += $self->write($data);
 696     }
 697
 698     $len == $content_length
 699       or die(qq/Content-Length missmatch (got: $len expected: $content_length)\n/);
 700
 701     return $len;
 702 }
 703
 704 sub read_chunked_body {
 705     @_ == 3 || die(q/Usage: $handle->read_chunked_body(callback, $response)/ . "\n");
 706     my ($self, $cb, $response) = @_;
 707
 708     while () {
 709         my $head = $self->readline;
 710
 711         $head =~ /\A ([A-Fa-f0-9]+)/x
 712           or die(q/Malformed chunk head: / . $Printable->($head) . "\n");
 713
 714         my $len = hex($1)
 715           or last;
 716
 717         $self->read_content_body($cb, $response, $len);
 718
 719         $self->read(2) eq "\x0D\x0A"
 720           or die(qq/Malformed chunk: missing CRLF after chunk data\n/);
 721     }
 722     $self->read_header_lines($response->{headers});
 723     return;
 724 }
 725
 726 sub write_chunked_body {
 727     @_ == 2 || die(q/Usage: $handle->write_chunked_body(request)/ . "\n");
 728     my ($self, $request) = @_;
 729
 730     my $len = 0;
 731     while () {
 732         my $data = $request->{cb}->();
 733
 734         defined $data && length $data
 735           or last;
 736
 737         if ( $] ge '5.008' ) {
 738             utf8::downgrade($data, 1)
 739                 or die(qq/Wide character in write_chunked_body()\n/);
 740         }
 741
 742         $len += length $data;
 743
 744         my $chunk  = sprintf '%X', length $data;
 745            $chunk .= "\x0D\x0A";
 746            $chunk .= $data;
 747            $chunk .= "\x0D\x0A";
 748
 749         $self->write($chunk);
 750     }
 751     $self->write("0\x0D\x0A");
 752     $self->write_header_lines($request->{trailer_cb}->())
 753         if ref $request->{trailer_cb} eq 'CODE';
 754     return $len;
 755 }
 756
 757 sub read_response_header {
 758     @_ == 1 || die(q/Usage: $handle->read_response_header()/ . "\n");
 759     my ($self) = @_;
 760
 761     my $line = $self->readline;
 762
 763     $line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
 764       or die(q/Malformed Status-Line: / . $Printable->($line). "\n");
 765
 766     my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
 767
 768     die (qq/Unsupported HTTP protocol: $protocol\n/)
 769         unless $version =~ /0*1\.0*[01]/;
 770
 771     return {
 772         status   => $status,
 773         reason   => $reason,
 774         headers  => $self->read_header_lines,
 775         protocol => $protocol,
 776     };
 777 }
 778
 779 sub write_request_header {
 780     @_ == 4 || die(q/Usage: $handle->write_request_header(method, request_uri, headers)/ . "\n");
 781     my ($self, $method, $request_uri, $headers) = @_;
 782
 783     return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
 784          + $self->write_header_lines($headers);
 785 }
 786
 787 sub _do_timeout {
 788     my ($self, $type, $timeout) = @_;
 789     $timeout = $self->{timeout}
 790         unless defined $timeout && $timeout >= 0;
 791
 792     my $fd = fileno $self->{fh};
 793     defined $fd && $fd >= 0
 794       or die(qq/select(2): 'Bad file descriptor'\n/);
 795
 796     my $initial = time;
 797     my $pending = $timeout;
 798     my $nfound;
 799
 800     vec(my $fdset = '', $fd, 1) = 1;
 801
 802     while () {
 803         $nfound = ($type eq 'read')
 804             ? select($fdset, undef, undef, $pending)
 805             : select(undef, $fdset, undef, $pending) ;
 806         if ($nfound == -1) {
 807             $! == EINTR
 808               or die(qq/select(2): '$!'\n/);
 809             redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
 810             $nfound = 0;
 811         }
 812         last;
 813     }
 814     $! = 0;
 815     return $nfound;
 816 }
 817
 818 sub can_read {
 819     @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_read([timeout])/ . "\n");
 820     my $self = shift;
 821     return $self->_do_timeout('read', @_)
 822 }
 823
 824 sub can_write {
 825     @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_write([timeout])/ . "\n");
 826     my $self = shift;
 827     return $self->_do_timeout('write', @_)
 828 }
 829
 830 1;
 831
 832
 833
 834 __END__
 835 =pod
 836
 837 =head1 NAME
 838
 839 HTTP::Tiny - A small, simple, correct HTTP/1.1 client
 840
 841 =head1 VERSION
 842
 843 version 0.016
 844
 845 =head1 SYNOPSIS
 846
 847     use HTTP::Tiny;
 848
 849     my $response = HTTP::Tiny->new->get('http://example.com/');
 850
 851     die "Failed!\n" unless $response->{success};
 852
 853     print "$response->{status} $response->{reason}\n";
 854
 855     while (my ($k, $v) = each %{$response->{headers}}) {
 856         for (ref $v eq 'ARRAY' ? @$v : $v) {
 857             print "$k: $_\n";
 858         }
 859     }
 860
 861     print $response->{content} if length $response->{content};
 862
 863 =head1 DESCRIPTION
 864
 865 This is a very simple HTTP/1.1 client, designed for doing simple GET
 866 requests without the overhead of a large framework like L<LWP::UserAgent>.
 867
 868 It is more correct and more complete than L<HTTP::Lite>.  It supports
 869 proxies (currently only non-authenticating ones) and redirection.  It
 870 also correctly resumes after EINTR.
 871
 872 =head1 METHODS
 873
 874 =head2 new
 875
 876     $http = HTTP::Tiny->new( %attributes );
 877
 878 This constructor returns a new HTTP::Tiny object.  Valid attributes include:
 879
 880 =over 4
 881
 882 =item *
 883
 884 agent
 885
 886 A user-agent string (defaults to 'HTTP::Tiny/$VERSION')
 887
 888 =item *
 889
 890 default_headers
 891
 892 A hashref of default headers to apply to requests
 893
 894 =item *
 895
 896 max_redirect
 897
 898 Maximum number of redirects allowed (defaults to 5)
 899
 900 =item *
 901
 902 max_size
 903
 904 Maximum response size (only when not using a data callback).  If defined,
 905 responses larger than this will die with an error message
 906
 907 =item *
 908
 909 proxy
 910
 911 URL of a proxy server to use (default is C<$ENV{http_proxy}> if set)
 912
 913 =item *
 914
 915 timeout
 916
 917 Request timeout in seconds (default is 60)
 918
 919 =back
 920
 921 =head2 get|head|put|post|delete
 922
 923     $response = $http->get($url);
 924     $response = $http->get($url, \%options);
 925     $response = $http->head($url);
 926
 927 These methods are shorthand for calling C<request()> for the given method.  The
 928 URL must have unsafe characters escaped and international domain names encoded.
 929 See C<request()> for valid options and a description of the response.
 930
 931 =head2 post_form
 932
 933     $response = $http->post_form($url, $form_data);
 934     $response = $http->post_form($url, $form_data, \%options);
 935
 936 This method executes a C<POST> request and sends the key/value pairs from a
 937 form data hash or array reference to the given URL with a C<content-type> of
 938 C<application/x-www-form-urlencoded>.  See documentation for the
 939 C<www_form_urlencode> method for details on the encoding.
 940
 941 The URL must have unsafe characters escaped and international domain names
 942 encoded.  See C<request()> for valid options and a description of the response.
 943 Any C<content-type> header or content in the options hashref will be ignored.
 944
 945 =head2 mirror
 946
 947     $response = $http->mirror($url, $file, \%options)
 948     if ( $response->{success} ) {
 949         print "$file is up to date\n";
 950     }
 951
 952 Executes a C<GET> request for the URL and saves the response body to the file
 953 name provided.  The URL must have unsafe characters escaped and international
 954 domain names encoded.  If the file already exists, the request will includes an
 955 C<If-Modified-Since> header with the modification timestamp of the file.  You
 956 may specificy a different C<If-Modified-Since> header yourself in the C<<
 957 $options->{headers} >> hash.
 958
 959 The C<success> field of the response will be true if the status code is 2XX
 960 or 304 (unmodified).
 961
 962 If the file was modified and the server response includes a properly
 963 formatted C<Last-Modified> header, the file modification time will
 964 be updated accordingly.
 965
 966 =head2 request
 967
 968     $response = $http->request($method, $url);
 969     $response = $http->request($method, $url, \%options);
 970
 971 Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST',
 972 'PUT', etc.) on the given URL.  The URL must have unsafe characters escaped and
 973 international domain names encoded.  A hashref of options may be appended to
 974 modify the request.
 975
 976 Valid options are:
 977
 978 =over 4
 979
 980 =item *
 981
 982 headers
 983
 984 A hashref containing headers to include with the request.  If the value for
 985 a header is an array reference, the header will be output multiple times with
 986 each value in the array.  These headers over-write any default headers.
 987
 988 =item *
 989
 990 content
 991
 992 A scalar to include as the body of the request OR a code reference
 993 that will be called iteratively to produce the body of the response
 994
 995 =item *
 996
 997 trailer_callback
 998
 999 A code reference that will be called if it exists to provide a hashref
1000 of trailing headers (only used with chunked transfer-encoding)
1001
1002 =item *
1003
1004 data_callback
1005
1006 A code reference that will be called for each chunks of the response
1007 body received.
1008
1009 =back
1010
1011 If the C<content> option is a code reference, it will be called iteratively
1012 to provide the content body of the request.  It should return the empty
1013 string or undef when the iterator is exhausted.
1014
1015 If the C<data_callback> option is provided, it will be called iteratively until
1016 the entire response body is received.  The first argument will be a string
1017 containing a chunk of the response body, the second argument will be the
1018 in-progress response hash reference, as described below.  (This allows
1019 customizing the action of the callback based on the C<status> or C<headers>
1020 received prior to the content body.)
1021
1022 The C<request> method returns a hashref containing the response.  The hashref
1023 will have the following keys:
1024
1025 =over 4
1026
1027 =item *
1028
1029 success
1030
1031 Boolean indicating whether the operation returned a 2XX status code
1032
1033 =item *
1034
1035 status
1036
1037 The HTTP status code of the response
1038
1039 =item *
1040
1041 reason
1042
1043 The response phrase returned by the server
1044
1045 =item *
1046
1047 content
1048
1049 The body of the response.  If the response does not have any content
1050 or if a data callback is provided to consume the response body,
1051 this will be the empty string
1052
1053 =item *
1054
1055 headers
1056
1057 A hashref of header fields.  All header field names will be normalized
1058 to be lower case. If a header is repeated, the value will be an arrayref;
1059 it will otherwise be a scalar string containing the value
1060
1061 =back
1062
1063 On an exception during the execution of the request, the C<status> field will
1064 contain 599, and the C<content> field will contain the text of the exception.
1065
1066 =head2 www_form_urlencode
1067
1068     $params = $http->www_form_urlencode( $data );
1069     $response = $http->get("http://example.com/query?$params");
1070
1071 This method converts the key/value pairs from a data hash or array reference
1072 into a C<x-www-form-urlencoded> string.  The keys and values from the data
1073 reference will be UTF-8 encoded and escaped per RFC 3986.  If a value is an
1074 array reference, the key will be repeated with each of the values of the array
1075 reference.  The key/value pairs in the resulting string will be sorted by key
1076 and value.
1077
1078 =for Pod::Coverage agent
1079 default_headers
1080 max_redirect
1081 max_size
1082 proxy
1083 timeout
1084
1085 =head1 LIMITATIONS
1086
1087 HTTP::Tiny is I<conditionally compliant> with the
1088 L<HTTP/1.1 specification|http://www.w3.org/Protocols/rfc2616/rfc2616.html>.
1089 It attempts to meet all "MUST" requirements of the specification, but does not
1090 implement all "SHOULD" requirements.
1091
1092 Some particular limitations of note include:
1093
1094 =over
1095
1096 =item *
1097
1098 HTTP::Tiny focuses on correct transport.  Users are responsible for ensuring
1099 that user-defined headers and content are compliant with the HTTP/1.1
1100 specification.
1101
1102 =item *
1103
1104 Users must ensure that URLs are properly escaped for unsafe characters and that
1105 international domain names are properly encoded to ASCII. See L<URI::Escape>,
1106 L<URI::_punycode> and L<Net::IDN::Encode>.
1107
1108 =item *
1109
1110 Redirection is very strict against the specification.  Redirection is only
1111 automatic for response codes 301, 302 and 307 if the request method is 'GET' or
1112 'HEAD'.  Response code 303 is always converted into a 'GET' redirection, as
1113 mandated by the specification.  There is no automatic support for status 305
1114 ("Use proxy") redirections.
1115
1116 =item *
1117
1118 Persistent connections are not supported.  The C<Connection> header will
1119 always be set to C<close>.
1120
1121 =item *
1122
1123 Direct C<https> connections are supported only if L<IO::Socket::SSL> is
1124 installed.  There is no support for C<https> connections via proxy.
1125 Any SSL certificate that matches the host is accepted -- SSL certificates
1126 are not verified against certificate authorities.
1127
1128 =item *
1129
1130 Cookies are not directly supported.  Users that set a C<Cookie> header
1131 should also set C<max_redirect> to zero to ensure cookies are not
1132 inappropriately re-transmitted.
1133
1134 =item *
1135
1136 Only the C<http_proxy> environment variable is supported in the format
1137 C<http://HOST:PORT/>.  If a C<proxy> argument is passed to C<new> (including
1138 undef), then the C<http_proxy> environment variable is ignored.
1139
1140 =item *
1141
1142 There is no provision for delaying a request body using an C<Expect> header.
1143 Unexpected C<1XX> responses are silently ignored as per the specification.
1144
1145 =item *
1146
1147 Only 'chunked' C<Transfer-Encoding> is supported.
1148
1149 =item *
1150
1151 There is no support for a Request-URI of '*' for the 'OPTIONS' request.
1152
1153 =back
1154
1155 =head1 SEE ALSO
1156
1157 =over 4
1158
1159 =item *
1160
1161 L<LWP::UserAgent>
1162
1163 =back
1164
1165 =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders
1166
1167 =head1 SUPPORT
1168
1169 =head2 Bugs / Feature Requests
1170
1171 Please report any bugs or feature requests by email to C<bug-http-tiny at rt.cpan.org>, or through
1172 the web interface at L<http://rt.cpan.org/Public/Dist/Display.html?Name=HTTP-Tiny>. You will be automatically notified of any
1173 progress on the request by the system.
1174
1175 =head2 Source Code
1176
1177 This is open source software.  The code repository is available for
1178 public review and contribution under the terms of the license.
1179
1180 L<https://github.com/dagolden/p5-http-tiny>
1181
1182   git clone https://github.com/dagolden/p5-http-tiny.git
1183
1184 =head1 AUTHORS
1185
1186 =over 4
1187
1188 =item *
1189
1190 Christian Hansen <chansen@cpan.org>
1191
1192 =item *
1193
1194 David Golden <dagolden@cpan.org>
1195
1196 =back
1197
1198 =head1 COPYRIGHT AND LICENSE
1199
1200 This software is copyright (c) 2011 by Christian Hansen.
1201
1202 This is free software; you can redistribute it and/or modify it under
1203 the same terms as the Perl 5 programming language system itself.
1204
1205 =cut
1206