PERL   32

Tiny save

Guest on 7th July 2022 08:14:29 AM

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

Raw Paste


Login or Register to edit or fork this paste. It's free.