import perl 5.16.3 from CPAN - worked on by Andrew Fresh and myself

1 files changed, 1214 insertions, 0 deletions

diff --git a/gnu/usr.bin/perl/cpan/HTTP-Tiny/lib/HTTP/Tiny.pm b/gnu/usr.bin/perl/cpan/HTTP-Tiny/lib/HTTP/Tiny.pm
new file mode 100644
index 00000000000..46dce742e38
--- /dev/null
+++ b/gnu/usr.bin/perl/cpan/HTTP-Tiny/lib/HTTP/Tiny.pm
@@ -0,0 +1,1214 @@
+# 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.017'; # VERSION
+
+use Carp ();
+
+
+my @attributes;
+BEGIN {
+    @attributes = qw(agent default_headers max_redirect max_size proxy timeout);
+    no strict 'refs';
+    for my $accessor ( @attributes ) {
+        *{$accessor} = sub {
+            @_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor};
+        };
+    }
+}
+
+sub new {
+    my($class, %args) = @_;
+    (my $agent = $class) =~ s{::}{-}g;
+    my $self = {
+        agent        => $agent . "/" . ($class->VERSION || 0),
+        max_redirect => 5,
+        timeout      => 60,
+    };
+    for my $key ( @attributes ) {
+        $self->{$key} = $args{$key} if exists $args{$key}
+    }
+
+    # 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});
+        }
+    }
+
+    return bless $self, $class;
+}
+
+
+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));
+    open my $fh, ">", $tempfile
+        or Carp::croak(qq/Error: Could not open temporary file $tempfile for downloading: $!\n/);
+    binmode $fh;
+    $args->{data_callback} = sub { print {$fh} $_[0] };
+    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 = {
+            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");
+
+    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 _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});
+
+    if ($self->{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);
+    $handle->write_request($request);
+
+    my $response;
+    do { $response = $handle->read_response_header }
+        until (substr($response->{status},0,1) ne '1');
+
+    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';
+    return $response;
+}
+
+sub _prepare_headers_and_cb {
+    my ($self, $request, $args) = @_;
+
+    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}) {
+        $request->{headers}{'content-type'} ||= "application/octet-stream";
+        if (ref $args->{content} eq 'CODE') {
+            $request->{headers}{'transfer-encoding'} = 'chunked'
+              unless $request->{headers}{'content-length'}
+                  || $request->{headers}{'transfer-encoding'};
+            $request->{cb} = $args->{content};
+        }
+        else {
+            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-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';
+    }
+    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 _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,
+        %args
+    }, $class;
+}
+
+my $ssl_verify_args = {
+    check_cn => "when_only",
+    wildcards_in_alt => "anywhere",
+    wildcards_in_cn => "anywhere"
+};
+
+sub connect {
+    @_ == 4 || die(q/Usage: $handle->connect(scheme, host, port)/ . "\n");
+    my ($self, $scheme, $host, $port) = @_;
+
+    if ( $scheme eq 'https' ) {
+        eval "require IO::Socket::SSL"
+            unless exists $INC{'IO/Socket/SSL.pm'};
+        die(qq/IO::Socket::SSL must be installed for https support\n/)
+            unless $INC{'IO/Socket/SSL.pm'};
+    }
+    elsif ( $scheme ne 'http' ) {
+      die(qq/Unsupported URL scheme '$scheme'\n/);
+    }
+
+    $self->{fh} = 'IO::Socket::INET'->new(
+        PeerHost  => $host,
+        PeerPort  => $port,
+        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') {
+        IO::Socket::SSL->start_SSL($self->{fh});
+        ref($self->{fh}) eq 'IO::Socket::SSL'
+            or die(qq/SSL connection failed for $host\n/);
+        $self->{fh}->verify_hostname( $host, $ssl_verify_args )
+            or die(qq/SSL certificate not valid for $host\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) {
+            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) {
+            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) {
+            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 ( $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', @_)
+}
+
+1;
+
+
+
+__END__
+=pod
+
+=head1 NAME
+
+HTTP::Tiny - A small, simple, correct HTTP/1.1 client
+
+=head1 VERSION
+
+version 0.017
+
+=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')
+
+=item *
+
+C<default_headers>
+
+A hashref of default headers to apply to requests
+
+=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<timeout>
+
+Request timeout in seconds (default is 60)
+
+=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.
+
+=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 includes 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 *
+
+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 *
+
+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 response
+
+=item *
+
+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 *
+
+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<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 *
+
+success
+
+Boolean indicating whether the operation returned a 2XX status code
+
+=item *
+
+status
+
+The HTTP status code of the response
+
+=item *
+
+reason
+
+The response phrase returned by the server
+
+=item *
+
+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 *
+
+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
+default_headers
+max_redirect
+max_size
+proxy
+timeout
+
+=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 *
+
+Direct C<https> connections are supported only if L<IO::Socket::SSL> is
+installed.  There is no support for C<https> connections via proxy.
+Any SSL certificate that matches the host is accepted -- SSL certificates
+are not verified against certificate authorities.
+
+=item *
+
+Cookies are not directly supported.  Users that set a C<Cookie> header
+should also set C<max_redirect> to zero to ensure cookies are not
+inappropriately re-transmitted.
+
+=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 *
+
+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.
+
+=back
+
+=head1 SEE ALSO
+
+=over 4
+
+=item *
+
+L<LWP::UserAgent>
+
+=back
+
+=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders
+
+=head1 SUPPORT
+
+=head2 Bugs / Feature Requests
+
+Please report any bugs or feature requests through the issue tracker
+at L<http://rt.cpan.org/Public/Dist/Display.html?Name=HTTP-Tiny>.
+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/dagolden/p5-http-tiny>
+
+  git clone https://github.com/dagolden/p5-http-tiny.git
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+Christian Hansen <chansen@cpan.org>
+
+=item *
+
+David Golden <dagolden@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2012 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
+