summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/HTTP
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/HTTP')
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Config.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Cookies.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Cookies/Microsoft.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Cookies/Netscape.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Daemon.pm7
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Date.pm11
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Headers.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Headers/Auth.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Headers/ETag.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Headers/Util.pm4
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Message.pm39
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Negotiate.pm3
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Request.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Request/Common.pm11
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Response.pm17
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Status.pm25
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Tiny.pm1098
17 files changed, 1174 insertions, 57 deletions
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Config.pm b/Master/tlpkg/tlperl/lib/HTTP/Config.pm
index c7d9df53711..931f63db69d 100644
--- a/Master/tlpkg/tlperl/lib/HTTP/Config.pm
+++ b/Master/tlpkg/tlperl/lib/HTTP/Config.pm
@@ -4,7 +4,7 @@ use strict;
use URI;
use vars qw($VERSION);
-$VERSION = "5.835";
+$VERSION = "6.00";
sub new {
my $class = shift;
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Cookies.pm b/Master/tlpkg/tlperl/lib/HTTP/Cookies.pm
index 831a4ace15c..79ac4f27f84 100644
--- a/Master/tlpkg/tlperl/lib/HTTP/Cookies.pm
+++ b/Master/tlpkg/tlperl/lib/HTTP/Cookies.pm
@@ -5,7 +5,7 @@ use HTTP::Date qw(str2time parse_date time2str);
use HTTP::Headers::Util qw(_split_header_words join_header_words);
use vars qw($VERSION $EPOCH_OFFSET);
-$VERSION = "5.837";
+$VERSION = "6.01";
# Legacy: because "use "HTTP::Cookies" used be the ONLY way
# to load the class HTTP::Cookies::Netscape.
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Cookies/Microsoft.pm b/Master/tlpkg/tlperl/lib/HTTP/Cookies/Microsoft.pm
index c5a0bf77087..9c69fa364cf 100644
--- a/Master/tlpkg/tlperl/lib/HTTP/Cookies/Microsoft.pm
+++ b/Master/tlpkg/tlperl/lib/HTTP/Cookies/Microsoft.pm
@@ -4,7 +4,7 @@ use strict;
use vars qw(@ISA $VERSION);
-$VERSION = "5.821";
+$VERSION = "6.00";
require HTTP::Cookies;
@ISA=qw(HTTP::Cookies);
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Cookies/Netscape.pm b/Master/tlpkg/tlperl/lib/HTTP/Cookies/Netscape.pm
index f19c517f946..5972029e558 100644
--- a/Master/tlpkg/tlperl/lib/HTTP/Cookies/Netscape.pm
+++ b/Master/tlpkg/tlperl/lib/HTTP/Cookies/Netscape.pm
@@ -3,7 +3,7 @@ package HTTP::Cookies::Netscape;
use strict;
use vars qw(@ISA $VERSION);
-$VERSION = "5.832";
+$VERSION = "6.00";
require HTTP::Cookies;
@ISA=qw(HTTP::Cookies);
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Daemon.pm b/Master/tlpkg/tlperl/lib/HTTP/Daemon.pm
index cf61147d077..27a7bf4e173 100644
--- a/Master/tlpkg/tlperl/lib/HTTP/Daemon.pm
+++ b/Master/tlpkg/tlperl/lib/HTTP/Daemon.pm
@@ -3,9 +3,9 @@ package HTTP::Daemon;
use strict;
use vars qw($VERSION @ISA $PROTO $DEBUG);
-$VERSION = "5.827";
+$VERSION = "6.01";
-use IO::Socket qw(AF_INET INADDR_ANY inet_ntoa);
+use IO::Socket qw(AF_INET INADDR_ANY INADDR_LOOPBACK inet_ntoa);
@ISA=qw(IO::Socket::INET);
$PROTO = "HTTP/1.1";
@@ -44,6 +44,9 @@ sub url
require Sys::Hostname;
$url .= lc Sys::Hostname::hostname();
}
+ elsif ($addr eq INADDR_LOOPBACK) {
+ $url .= inet_ntoa($addr);
+ }
else {
$url .= gethostbyaddr($addr, AF_INET) || inet_ntoa($addr);
}
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Date.pm b/Master/tlpkg/tlperl/lib/HTTP/Date.pm
index 7756214af98..d05d21605ae 100644
--- a/Master/tlpkg/tlperl/lib/HTTP/Date.pm
+++ b/Master/tlpkg/tlperl/lib/HTTP/Date.pm
@@ -1,8 +1,7 @@
package HTTP::Date;
-$VERSION = "5.831";
+$VERSION = "6.02";
-require 5.004;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(time2str str2time);
@@ -107,7 +106,7 @@ sub parse_date ($)
\s*
([-+]?\d{2,4}|(?![APap][Mm]\b)[A-Za-z]+)? # timezone
\s*
- (?:\(\w+\))? # ASCII representation of timezone in parens.
+ (?:\(\w+\)|\w{3,})? # ASCII representation of timezone.
\s*$
/x)
@@ -316,13 +315,13 @@ to get the date recognized.
This function will try to parse a date string, and then return it as a
list of numerical values followed by a (possible undefined) time zone
specifier; ($year, $month, $day, $hour, $min, $sec, $tz). The $year
-returned will B<not> have the number 1900 subtracted from it and the
-$month numbers start with 1.
+will be the full 4-digit year, and $month numbers start with 1 (for January).
In scalar context the numbers are interpolated in a string of the
"YYYY-MM-DD hh:mm:ss TZ"-format and returned.
-If the date is unrecognized, then the empty list is returned.
+If the date is unrecognized, then the empty list is returned (C<undef> in
+scalar context).
The function is able to parse the following formats:
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Headers.pm b/Master/tlpkg/tlperl/lib/HTTP/Headers.pm
index 1e9198cd3c7..67f1d2e6406 100644
--- a/Master/tlpkg/tlperl/lib/HTTP/Headers.pm
+++ b/Master/tlpkg/tlperl/lib/HTTP/Headers.pm
@@ -4,7 +4,7 @@ use strict;
use Carp ();
use vars qw($VERSION $TRANSLATE_UNDERSCORE);
-$VERSION = "5.835";
+$VERSION = "6.00";
# The $TRANSLATE_UNDERSCORE variable controls whether '_' can be used
# as a replacement for '-' in header field names.
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Headers/Auth.pm b/Master/tlpkg/tlperl/lib/HTTP/Headers/Auth.pm
index 1e416e2dd9a..64e204ce388 100644
--- a/Master/tlpkg/tlperl/lib/HTTP/Headers/Auth.pm
+++ b/Master/tlpkg/tlperl/lib/HTTP/Headers/Auth.pm
@@ -2,7 +2,7 @@ package HTTP::Headers::Auth;
use strict;
use vars qw($VERSION);
-$VERSION = "5.817";
+$VERSION = "6.00";
use HTTP::Headers;
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Headers/ETag.pm b/Master/tlpkg/tlperl/lib/HTTP/Headers/ETag.pm
index 743da463de4..e0b2c7e255c 100644
--- a/Master/tlpkg/tlperl/lib/HTTP/Headers/ETag.pm
+++ b/Master/tlpkg/tlperl/lib/HTTP/Headers/ETag.pm
@@ -2,7 +2,7 @@ package HTTP::Headers::ETag;
use strict;
use vars qw($VERSION);
-$VERSION = "5.810";
+$VERSION = "6.00";
require HTTP::Date;
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Headers/Util.pm b/Master/tlpkg/tlperl/lib/HTTP/Headers/Util.pm
index 9ae65e7faf5..fdcf501b8e5 100644
--- a/Master/tlpkg/tlperl/lib/HTTP/Headers/Util.pm
+++ b/Master/tlpkg/tlperl/lib/HTTP/Headers/Util.pm
@@ -3,7 +3,7 @@ package HTTP::Headers::Util;
use strict;
use vars qw($VERSION @ISA @EXPORT_OK);
-$VERSION = "5.817";
+$VERSION = "6.03";
require Exporter;
@ISA=qw(Exporter);
@@ -153,7 +153,7 @@ the requirement for tokens).
Each I<header> is represented by an anonymous array of key/value
pairs. The keys will be all be forced to lower case.
The value for a simple token (not part of a parameter) is C<undef>.
-Syntactically incorrect headers will not necessary be parsed as you
+Syntactically incorrect headers will not necessarily be parsed as you
would want.
This is easier to describe with some examples:
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Message.pm b/Master/tlpkg/tlperl/lib/HTTP/Message.pm
index 944e88d1899..4aae3f2c8a1 100644
--- a/Master/tlpkg/tlperl/lib/HTTP/Message.pm
+++ b/Master/tlpkg/tlperl/lib/HTTP/Message.pm
@@ -2,7 +2,7 @@ package HTTP::Message;
use strict;
use vars qw($VERSION $AUTOLOAD);
-$VERSION = "5.837";
+$VERSION = "6.03";
require HTTP::Headers;
require Carp;
@@ -307,7 +307,7 @@ sub decoded_content
$content_ref = \$output;
$content_ref_iscopy++;
}
- elsif ($ce eq "x-bzip2") {
+ elsif ($ce eq "x-bzip2" or $ce eq "bzip2") {
require IO::Uncompress::Bunzip2;
my $output;
IO::Uncompress::Bunzip2::bunzip2($content_ref, \$output, Transparent => 0)
@@ -364,16 +364,21 @@ sub decoded_content
$self->content_charset ||
"ISO-8859-1"
);
- unless ($charset =~ /^(?:none|us-ascii|iso-8859-1)\z/) {
- require Encode;
- if (do{my $v = $Encode::VERSION; $v =~ s/_//g; $v} < 2.0901 &&
- !$content_ref_iscopy)
- {
- # LEAVE_SRC did not work before Encode-2.0901
- my $copy = $$content_ref;
- $content_ref = \$copy;
- $content_ref_iscopy++;
+ if ($charset eq "none") {
+ # leave it asis
+ }
+ elsif ($charset eq "us-ascii" || $charset eq "iso-8859-1") {
+ if ($$content_ref =~ /[^\x00-\x7F]/ && defined &utf8::upgrade) {
+ unless ($content_ref_iscopy) {
+ my $copy = $$content_ref;
+ $content_ref = \$copy;
+ $content_ref_iscopy++;
+ }
+ utf8::upgrade($$content_ref);
}
+ }
+ else {
+ require Encode;
eval {
$content_ref = \Encode::decode($charset, $$content_ref,
($opt{charset_strict} ? Encode::FB_CROAK() : 0) | Encode::LEAVE_SRC());
@@ -386,7 +391,7 @@ sub decoded_content
# Retry decoding with the alternative charset
$content_ref = \Encode::decode($alt_charset, $$content_ref,
($opt{charset_strict} ? Encode::FB_CROAK() : 0) | Encode::LEAVE_SRC())
- unless $alt_charset =~ /^(?:none|us-ascii|iso-8859-1)\z/;
+ unless $alt_charset eq "none";
$retried++;
}
}
@@ -869,10 +874,10 @@ for details about how charset is determined.
=item $mess->decoded_content( %options )
-Returns the content with any C<Content-Encoding> undone and the raw
-content encoded to perl's Unicode strings. If the C<Content-Encoding>
-or C<charset> of the message is unknown this method will fail by
-returning C<undef>.
+Returns the content with any C<Content-Encoding> undone and for textual content
+the raw content encoded to Perl's Unicode strings. If the C<Content-Encoding>
+or C<charset> of the message is unknown this method will fail by returning
+C<undef>.
The following options can be specified.
@@ -976,7 +981,7 @@ one part returned.
If the content type is C<message/http>, then the return value will be
either an C<HTTP::Request> or an C<HTTP::Response> object.
-If an @parts argument is given, then the content of the message will be
+If a @parts argument is given, then the content of the message will be
modified. The array reference form is provided so that an empty list
can be provided. The @parts array should contain C<HTTP::Message>
objects. The @parts objects are owned by $mess after this call and
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Negotiate.pm b/Master/tlpkg/tlperl/lib/HTTP/Negotiate.pm
index 7ded7e6d5a5..d293ce86d97 100644
--- a/Master/tlpkg/tlperl/lib/HTTP/Negotiate.pm
+++ b/Master/tlpkg/tlperl/lib/HTTP/Negotiate.pm
@@ -1,9 +1,8 @@
package HTTP::Negotiate;
-$VERSION = "5.835";
+$VERSION = "6.01";
sub Version { $VERSION; }
-require 5.002;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(choose);
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Request.pm b/Master/tlpkg/tlperl/lib/HTTP/Request.pm
index ac7dc65af43..154ea2f926c 100644
--- a/Master/tlpkg/tlperl/lib/HTTP/Request.pm
+++ b/Master/tlpkg/tlperl/lib/HTTP/Request.pm
@@ -2,7 +2,7 @@ package HTTP::Request;
require HTTP::Message;
@ISA = qw(HTTP::Message);
-$VERSION = "5.827";
+$VERSION = "6.00";
use strict;
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Request/Common.pm b/Master/tlpkg/tlperl/lib/HTTP/Request/Common.pm
index 7e3e03a861b..626e048d65f 100644
--- a/Master/tlpkg/tlperl/lib/HTTP/Request/Common.pm
+++ b/Master/tlpkg/tlperl/lib/HTTP/Request/Common.pm
@@ -13,7 +13,7 @@ require Exporter;
require HTTP::Request;
use Carp();
-$VERSION = "5.824";
+$VERSION = "6.03";
my $CRLF = "\015\012"; # "\r\n" is not portable
@@ -81,6 +81,9 @@ sub POST
my $url = URI->new('http:');
$url->query_form(ref($content) eq "HASH" ? %$content : @$content);
$content = $url->query;
+
+ # HTML/4.01 says that line breaks are represented as "CR LF" pairs (i.e., `%0D%0A')
+ $content =~ s/(?<!%0D)%0A/%0D%0A/g;
}
}
@@ -389,7 +392,7 @@ the $form_ref this way.
The $form_ref argument can be used to pass key/value pairs for the
form content. By default we will initialize a request using the
C<application/x-www-form-urlencoded> content type. This means that
-you can emulate a HTML E<lt>form> POSTing like this:
+you can emulate an HTML E<lt>form> POSTing like this:
POST 'http://www.perl.org/survey.cgi',
[ name => 'Gisle Aas',
@@ -399,7 +402,7 @@ you can emulate a HTML E<lt>form> POSTing like this:
perc => '3%',
];
-This will create a HTTP::Request object that looks like this:
+This will create an HTTP::Request object that looks like this:
POST http://www.perl.org/survey.cgi
Content-Length: 66
@@ -445,7 +448,7 @@ achieved by this:
init => ["$ENV{HOME}/.profile"],
]
-This will create a HTTP::Request object that almost looks this (the
+This will create an HTTP::Request object that almost looks this (the
boundary and the content of your F<~/.profile> is likely to be
different):
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Response.pm b/Master/tlpkg/tlperl/lib/HTTP/Response.pm
index b60f06fc09a..8bdb1c5bd1e 100644
--- a/Master/tlpkg/tlperl/lib/HTTP/Response.pm
+++ b/Master/tlpkg/tlperl/lib/HTTP/Response.pm
@@ -2,7 +2,7 @@ package HTTP::Response;
require HTTP::Message;
@ISA = qw(HTTP::Message);
-$VERSION = "5.836";
+$VERSION = "6.03";
use strict;
use HTTP::Status ();
@@ -143,12 +143,8 @@ sub filename
}
require Encode;
- require encoding;
- # This is ugly use of non-public API, but is there
- # a better way to accomplish what we want (locally
- # as-is usable filename string)?
- my $locale_charset = encoding::_get_locale_encoding();
- Encode::from_to($encfile, $charset, $locale_charset);
+ require Encode::Locale;
+ Encode::from_to($encfile, $charset, "locale_fs");
};
$file = $encfile unless $@;
@@ -221,10 +217,11 @@ sub is_error { HTTP::Status::is_error (shift->{'_rc'}); }
sub error_as_HTML
{
- require HTML::Entities;
my $self = shift;
my $title = 'An Error Occurred';
- my $body = HTML::Entities::encode($self->status_line);
+ my $body = $self->status_line;
+ $body =~ s/&/&amp;/g;
+ $body =~ s/</&lt;/g;
return <<EOM;
<html>
<head><title>$title</title></head>
@@ -395,7 +392,7 @@ This constructs a new response object by parsing the given string.
=item $r->code( $code )
This is used to get/set the code attribute. The code is a 3 digit
-number that encode the overall outcome of a HTTP response. The
+number that encode the overall outcome of an HTTP response. The
C<HTTP::Status> module provide constants that provide mnemonic names
for the code attribute.
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Status.pm b/Master/tlpkg/tlperl/lib/HTTP/Status.pm
index 930bd878858..f229af6c226 100644
--- a/Master/tlpkg/tlperl/lib/HTTP/Status.pm
+++ b/Master/tlpkg/tlperl/lib/HTTP/Status.pm
@@ -9,7 +9,7 @@ require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(is_info is_success is_redirect is_error status_message);
@EXPORT_OK = qw(is_client_error is_server_error);
-$VERSION = "5.817";
+$VERSION = "6.03";
# Note also addition of mnemonics to @EXPORT below
@@ -28,6 +28,7 @@ my %StatusCode = (
205 => 'Reset Content',
206 => 'Partial Content',
207 => 'Multi-Status', # RFC 2518 (WebDAV)
+ 208 => 'Already Reported', # RFC 5842
300 => 'Multiple Choices',
301 => 'Moved Permanently',
302 => 'Found',
@@ -53,11 +54,15 @@ my %StatusCode = (
415 => 'Unsupported Media Type',
416 => 'Request Range Not Satisfiable',
417 => 'Expectation Failed',
+ 418 => 'I\'m a teapot', # RFC 2324
422 => 'Unprocessable Entity', # RFC 2518 (WebDAV)
423 => 'Locked', # RFC 2518 (WebDAV)
424 => 'Failed Dependency', # RFC 2518 (WebDAV)
425 => 'No code', # WebDAV Advanced Collections
426 => 'Upgrade Required', # RFC 2817
+ 428 => 'Precondition Required',
+ 429 => 'Too Many Requests',
+ 431 => 'Request Header Fields Too Large',
449 => 'Retry with', # unofficial Microsoft
500 => 'Internal Server Error',
501 => 'Not Implemented',
@@ -69,12 +74,14 @@ my %StatusCode = (
507 => 'Insufficient Storage', # RFC 2518 (WebDAV)
509 => 'Bandwidth Limit Exceeded', # unofficial
510 => 'Not Extended', # RFC 2774
+ 511 => 'Network Authentication Required',
);
my $mnemonicCode = '';
my ($code, $message);
while (($code, $message) = each %StatusCode) {
# create mnemonic subroutines
+ $message =~ s/I'm/I am/;
$message =~ tr/a-z \-/A-Z__/;
$mnemonicCode .= "sub HTTP_$message () { $code }\n";
$mnemonicCode .= "*RC_$message = \\&HTTP_$message;\n"; # legacy
@@ -128,7 +135,7 @@ HTTP::Status - HTTP Status code processing
I<HTTP::Status> is a library of routines for defining and
classifying HTTP status codes for libwww-perl. Status codes are
-used to encode the overall outcome of a HTTP response message. Codes
+used to encode the overall outcome of an HTTP response message. Codes
correspond to those defined in RFC 2616 and RFC 2518.
=head1 CONSTANTS
@@ -149,6 +156,7 @@ tag to import them all.
HTTP_RESET_CONTENT (205)
HTTP_PARTIAL_CONTENT (206)
HTTP_MULTI_STATUS (207)
+ HTTP_ALREADY_REPORTED (208)
HTTP_MULTIPLE_CHOICES (300)
HTTP_MOVED_PERMANENTLY (301)
@@ -176,11 +184,15 @@ tag to import them all.
HTTP_UNSUPPORTED_MEDIA_TYPE (415)
HTTP_REQUEST_RANGE_NOT_SATISFIABLE (416)
HTTP_EXPECTATION_FAILED (417)
+ HTTP_I_AM_A_TEAPOT (418)
HTTP_UNPROCESSABLE_ENTITY (422)
HTTP_LOCKED (423)
HTTP_FAILED_DEPENDENCY (424)
HTTP_NO_CODE (425)
HTTP_UPGRADE_REQUIRED (426)
+ HTTP_PRECONDITION_REQUIRED (428)
+ HTTP_TOO_MANY_REQUESTS (429)
+ HTTP_REQUEST_HEADER_FIELDS_TOO_LARGE (431)
HTTP_RETRY_WITH (449)
HTTP_INTERNAL_SERVER_ERROR (500)
@@ -193,6 +205,7 @@ tag to import them all.
HTTP_INSUFFICIENT_STORAGE (507)
HTTP_BANDWIDTH_LIMIT_EXCEEDED (509)
HTTP_NOT_EXTENDED (510)
+ HTTP_NETWORK_AUTHENTICATION_REQUIRED (511)
=head1 FUNCTIONS
@@ -227,11 +240,11 @@ user agent in order to fulfill the request.
=item is_error( $code )
Return TRUE if C<$code> is an I<Error> status code (4xx or 5xx). The function
-return TRUE for both client error or a server error status codes.
+returns TRUE for both client and server error status codes.
=item is_client_error( $code )
-Return TRUE if C<$code> is an I<Client Error> status code (4xx). This class
+Return TRUE if C<$code> is a I<Client Error> status code (4xx). This class
of status code is intended for cases in which the client seems to have
erred.
@@ -239,7 +252,7 @@ This function is B<not> exported by default.
=item is_server_error( $code )
-Return TRUE if C<$code> is an I<Server Error> status code (5xx). This class
+Return TRUE if C<$code> is a I<Server Error> status code (5xx). This class
of status codes is intended for cases in which the server is aware
that it has erred or is incapable of performing the request.
@@ -250,5 +263,5 @@ This function is B<not> exported by default.
=head1 BUGS
For legacy reasons all the C<HTTP_> constants are exported by default
-with the prefix C<RC_>. It's recommended to use explict imports and
+with the prefix C<RC_>. It's recommended to use explicit imports and
the C<:constants> tag instead of relying on this.
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Tiny.pm b/Master/tlpkg/tlperl/lib/HTTP/Tiny.pm
new file mode 100644
index 00000000000..b4f6bd733c5
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/HTTP/Tiny.pm
@@ -0,0 +1,1098 @@
+# vim: ts=4 sts=4 sw=4 et:
+#
+# This file is part of HTTP-Tiny
+#
+# This software is copyright (c) 2011 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.
+#
+package HTTP::Tiny;
+BEGIN {
+ $HTTP::Tiny::VERSION = '0.012';
+}
+use strict;
+use warnings;
+# ABSTRACT: A small, simple, correct HTTP/1.1 client
+
+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}
+ }
+ return bless $self, $class;
+}
+
+
+sub get {
+ my ($self, $url, $args) = @_;
+ @_ == 2 || (@_ == 3 && ref $args eq 'HASH')
+ or Carp::croak(q/Usage: $http->get(URL, [HASHREF])/);
+ return $self->request('GET', $url, $args || {});
+}
+
+
+sub mirror {
+ my ($self, $url, $file, $args) = @_;
+ @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
+ or Carp::croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/);
+ 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: $!/);
+ 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: $!/);
+ if ( $response->{success} ) {
+ rename $tempfile, $file
+ or Carp::croak "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])/);
+ $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;
+}
+
+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";
+ croak(qq/HTTPS via proxy is not supported/)
+ 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 Carp::croak(q/Wide character in request message body/);
+ }
+ $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 Carp::croak(qq/Cannot parse URL: '$url'/);
+
+ $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;
+ };
+}
+
+package
+ HTTP::Tiny::Handle; # hide from PAUSE/indexers
+use strict;
+use warnings;
+
+use Carp qw[croak];
+use Errno qw[EINTR EPIPE];
+use IO::Socket qw[SOCK_STREAM];
+
+sub BUFSIZE () { 32768 }
+
+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 || croak(q/Usage: $handle->connect(scheme, host, port)/);
+ my ($self, $scheme, $host, $port) = @_;
+
+ if ( $scheme eq 'https' ) {
+ eval "require IO::Socket::SSL"
+ unless exists $INC{'IO/Socket/SSL.pm'};
+ croak(qq/IO::Socket::SSL must be installed for https support\n/)
+ unless $INC{'IO/Socket/SSL.pm'};
+ }
+ elsif ( $scheme ne 'http' ) {
+ croak(qq/Unsupported URL scheme '$scheme'/);
+ }
+
+ $self->{fh} = 'IO::Socket::INET'->new(
+ PeerHost => $host,
+ PeerPort => $port,
+ Proto => 'tcp',
+ Type => SOCK_STREAM,
+ Timeout => $self->{timeout}
+ ) or croak(qq/Could not connect to '$host:$port': $@/);
+
+ binmode($self->{fh})
+ or croak(qq/Could not binmode() socket: '$!'/);
+
+ 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 || croak(q/Usage: $handle->close()/);
+ my ($self) = @_;
+ CORE::close($self->{fh})
+ or croak(qq/Could not close socket: '$!'/);
+}
+
+sub write {
+ @_ == 2 || croak(q/Usage: $handle->write(buf)/);
+ my ($self, $buf) = @_;
+
+ if ( $] ge '5.008' ) {
+ utf8::downgrade($buf, 1)
+ or croak(q/Wide character in write()/);
+ }
+
+ my $len = length $buf;
+ my $off = 0;
+
+ local $SIG{PIPE} = 'IGNORE';
+
+ while () {
+ $self->can_write
+ or croak(q/Timed out while waiting for socket to become ready for writing/);
+ my $r = syswrite($self->{fh}, $buf, $len, $off);
+ if (defined $r) {
+ $len -= $r;
+ $off += $r;
+ last unless $len > 0;
+ }
+ elsif ($! == EPIPE) {
+ croak(qq/Socket closed by remote server: $!/);
+ }
+ elsif ($! != EINTR) {
+ croak(qq/Could not write to socket: '$!'/);
+ }
+ }
+ return $off;
+}
+
+sub read {
+ @_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len [, allow_partial])/);
+ 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 croak(q/Timed out while waiting for socket to become ready for reading/);
+ my $r = sysread($self->{fh}, $buf, $len, length $buf);
+ if (defined $r) {
+ last unless $r;
+ $len -= $r;
+ }
+ elsif ($! != EINTR) {
+ croak(qq/Could not read from socket: '$!'/);
+ }
+ }
+ if ($len && !$allow_partial) {
+ croak(q/Unexpected end of stream/);
+ }
+ return $buf;
+}
+
+sub readline {
+ @_ == 1 || croak(q/Usage: $handle->readline()/);
+ my ($self) = @_;
+
+ while () {
+ if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
+ return $1;
+ }
+ if (length $self->{rbuf} >= $self->{max_line_size}) {
+ croak(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}/);
+ }
+ $self->can_read
+ or croak(q/Timed out while waiting for socket to become ready for reading/);
+ my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
+ if (defined $r) {
+ last unless $r;
+ }
+ elsif ($! != EINTR) {
+ croak(qq/Could not read from socket: '$!'/);
+ }
+ }
+ croak(q/Unexpected end of stream while looking for line/);
+}
+
+sub read_header_lines {
+ @_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
+ my ($self, $headers) = @_;
+ $headers ||= {};
+ my $lines = 0;
+ my $val;
+
+ while () {
+ my $line = $self->readline;
+
+ if (++$lines >= $self->{max_header_lines}) {
+ croak(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}/);
+ }
+ 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 croak(q/Unexpected header continuation line/);
+ next unless length $1;
+ $$val .= ' ' if length $$val;
+ $$val .= $1;
+ }
+ elsif ($line =~ /\A \x0D?\x0A \z/x) {
+ last;
+ }
+ else {
+ croak(q/Malformed header line: / . $Printable->($line));
+ }
+ }
+ return $headers;
+}
+
+sub write_request {
+ @_ == 2 || croak(q/Usage: $handle->write_request(request)/);
+ 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') || croak(q/Usage: $handle->write_header_lines(headers)/);
+ 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 croak(q/Invalid HTTP header field name: / . $Printable->($field_name));
+ $field_name =~ s/\b(\w)/\u$1/g;
+ $HeaderCase{lc $field_name} = $field_name;
+ }
+ for (ref $v eq 'ARRAY' ? @$v : $v) {
+ /[^\x0D\x0A]/
+ or croak(qq/Invalid HTTP header field value ($field_name): / . $Printable->($_));
+ $buf .= "$field_name: $_\x0D\x0A";
+ }
+ }
+ $buf .= "\x0D\x0A";
+ return $self->write($buf);
+}
+
+sub read_body {
+ @_ == 3 || croak(q/Usage: $handle->read_body(callback, response)/);
+ 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 || croak(q/Usage: $handle->write_body(request)/);
+ 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 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
+ 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 || croak(q/Usage: $handle->write_content_body(request)/);
+ 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 croak(q/Wide character in write_content()/);
+ }
+
+ $len += $self->write($data);
+ }
+
+ $len == $content_length
+ or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
+
+ return $len;
+}
+
+sub read_chunked_body {
+ @_ == 3 || croak(q/Usage: $handle->read_chunked_body(callback, $response)/);
+ my ($self, $cb, $response) = @_;
+
+ while () {
+ my $head = $self->readline;
+
+ $head =~ /\A ([A-Fa-f0-9]+)/x
+ or croak(q/Malformed chunk head: / . $Printable->($head));
+
+ my $len = hex($1)
+ or last;
+
+ $self->read_content_body($cb, $response, $len);
+
+ $self->read(2) eq "\x0D\x0A"
+ or croak(q/Malformed chunk: missing CRLF after chunk data/);
+ }
+ $self->read_header_lines($response->{headers});
+ return;
+}
+
+sub write_chunked_body {
+ @_ == 2 || croak(q/Usage: $handle->write_chunked_body(request)/);
+ 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 croak(q/Wide character in write_chunked_body()/);
+ }
+
+ $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 || croak(q/Usage: $handle->read_response_header()/);
+ 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 croak(q/Malformed Status-Line: / . $Printable->($line));
+
+ my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
+
+ croak (qq/Unsupported HTTP protocol: $protocol/)
+ unless $version =~ /0*1\.0*[01]/;
+
+ return {
+ status => $status,
+ reason => $reason,
+ headers => $self->read_header_lines,
+ protocol => $protocol,
+ };
+}
+
+sub write_request_header {
+ @_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
+ 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 croak(q/select(2): 'Bad file descriptor'/);
+
+ 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 croak(qq/select(2): '$!'/);
+ redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
+ $nfound = 0;
+ }
+ last;
+ }
+ $! = 0;
+ return $nfound;
+}
+
+sub can_read {
+ @_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
+ my $self = shift;
+ return $self->_do_timeout('read', @_)
+}
+
+sub can_write {
+ @_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/);
+ 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.012
+
+=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 primarily 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 *
+
+agent
+
+A user-agent string (defaults to 'HTTP::Tiny/$VERSION')
+
+=item *
+
+default_headers
+
+A hashref of default headers to apply to requests
+
+=item *
+
+max_redirect
+
+Maximum number of redirects allowed (defaults to 5)
+
+=item *
+
+max_size
+
+Maximum response size (only when not using a data callback). If defined,
+responses larger than this will die with an error message
+
+=item *
+
+proxy
+
+URL of a proxy server to use.
+
+=item *
+
+timeout
+
+Request timeout in seconds (default is 60)
+
+=back
+
+=head2 get
+
+ $response = $http->get($url);
+ $response = $http->get($url, \%options);
+
+Executes a C<GET> request for the given URL. The URL must have unsafe
+characters escaped and international domain names encoded. Internally, it just
+calls C<request()> with 'GET' as the method. See C<request()> for valid
+options and a description of the response.
+
+=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 specificy 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 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.
+
+=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 *
+
+Persistant 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 *
+
+Proxy environment variables are not supported.
+
+=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 by email to C<bug-http-tiny at rt.cpan.org>, or through
+the web interface at L<http://rt.cpan.org/Public/Dist/Display.html?Name=HTTP-Tiny>. You will be automatically notified of any
+progress on the request by the system.
+
+=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<http://github.com/dagolden/p5-http-tiny/tree>
+
+ git clone git://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) 2011 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
+