summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/site/lib/HTTP
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/site/lib/HTTP')
-rw-r--r--Master/tlpkg/tlperl/site/lib/HTTP/Config.pm4
-rw-r--r--Master/tlpkg/tlperl/site/lib/HTTP/Cookies.pm87
-rw-r--r--Master/tlpkg/tlperl/site/lib/HTTP/Cookies/Microsoft.pm12
-rw-r--r--Master/tlpkg/tlperl/site/lib/HTTP/Cookies/Netscape.pm21
-rw-r--r--Master/tlpkg/tlperl/site/lib/HTTP/Daemon.pm943
-rw-r--r--Master/tlpkg/tlperl/site/lib/HTTP/Date.pm394
-rw-r--r--Master/tlpkg/tlperl/site/lib/HTTP/Headers.pm4
-rw-r--r--Master/tlpkg/tlperl/site/lib/HTTP/Headers/Auth.pm4
-rw-r--r--Master/tlpkg/tlperl/site/lib/HTTP/Headers/ETag.pm4
-rw-r--r--Master/tlpkg/tlperl/site/lib/HTTP/Headers/Util.pm4
-rw-r--r--Master/tlpkg/tlperl/site/lib/HTTP/Message.pm5
-rw-r--r--Master/tlpkg/tlperl/site/lib/HTTP/Request.pm22
-rw-r--r--Master/tlpkg/tlperl/site/lib/HTTP/Request/Common.pm20
-rw-r--r--Master/tlpkg/tlperl/site/lib/HTTP/Response.pm4
-rw-r--r--Master/tlpkg/tlperl/site/lib/HTTP/Status.pm4
15 files changed, 935 insertions, 597 deletions
diff --git a/Master/tlpkg/tlperl/site/lib/HTTP/Config.pm b/Master/tlpkg/tlperl/site/lib/HTTP/Config.pm
index 0742c932fce..5905634d82b 100644
--- a/Master/tlpkg/tlperl/site/lib/HTTP/Config.pm
+++ b/Master/tlpkg/tlperl/site/lib/HTTP/Config.pm
@@ -3,7 +3,7 @@ package HTTP::Config;
use strict;
use warnings;
-our $VERSION = '6.18';
+our $VERSION = '6.22';
use URI;
@@ -245,7 +245,7 @@ HTTP::Config - Configuration for request and response objects
=head1 VERSION
-version 6.18
+version 6.22
=head1 SYNOPSIS
diff --git a/Master/tlpkg/tlperl/site/lib/HTTP/Cookies.pm b/Master/tlpkg/tlperl/site/lib/HTTP/Cookies.pm
index dcbeba64d27..3aee7b4640b 100644
--- a/Master/tlpkg/tlperl/site/lib/HTTP/Cookies.pm
+++ b/Master/tlpkg/tlperl/site/lib/HTTP/Cookies.pm
@@ -4,18 +4,14 @@ use strict;
use HTTP::Date qw(str2time parse_date time2str);
use HTTP::Headers::Util qw(_split_header_words join_header_words);
-use vars qw($EPOCH_OFFSET);
-our $VERSION = '6.04';
+our $EPOCH_OFFSET;
+our $VERSION = '6.08';
# Legacy: because "use "HTTP::Cookies" used be the ONLY way
# to load the class HTTP::Cookies::Netscape.
require HTTP::Cookies::Netscape;
$EPOCH_OFFSET = 0; # difference from Unix epoch
-if ($^O eq "MacOS") {
- require Time::Local;
- $EPOCH_OFFSET = Time::Local::timelocal(0,0,0,1,0,70);
-}
# A HTTP::Cookies object is a hash. The main attribute is the
# COOKIES 3 level hash: $self->{COOKIES}{$domain}{$path}{$key}.
@@ -231,7 +227,7 @@ sub extract_cookies
my $param;
my $expires;
my $first_param = 1;
- for $param (split(/;\s*/, $set)) {
+ for $param (@{_split_text($set)}) {
next unless length($param);
my($k,$v) = split(/\s*=\s*/, $param, 2);
if (defined $v) {
@@ -430,10 +426,17 @@ sub set_cookie
sub save
{
my $self = shift;
- my $file = shift || $self->{'file'} || return;
+ my %args = (
+ file => $self->{'file'},
+ ignore_discard => $self->{'ignore_discard'},
+ @_ == 1 ? ( file => $_[0] ) : @_
+ );
+ Carp::croak('Unexpected argument to save method') if keys %args > 2;
+ my $file = $args{'file'} || return;
open(my $fh, '>', $file) or die "Can't open $file: $!";
print {$fh} "#LWP-Cookies-1.0\n";
- print {$fh} $self->as_string(!$self->{ignore_discard});
+ print {$fh} $self->as_string(!$args{'ignore_discard'});
+ close $fh or die "Can't close $file: $!";
1;
}
@@ -620,6 +623,50 @@ sub _normalize_path # so that plain string compare can be used
$_[0] =~ s/([\0-\x20\x7f-\xff])/sprintf("%%%02X",ord($1))/eg;
}
+# deals with splitting values by ; and the fact that they could
+# be in quotes which can also have escaping.
+sub _split_text {
+ my $val = shift;
+ my @vals = grep { $_ ne q{} } split(/([;\\"])/, $val);
+ my @chunks;
+ # divide it up into chunks to be processed.
+ my $in_string = 0;
+ my @current_string;
+ for(my $i = 0; $i < @vals; $i++) {
+ my $chunk = $vals[$i];
+ if($in_string) {
+ if($chunk eq q{\\}) {
+ # don't care about next char probably.
+ # having said that, probably need to be appending to the chunks
+ # just dropping this.
+ $i++;
+ if($i < @vals) {
+ push @current_string, $vals[$i];
+ }
+ } elsif($chunk eq q{"}) {
+ $in_string = 0;
+ }
+ else {
+ push @current_string, $chunk;
+ }
+ } else {
+ if($chunk eq q{"}) {
+ $in_string = 1;
+ }
+ elsif($chunk eq q{;}) {
+ push @chunks, join(q{}, @current_string);
+ @current_string = ();
+ }
+ else {
+ push @current_string, $chunk;
+ }
+ }
+ }
+ push @chunks, join(q{}, @current_string) if @current_string;
+ s/^\s+// for @chunks;
+ return \@chunks;
+}
+
1;
=pod
@@ -632,7 +679,7 @@ HTTP::Cookies - HTTP cookie jars
=head1 VERSION
-version 6.04
+version 6.08
=head1 SYNOPSIS
@@ -661,8 +708,8 @@ knows about.
Cookies are a general mechanism which server side connections can use
to both store and retrieve information on the client side of the
connection. For more information about cookies refer to
-<URL:http://curl.haxx.se/rfc/cookie_spec.html> and
-<URL:http://www.cookiecentral.com/>. This module also implements the
+L<Cookie Spec|http://curl.haxx.se/rfc/cookie_spec.html> and
+L<Cookie Central|http://www.cookiecentral.com>. This module also implements the
new style cookies described in L<RFC 2965|https://tools.ietf.org/html/rfc2965>.
The two variants of cookies are supposed to be able to coexist happily.
@@ -741,18 +788,24 @@ The set_cookie() method updates the state of the $cookie_jar. The
$key, $val, $domain, $port and $path arguments are strings. The
$path_spec, $secure, $discard arguments are boolean values. The $maxage
value is a number indicating number of seconds that this cookie will
-live. A value of $maxage <= 0 will delete this cookie. %rest defines
-various other attributes like "Comment" and "CommentURL".
+live. A value of $maxage <= 0 will delete this cookie. The $version argument
+sets the version of the cookie; the default value is 0 ( original Netscape
+spec ). Setting $version to another value indicates the RFC to which the
+cookie conforms (e.g. version 1 for RFC 2109). %rest defines various other
+attributes like "Comment" and "CommentURL".
=item $cookie_jar->save
=item $cookie_jar->save( $file )
+=item $cookie_jar->save( file => $file, ignore_discard => $ignore_discard )
+
This method file saves the state of the $cookie_jar to a file.
The state can then be restored later using the load() method. If a
filename is not specified we will use the name specified during
-construction. If the attribute I<ignore_discard> is set, then we
-will even save cookies that are marked to be discarded.
+construction. If the $ignore_discard value is true (or not specified,
+but attribute I<ignore_discard> was set at cookie jar construction),
+then we will even save cookies that are marked to be discarded.
The default is to save a sequence of "Set-Cookie3" lines.
"Set-Cookie3" is a proprietary LWP format, not known to be compatible
@@ -832,7 +885,7 @@ Gisle Aas <gisle@activestate.com>
=head1 COPYRIGHT AND LICENSE
-This software is copyright (c) 2002-2017 by Gisle Aas.
+This software is copyright (c) 2002-2019 by Gisle Aas.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
diff --git a/Master/tlpkg/tlperl/site/lib/HTTP/Cookies/Microsoft.pm b/Master/tlpkg/tlperl/site/lib/HTTP/Cookies/Microsoft.pm
index 737da2829fa..702255a3359 100644
--- a/Master/tlpkg/tlperl/site/lib/HTTP/Cookies/Microsoft.pm
+++ b/Master/tlpkg/tlperl/site/lib/HTTP/Cookies/Microsoft.pm
@@ -2,12 +2,10 @@ package HTTP::Cookies::Microsoft;
use strict;
-use vars qw(@ISA);
-
-our $VERSION = '6.04';
+our $VERSION = '6.08';
require HTTP::Cookies;
-@ISA=qw(HTTP::Cookies);
+our @ISA=qw(HTTP::Cookies);
sub load_cookies_from_file
{
@@ -226,7 +224,7 @@ sub load
# set the delayload cookie for this domain with
# the cookie_file as cookie for later-loading info
- $self->set_cookie(undef, 'cookie', $cookie_file, '//+delayload', $domain, undef, 0, 0, $now+86400, 0);
+ $self->set_cookie(undef, 'cookie', $cookie_file, '//+delayload', $domain, undef, 0, 0, $now+86_400, 0);
}
}
}
@@ -246,7 +244,7 @@ HTTP::Cookies::Microsoft - Access to Microsoft cookies files
=head1 VERSION
-version 6.04
+version 6.08
=head1 SYNOPSIS
@@ -313,7 +311,7 @@ Gisle Aas <gisle@activestate.com>
=head1 COPYRIGHT AND LICENSE
-This software is copyright (c) 2002-2017 by Gisle Aas.
+This software is copyright (c) 2002-2019 by Gisle Aas.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
diff --git a/Master/tlpkg/tlperl/site/lib/HTTP/Cookies/Netscape.pm b/Master/tlpkg/tlperl/site/lib/HTTP/Cookies/Netscape.pm
index 8fbac888499..28a59d4feff 100644
--- a/Master/tlpkg/tlperl/site/lib/HTTP/Cookies/Netscape.pm
+++ b/Master/tlpkg/tlperl/site/lib/HTTP/Cookies/Netscape.pm
@@ -1,12 +1,11 @@
package HTTP::Cookies::Netscape;
use strict;
-use vars qw(@ISA);
-our $VERSION = '6.04';
+our $VERSION = '6.08';
require HTTP::Cookies;
-@ISA=qw(HTTP::Cookies);
+our @ISA=qw(HTTP::Cookies);
sub load
{
@@ -37,8 +36,14 @@ sub load
sub save
{
- my($self, $file) = @_;
- $file ||= $self->{'file'} || return;
+ my $self = shift;
+ my %args = (
+ file => $self->{'file'},
+ ignore_discard => $self->{'ignore_discard'},
+ @_ == 1 ? ( file => $_[0] ) : @_
+ );
+ Carp::croak('Unexpected argument to save method') if keys %args > 2;
+ my $file = $args{'file'} || return;
open(my $fh, '>', $file) || return;
@@ -54,7 +59,7 @@ EOT
my $now = time - $HTTP::Cookies::EPOCH_OFFSET;
$self->scan(sub {
my ($version, $key, $val, $path, $domain, $port, $path_spec, $secure, $expires, $discard, $rest) = @_;
- return if $discard && !$self->{ignore_discard};
+ return if $discard && !$args{'ignore_discard'};
$expires = $expires ? $expires - $HTTP::Cookies::EPOCH_OFFSET : 0;
return if $now > $expires;
$secure = $secure ? "TRUE" : "FALSE";
@@ -76,7 +81,7 @@ HTTP::Cookies::Netscape - Access to Netscape cookies files
=head1 VERSION
-version 6.04
+version 6.08
=head1 SYNOPSIS
@@ -114,7 +119,7 @@ Gisle Aas <gisle@activestate.com>
=head1 COPYRIGHT AND LICENSE
-This software is copyright (c) 2002-2017 by Gisle Aas.
+This software is copyright (c) 2002-2019 by Gisle Aas.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
diff --git a/Master/tlpkg/tlperl/site/lib/HTTP/Daemon.pm b/Master/tlpkg/tlperl/site/lib/HTTP/Daemon.pm
index 27a7bf4e173..3b3d6903d0a 100644
--- a/Master/tlpkg/tlperl/site/lib/HTTP/Daemon.pm
+++ b/Master/tlpkg/tlperl/site/lib/HTTP/Daemon.pm
@@ -1,29 +1,41 @@
-package HTTP::Daemon;
+package HTTP::Daemon; # git description: v6.05-4-g31c6eaf
+
+# ABSTRACT: A simple http server class
use strict;
-use vars qw($VERSION @ISA $PROTO $DEBUG);
+use warnings;
-$VERSION = "6.01";
+our $VERSION = '6.06';
-use IO::Socket qw(AF_INET INADDR_ANY INADDR_LOOPBACK inet_ntoa);
-@ISA=qw(IO::Socket::INET);
+use Socket qw(
+ AF_INET AF_INET6 INADDR_ANY IN6ADDR_ANY INADDR_LOOPBACK IN6ADDR_LOOPBACK
+ inet_ntop sockaddr_family
+);
+use IO::Socket::IP;
+our @ISA = qw(IO::Socket::IP);
-$PROTO = "HTTP/1.1";
+our $PROTO = "HTTP/1.1";
+our $DEBUG;
-sub new
-{
- my($class, %args) = @_;
+sub new {
+ my ($class, %args) = @_;
$args{Listen} ||= 5;
$args{Proto} ||= 'tcp';
+
+ # Handle undefined or empty local address the same way as
+ # IO::Socket::INET -- use unspecified address
+ for my $key (qw(LocalAddr LocalHost)) {
+ if (exists $args{$key} && (!defined $args{$key} || $args{$key} eq '')) {
+ delete $args{$key};
+ }
+ }
return $class->SUPER::new(%args);
}
-
-sub accept
-{
+sub accept {
my $self = shift;
- my $pkg = shift || "HTTP::Daemon::ClientConn";
+ my $pkg = shift || "HTTP::Daemon::ClientConn";
my ($sock, $peer) = $self->SUPER::accept($pkg);
if ($sock) {
${*$sock}{'httpd_daemon'} = $self;
@@ -34,21 +46,49 @@ sub accept
}
}
-
-sub url
-{
+sub url {
my $self = shift;
- my $url = $self->_default_scheme . "://";
+ my $url = $self->_default_scheme . "://";
my $addr = $self->sockaddr;
- if (!$addr || $addr eq INADDR_ANY) {
- require Sys::Hostname;
- $url .= lc Sys::Hostname::hostname();
+ if (!$addr || $addr eq INADDR_ANY || $addr eq IN6ADDR_ANY) {
+ require Sys::Hostname;
+ $url .= lc Sys::Hostname::hostname();
}
elsif ($addr eq INADDR_LOOPBACK) {
- $url .= inet_ntoa($addr);
+ $url .= inet_ntop(AF_INET, $addr);
+ }
+ elsif ($addr eq IN6ADDR_LOOPBACK) {
+ $url .= '[' . inet_ntop(AF_INET6, $addr) . ']';
}
else {
- $url .= gethostbyaddr($addr, AF_INET) || inet_ntoa($addr);
+ my $host = $self->sockhostname;
+
+ # sockhostname() seems to return a stringified IP address if not
+ # resolvable. Then quote it for a port separator and an IPv6 zone
+ # separator. But be paranoid for a case when it already contains
+ # a bracket.
+ if (defined $host and $host =~ /:/) {
+ if ($host =~ /[\[\]]/) {
+ $host = undef;
+ }
+ else {
+ $host =~ s/%/%25/g;
+ $host = '[' . $host . ']';
+ }
+ }
+ if (!defined $host) {
+ my $family = sockaddr_family($self->sockname);
+ if ($family && $family == AF_INET6) {
+ $host = '[' . inet_ntop(AF_INET6, $addr) . ']';
+ }
+ elsif ($family && $family == AF_INET) {
+ $host = inet_ntop(AF_INET, $addr);
+ }
+ else {
+ die "Unknown family";
+ }
+ }
+ $url .= $host;
}
my $port = $self->sockport;
$url .= ":$port" if $port != $self->_default_port;
@@ -56,29 +96,27 @@ sub url
$url;
}
-
sub _default_port {
80;
}
-
sub _default_scheme {
"http";
}
-
-sub product_tokens
-{
+sub product_tokens {
"libwww-perl-daemon/$HTTP::Daemon::VERSION";
}
+package # hide from PAUSE
+ HTTP::Daemon::ClientConn;
+use strict;
+use warnings;
-package HTTP::Daemon::ClientConn;
-
-use vars qw(@ISA $DEBUG);
-use IO::Socket ();
-@ISA=qw(IO::Socket::INET);
+use IO::Socket::IP ();
+our @ISA = qw(IO::Socket::IP);
+our $DEBUG;
*DEBUG = \$HTTP::Daemon::DEBUG;
use HTTP::Request ();
@@ -88,64 +126,65 @@ use HTTP::Date qw(time2str);
use LWP::MediaTypes qw(guess_media_type);
use Carp ();
-my $CRLF = "\015\012"; # "\r\n" is not portable
+# "\r\n" is not portable
+my $CRLF = "\015\012";
my $HTTP_1_0 = _http_version("HTTP/1.0");
my $HTTP_1_1 = _http_version("HTTP/1.1");
-sub get_request
-{
- my($self, $only_headers) = @_;
+sub get_request {
+ my ($self, $only_headers) = @_;
if (${*$self}{'httpd_nomore'}) {
$self->reason("No more requests from this connection");
- return;
+ return;
}
$self->reason("");
my $buf = ${*$self}{'httpd_rbuf'};
$buf = "" unless defined $buf;
- my $timeout = $ {*$self}{'io_socket_timeout'};
- my $fdset = "";
+ my $timeout = ${*$self}{'io_socket_timeout'};
+ my $fdset = "";
vec($fdset, $self->fileno, 1) = 1;
- local($_);
+ local ($_);
- READ_HEADER:
+READ_HEADER:
while (1) {
- # loop until we have the whole header in $buf
- $buf =~ s/^(?:\015?\012)+//; # ignore leading blank lines
- if ($buf =~ /\012/) { # potential, has at least one line
- if ($buf =~ /^\w+[^\012]+HTTP\/\d+\.\d+\015?\012/) {
- if ($buf =~ /\015?\012\015?\012/) {
- last READ_HEADER; # we have it
- }
- elsif (length($buf) > 16*1024) {
- $self->send_error(413); # REQUEST_ENTITY_TOO_LARGE
- $self->reason("Very long header");
- return;
- }
- }
- else {
- last READ_HEADER; # HTTP/0.9 client
- }
- }
- elsif (length($buf) > 16*1024) {
- $self->send_error(414); # REQUEST_URI_TOO_LARGE
- $self->reason("Very long first line");
- return;
- }
- print STDERR "Need more data for complete header\n" if $DEBUG;
- return unless $self->_need_more($buf, $timeout, $fdset);
+
+ # loop until we have the whole header in $buf
+ $buf =~ s/^(?:\015?\012)+//; # ignore leading blank lines
+ if ($buf =~ /\012/) { # potential, has at least one line
+ if ($buf =~ /^\w+[^\012]+HTTP\/\d+\.\d+\015?\012/) {
+ if ($buf =~ /\015?\012\015?\012/) {
+ last READ_HEADER; # we have it
+ }
+ elsif (length($buf) > 16 * 1024) {
+ $self->send_error(413); # REQUEST_ENTITY_TOO_LARGE
+ $self->reason("Very long header");
+ return;
+ }
+ }
+ else {
+ last READ_HEADER; # HTTP/0.9 client
+ }
+ }
+ elsif (length($buf) > 16 * 1024) {
+ $self->send_error(414); # REQUEST_URI_TOO_LARGE
+ $self->reason("Very long first line");
+ return;
+ }
+ print STDERR "Need more data for complete header\n" if $DEBUG;
+ return unless $self->_need_more($buf, $timeout, $fdset);
}
if ($buf !~ s/^(\S+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) {
- ${*$self}{'httpd_client_proto'} = _http_version("HTTP/1.0");
- $self->send_error(400); # BAD_REQUEST
- $self->reason("Bad request line: $buf");
- return;
+ ${*$self}{'httpd_client_proto'} = _http_version("HTTP/1.0");
+ $self->send_error(400); # BAD_REQUEST
+ $self->reason("Bad request line: $buf");
+ return;
}
my $method = $1;
- my $uri = $2;
- my $proto = $3 || "HTTP/0.9";
+ my $uri = $2;
+ my $proto = $3 || "HTTP/0.9";
$uri = "http://$uri" if $method eq "CONNECT";
$uri = $HTTP::URI_CLASS->new($uri, $self->daemon->url);
my $r = HTTP::Request->new($method, $uri);
@@ -154,37 +193,38 @@ sub get_request
${*$self}{'httpd_head'} = ($method eq "HEAD");
if ($proto >= $HTTP_1_0) {
- # we expect to find some headers
- my($key, $val);
- HEADER:
- while ($buf =~ s/^([^\012]*)\012//) {
- $_ = $1;
- s/\015$//;
- if (/^([^:\s]+)\s*:\s*(.*)/) {
- $r->push_header($key, $val) if $key;
- ($key, $val) = ($1, $2);
- }
- elsif (/^\s+(.*)/) {
- $val .= " $1";
- }
- else {
- last HEADER;
- }
- }
- $r->push_header($key, $val) if $key;
+
+ # we expect to find some headers
+ my ($key, $val);
+ HEADER:
+ while ($buf =~ s/^([^\012]*)\012//) {
+ $_ = $1;
+ s/\015$//;
+ if (/^([^:\s]+)\s*:\s*(.*)/) {
+ $r->push_header($key, $val) if $key;
+ ($key, $val) = ($1, $2);
+ }
+ elsif (/^\s+(.*)/) {
+ $val .= " $1";
+ }
+ else {
+ last HEADER;
+ }
+ }
+ $r->push_header($key, $val) if $key;
}
my $conn = $r->header('Connection');
if ($proto >= $HTTP_1_1) {
- ${*$self}{'httpd_nomore'}++ if $conn && lc($conn) =~ /\bclose\b/;
+ ${*$self}{'httpd_nomore'}++ if $conn && lc($conn) =~ /\bclose\b/;
}
else {
- ${*$self}{'httpd_nomore'}++ unless $conn &&
- lc($conn) =~ /\bkeep-alive\b/;
+ ${*$self}{'httpd_nomore'}++
+ unless $conn && lc($conn) =~ /\bkeep-alive\b/;
}
if ($only_headers) {
- ${*$self}{'httpd_rbuf'} = $buf;
+ ${*$self}{'httpd_rbuf'} = $buf;
return $r;
}
@@ -194,8 +234,8 @@ sub get_request
my $len = $r->header('Content-Length');
# Act on the Expect header, if it's there
- for my $e ( $r->header('Expect') ) {
- if( lc($e) eq '100-continue' ) {
+ for my $e ($r->header('Expect')) {
+ if (lc($e) eq '100-continue') {
$self->send_status_line(100);
$self->send_crlf;
}
@@ -207,111 +247,116 @@ sub get_request
}
if ($te && lc($te) eq 'chunked') {
- # Handle chunked transfer encoding
- my $body = "";
- CHUNK:
- while (1) {
- print STDERR "Chunked\n" if $DEBUG;
- if ($buf =~ s/^([^\012]*)\012//) {
- my $chunk_head = $1;
- unless ($chunk_head =~ /^([0-9A-Fa-f]+)/) {
- $self->send_error(400);
- $self->reason("Bad chunk header $chunk_head");
- return;
- }
- my $size = hex($1);
- last CHUNK if $size == 0;
-
- my $missing = $size - length($buf) + 2; # 2=CRLF at chunk end
- # must read until we have a complete chunk
- while ($missing > 0) {
- print STDERR "Need $missing more bytes\n" if $DEBUG;
- my $n = $self->_need_more($buf, $timeout, $fdset);
- return unless $n;
- $missing -= $n;
- }
- $body .= substr($buf, 0, $size);
- substr($buf, 0, $size+2) = '';
-
- }
- else {
- # need more data in order to have a complete chunk header
- return unless $self->_need_more($buf, $timeout, $fdset);
- }
- }
- $r->content($body);
-
- # pretend it was a normal entity body
- $r->remove_header('Transfer-Encoding');
- $r->header('Content-Length', length($body));
-
- my($key, $val);
- FOOTER:
- while (1) {
- if ($buf !~ /\012/) {
- # need at least one line to look at
- return unless $self->_need_more($buf, $timeout, $fdset);
- }
- else {
- $buf =~ s/^([^\012]*)\012//;
- $_ = $1;
- s/\015$//;
- if (/^([\w\-]+)\s*:\s*(.*)/) {
- $r->push_header($key, $val) if $key;
- ($key, $val) = ($1, $2);
- }
- elsif (/^\s+(.*)/) {
- $val .= " $1";
- }
- elsif (!length) {
- last FOOTER;
- }
- else {
- $self->reason("Bad footer syntax");
- return;
- }
- }
- }
- $r->push_header($key, $val) if $key;
+
+ # Handle chunked transfer encoding
+ my $body = "";
+ CHUNK:
+ while (1) {
+ print STDERR "Chunked\n" if $DEBUG;
+ if ($buf =~ s/^([^\012]*)\012//) {
+ my $chunk_head = $1;
+ unless ($chunk_head =~ /^([0-9A-Fa-f]+)/) {
+ $self->send_error(400);
+ $self->reason("Bad chunk header $chunk_head");
+ return;
+ }
+ my $size = hex($1);
+ last CHUNK if $size == 0;
+
+ my $missing = $size - length($buf) + 2; # 2=CRLF at chunk end
+ # must read until we have a complete chunk
+ while ($missing > 0) {
+ print STDERR "Need $missing more bytes\n" if $DEBUG;
+ my $n = $self->_need_more($buf, $timeout, $fdset);
+ return unless $n;
+ $missing -= $n;
+ }
+ $body .= substr($buf, 0, $size);
+ substr($buf, 0, $size + 2) = '';
+
+ }
+ else {
+ # need more data in order to have a complete chunk header
+ return unless $self->_need_more($buf, $timeout, $fdset);
+ }
+ }
+ $r->content($body);
+
+ # pretend it was a normal entity body
+ $r->remove_header('Transfer-Encoding');
+ $r->header('Content-Length', length($body));
+
+ my ($key, $val);
+ FOOTER:
+ while (1) {
+ if ($buf !~ /\012/) {
+
+ # need at least one line to look at
+ return unless $self->_need_more($buf, $timeout, $fdset);
+ }
+ else {
+ $buf =~ s/^([^\012]*)\012//;
+ $_ = $1;
+ s/\015$//;
+ if (/^([\w\-]+)\s*:\s*(.*)/) {
+ $r->push_header($key, $val) if $key;
+ ($key, $val) = ($1, $2);
+ }
+ elsif (/^\s+(.*)/) {
+ $val .= " $1";
+ }
+ elsif (!length) {
+ last FOOTER;
+ }
+ else {
+ $self->reason("Bad footer syntax");
+ return;
+ }
+ }
+ }
+ $r->push_header($key, $val) if $key;
}
elsif ($te) {
- $self->send_error(501); # Unknown transfer encoding
- $self->reason("Unknown transfer encoding '$te'");
- return;
+ $self->send_error(501); # Unknown transfer encoding
+ $self->reason("Unknown transfer encoding '$te'");
+ return;
}
elsif ($len) {
- # Plain body specified by "Content-Length"
- my $missing = $len - length($buf);
- while ($missing > 0) {
- print "Need $missing more bytes of content\n" if $DEBUG;
- my $n = $self->_need_more($buf, $timeout, $fdset);
- return unless $n;
- $missing -= $n;
- }
- if (length($buf) > $len) {
- $r->content(substr($buf,0,$len));
- substr($buf, 0, $len) = '';
- }
- else {
- $r->content($buf);
- $buf='';
- }
+
+ # Plain body specified by "Content-Length"
+ my $missing = $len - length($buf);
+ while ($missing > 0) {
+ print "Need $missing more bytes of content\n" if $DEBUG;
+ my $n = $self->_need_more($buf, $timeout, $fdset);
+ return unless $n;
+ $missing -= $n;
+ }
+ if (length($buf) > $len) {
+ $r->content(substr($buf, 0, $len));
+ substr($buf, 0, $len) = '';
+ }
+ else {
+ $r->content($buf);
+ $buf = '';
+ }
}
elsif ($ct && $ct =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*("?)(\w+)\1/i) {
- # Handle multipart content type
- my $boundary = "$CRLF--$2--";
- my $index;
- while (1) {
- $index = index($buf, $boundary);
- last if $index >= 0;
- # end marker not yet found
- return unless $self->_need_more($buf, $timeout, $fdset);
- }
- $index += length($boundary);
- $r->content(substr($buf, 0, $index));
- substr($buf, 0, $index) = '';
+
+ # Handle multipart content type
+ my $boundary = "$CRLF--$2--";
+ my $index;
+ while (1) {
+ $index = index($buf, $boundary);
+ last if $index >= 0;
+
+ # end marker not yet found
+ return unless $self->_need_more($buf, $timeout, $fdset);
+ }
+ $index += length($boundary);
+ $r->content(substr($buf, 0, $index));
+ substr($buf, 0, $index) = '';
}
${*$self}{'httpd_rbuf'} = $buf;
@@ -319,19 +364,18 @@ sub get_request
$r;
}
-
-sub _need_more
-{
+sub _need_more {
my $self = shift;
+
#my($buf,$timeout,$fdset) = @_;
if ($_[1]) {
- my($timeout, $fdset) = @_[1,2];
- print STDERR "select(,,,$timeout)\n" if $DEBUG;
- my $n = select($fdset,undef,undef,$timeout);
- unless ($n) {
- $self->reason(defined($n) ? "Timeout" : "select: $!");
- return;
- }
+ my ($timeout, $fdset) = @_[1, 2];
+ print STDERR "select(,,,$timeout)\n" if $DEBUG;
+ my $n = select($fdset, undef, undef, $timeout);
+ unless ($n) {
+ $self->reason(defined($n) ? "Timeout" : "select: $!");
+ return;
+ }
}
print STDERR "sysread()\n" if $DEBUG;
my $n = sysread($self, $_[0], 2048, length($_[0]));
@@ -339,67 +383,53 @@ sub _need_more
$n;
}
-
-sub read_buffer
-{
+sub read_buffer {
my $self = shift;
- my $old = ${*$self}{'httpd_rbuf'};
+ my $old = ${*$self}{'httpd_rbuf'};
if (@_) {
- ${*$self}{'httpd_rbuf'} = shift;
+ ${*$self}{'httpd_rbuf'} = shift;
}
$old;
}
-
-sub reason
-{
+sub reason {
my $self = shift;
- my $old = ${*$self}{'httpd_reason'};
+ my $old = ${*$self}{'httpd_reason'};
if (@_) {
${*$self}{'httpd_reason'} = shift;
}
$old;
}
-
-sub proto_ge
-{
+sub proto_ge {
my $self = shift;
${*$self}{'httpd_client_proto'} >= _http_version(shift);
}
-
-sub _http_version
-{
- local($_) = shift;
+sub _http_version {
+ local ($_) = shift;
return 0 unless m,^(?:HTTP/)?(\d+)\.(\d+)$,i;
$1 * 1000 + $2;
}
-
-sub antique_client
-{
+sub antique_client {
my $self = shift;
${*$self}{'httpd_client_proto'} < $HTTP_1_0;
}
-
-sub force_last_request
-{
+sub force_last_request {
my $self = shift;
${*$self}{'httpd_nomore'}++;
}
-sub head_request
-{
+sub head_request {
my $self = shift;
${*$self}{'httpd_head'};
}
-sub send_status_line
-{
- my($self, $status, $message, $proto) = @_;
+sub send_status_line {
+ my ($self, $status, $message, $proto) = @_;
return if $self->antique_client;
$status ||= RC_OK;
$message ||= status_message($status) || "";
@@ -407,16 +437,12 @@ sub send_status_line
print $self "$proto $status $message$CRLF";
}
-
-sub send_crlf
-{
+sub send_crlf {
my $self = shift;
print $self $CRLF;
}
-
-sub send_basic_header
-{
+sub send_basic_header {
my $self = shift;
return if $self->antique_client;
$self->send_status_line(@_);
@@ -425,83 +451,80 @@ sub send_basic_header
print $self "Server: $product$CRLF" if $product;
}
-
-sub send_header
-{
+sub send_header {
my $self = shift;
while (@_) {
- my($k, $v) = splice(@_, 0, 2);
- $v = "" unless defined($v);
- print $self "$k: $v$CRLF";
+ my ($k, $v) = splice(@_, 0, 2);
+ $v = "" unless defined($v);
+ print $self "$k: $v$CRLF";
}
}
-
-sub send_response
-{
+sub send_response {
my $self = shift;
- my $res = shift;
+ my $res = shift;
if (!ref $res) {
- $res ||= RC_OK;
- $res = HTTP::Response->new($res, @_);
+ $res ||= RC_OK;
+ $res = HTTP::Response->new($res, @_);
}
my $content = $res->content;
my $chunked;
unless ($self->antique_client) {
- my $code = $res->code;
- $self->send_basic_header($code, $res->message, $res->protocol);
- if ($code =~ /^(1\d\d|[23]04)$/) {
- # make sure content is empty
- $res->remove_header("Content-Length");
- $content = "";
- }
- elsif ($res->request && $res->request->method eq "HEAD") {
- # probably OK
- }
- elsif (ref($content) eq "CODE") {
- if ($self->proto_ge("HTTP/1.1")) {
- $res->push_header("Transfer-Encoding" => "chunked");
- $chunked++;
- }
- else {
- $self->force_last_request;
- }
- }
- elsif (length($content)) {
- $res->header("Content-Length" => length($content));
- }
- else {
- $self->force_last_request;
- $res->header('connection','close');
- }
- print $self $res->headers_as_string($CRLF);
- print $self $CRLF; # separates headers and content
+ my $code = $res->code;
+ $self->send_basic_header($code, $res->message, $res->protocol);
+ if ($code =~ /^(1\d\d|[23]04)$/) {
+
+ # make sure content is empty
+ $res->remove_header("Content-Length");
+ $content = "";
+ }
+ elsif ($res->request && $res->request->method eq "HEAD") {
+
+ # probably OK
+ }
+ elsif (ref($content) eq "CODE") {
+ if ($self->proto_ge("HTTP/1.1")) {
+ $res->push_header("Transfer-Encoding" => "chunked");
+ $chunked++;
+ }
+ else {
+ $self->force_last_request;
+ }
+ }
+ elsif (length($content)) {
+ $res->header("Content-Length" => length($content));
+ }
+ else {
+ $self->force_last_request;
+ $res->header('connection', 'close');
+ }
+ print $self $res->headers_as_string($CRLF);
+ print $self $CRLF; # separates headers and content
}
if ($self->head_request) {
- # no content
+
+ # no content
}
elsif (ref($content) eq "CODE") {
- while (1) {
- my $chunk = &$content();
- last unless defined($chunk) && length($chunk);
- if ($chunked) {
- printf $self "%x%s%s%s", length($chunk), $CRLF, $chunk, $CRLF;
- }
- else {
- print $self $chunk;
- }
- }
- print $self "0$CRLF$CRLF" if $chunked; # no trailers either
+ while (1) {
+ my $chunk = &$content();
+ last unless defined($chunk) && length($chunk);
+ if ($chunked) {
+ printf $self "%x%s%s%s", length($chunk), $CRLF, $chunk, $CRLF;
+ }
+ else {
+ print $self $chunk;
+ }
+ }
+ print $self "0$CRLF$CRLF" if $chunked; # no trailers either
}
elsif (length $content) {
- print $self $content;
+ print $self $content;
}
}
-
-sub send_redirect
-{
- my($self, $loc, $status, $content) = @_;
+sub send_redirect {
+ my ($self, $loc, $status, $content) = @_;
$status ||= RC_MOVED_PERMANENTLY;
Carp::croak("Status '$status' is not redirect") unless is_redirect($status);
$self->send_basic_header($status);
@@ -509,23 +532,22 @@ sub send_redirect
$loc = $HTTP::URI_CLASS->new($loc, $base) unless ref($loc);
$loc = $loc->abs($base);
print $self "Location: $loc$CRLF";
+
if ($content) {
- my $ct = $content =~ /^\s*</ ? "text/html" : "text/plain";
- print $self "Content-Type: $ct$CRLF";
+ my $ct = $content =~ /^\s*</ ? "text/html" : "text/plain";
+ print $self "Content-Type: $ct$CRLF";
}
print $self $CRLF;
print $self $content if $content && !$self->head_request;
- $self->force_last_request; # no use keeping the connection open
+ $self->force_last_request; # no use keeping the connection open
}
-
-sub send_error
-{
- my($self, $status, $error) = @_;
+sub send_error {
+ my ($self, $status, $error) = @_;
$status ||= RC_BAD_REQUEST;
Carp::croak("Status '$status' is not an error") unless is_error($status);
my $mess = status_message($status);
- $error ||= "";
+ $error ||= "";
$mess = <<EOT;
<title>$status $mess</title>
<h1>$status $mess</h1>
@@ -534,79 +556,71 @@ EOT
unless ($self->antique_client) {
$self->send_basic_header($status);
print $self "Content-Type: text/html$CRLF";
- print $self "Content-Length: " . length($mess) . $CRLF;
+ print $self "Content-Length: " . length($mess) . $CRLF;
print $self $CRLF;
}
print $self $mess unless $self->head_request;
$status;
}
-
-sub send_file_response
-{
- my($self, $file) = @_;
+sub send_file_response {
+ my ($self, $file) = @_;
if (-d $file) {
- $self->send_dir($file);
+ $self->send_dir($file);
}
elsif (-f _) {
- # plain file
- local(*F);
- sysopen(F, $file, 0) or
- return $self->send_error(RC_FORBIDDEN);
- binmode(F);
- my($ct,$ce) = guess_media_type($file);
- my($size,$mtime) = (stat _)[7,9];
- unless ($self->antique_client) {
- $self->send_basic_header;
- print $self "Content-Type: $ct$CRLF";
- print $self "Content-Encoding: $ce$CRLF" if $ce;
- print $self "Content-Length: $size$CRLF" if $size;
- print $self "Last-Modified: ", time2str($mtime), "$CRLF" if $mtime;
- print $self $CRLF;
- }
- $self->send_file(\*F) unless $self->head_request;
- return RC_OK;
+
+ # plain file
+ local (*F);
+ sysopen(F, $file, 0) or return $self->send_error(RC_FORBIDDEN);
+ binmode(F);
+ my ($ct, $ce) = guess_media_type($file);
+ my ($size, $mtime) = (stat _)[7, 9];
+ unless ($self->antique_client) {
+ $self->send_basic_header;
+ print $self "Content-Type: $ct$CRLF";
+ print $self "Content-Encoding: $ce$CRLF" if $ce;
+ print $self "Content-Length: $size$CRLF" if $size;
+ print $self "Last-Modified: ", time2str($mtime), "$CRLF" if $mtime;
+ print $self $CRLF;
+ }
+ $self->send_file(\*F) unless $self->head_request;
+ return RC_OK;
}
else {
- $self->send_error(RC_NOT_FOUND);
+ $self->send_error(RC_NOT_FOUND);
}
}
-
-sub send_dir
-{
- my($self, $dir) = @_;
+sub send_dir {
+ my ($self, $dir) = @_;
$self->send_error(RC_NOT_FOUND) unless -d $dir;
$self->send_error(RC_NOT_IMPLEMENTED);
}
-
-sub send_file
-{
- my($self, $file) = @_;
+sub send_file {
+ my ($self, $file) = @_;
my $opened = 0;
- local(*FILE);
+ local (*FILE);
if (!ref($file)) {
- open(FILE, $file) || return undef;
- binmode(FILE);
- $file = \*FILE;
- $opened++;
+ open(FILE, $file) || return undef;
+ binmode(FILE);
+ $file = \*FILE;
+ $opened++;
}
my $cnt = 0;
my $buf = "";
my $n;
- while ($n = sysread($file, $buf, 8*1024)) {
- last if !$n;
- $cnt += $n;
- print $self $buf;
+ while ($n = sysread($file, $buf, 8 * 1024)) {
+ last if !$n;
+ $cnt += $n;
+ print $self $buf;
}
close($file) if $opened;
$cnt;
}
-
-sub daemon
-{
+sub daemon {
my $self = shift;
${*$self}{'httpd_daemon'};
}
@@ -616,9 +630,17 @@ sub daemon
__END__
+=pod
+
+=encoding UTF-8
+
=head1 NAME
-HTTP::Daemon - a simple http server class
+HTTP::Daemon - A simple http server class
+
+=head1 VERSION
+
+version 6.06
=head1 SYNOPSIS
@@ -645,12 +667,12 @@ HTTP::Daemon - a simple http server class
Instances of the C<HTTP::Daemon> class are HTTP/1.1 servers that
listen on a socket for incoming requests. The C<HTTP::Daemon> is a
-subclass of C<IO::Socket::INET>, so you can perform socket operations
+subclass of C<IO::Socket::IP>, so you can perform socket operations
directly on it too.
The accept() method will return when a connection from a client is
available. The returned value will be an C<HTTP::Daemon::ClientConn>
-object which is another C<IO::Socket::INET> subclass. Calling the
+object which is another C<IO::Socket::IP> subclass. Calling the
get_request() method on this object will read data from the client and
return an C<HTTP::Request> object. The ClientConn object also provide
methods to send back various responses.
@@ -661,7 +683,7 @@ desirable. Also note that the user is responsible for generating
responses that conform to the HTTP/1.1 protocol.
The following methods of C<HTTP::Daemon> are new (or enhanced) relative
-to the C<IO::Socket::INET> base class:
+to the C<IO::Socket::IP> base class:
=over 4
@@ -670,7 +692,7 @@ to the C<IO::Socket::INET> base class:
=item $d = HTTP::Daemon->new( %opts )
The constructor method takes the same arguments as the
-C<IO::Socket::INET> constructor, but unlike its base class it can also
+C<IO::Socket::IP> constructor, but unlike its base class it can also
be called without any arguments. The daemon will then set up a listen
queue of 5 connections and allocate some random port number.
@@ -682,7 +704,7 @@ HTTP port will be constructed like this:
LocalPort => 80,
);
-See L<IO::Socket::INET> for a description of other arguments that can
+See L<IO::Socket::IP> for a description of other arguments that can
be used configure the daemon during construction.
=item $c = $d->accept
@@ -699,7 +721,7 @@ class a subclass of C<HTTP::Daemon::ClientConn>.
The accept method will return C<undef> if timeouts have been enabled
and no connection is made within the given time. The timeout() method
-is described in L<IO::Socket>.
+is described in L<IO::Socket::IP>.
In list context both the client object and the peer address will be
returned; see the description of the accept method L<IO::Socket> for
@@ -721,7 +743,7 @@ replaced with the version number of this module.
=back
-The C<HTTP::Daemon::ClientConn> is a C<IO::Socket::INET>
+The C<HTTP::Daemon::ClientConn> is a C<IO::Socket::IP>
subclass. Instances of this class are returned by the accept() method
of C<HTTP::Daemon>. The following methods are provided:
@@ -895,12 +917,219 @@ Return a reference to the corresponding C<HTTP::Daemon> object.
RFC 2616
-L<IO::Socket::INET>, L<IO::Socket>
+L<IO::Socket::IP>, L<IO::Socket>
+
+=head1 SUPPORT
+
+bugs may be submitted through L<https://github.com/libwww-perl/HTTP-Daemon/issues>.
+
+There is also a mailing list available for users of this distribution, at
+L<mailto:libwww@perl.org>.
+
+There is also an irc channel available for users of this distribution, at
+L<C<#lwp> on C<irc.perl.org>|irc://irc.perl.org/#lwp>.
+
+=head1 AUTHOR
+
+Gisle Aas <gisle@activestate.com>
+
+=head1 CONTRIBUTORS
+
+=for stopwords Ville Skyttä Olaf Alders Mark Stosberg Karen Etheridge Chase Whitener Slaven Rezic Zefram Alexey Tourbin Bron Gondwana Petr Písař Mike Schilli Tom Hukins Ian Kilgore Jacob J Ondrej Hanak Perlover Peter Rabbitson Robert Stone Rolf Grossmann Sean M. Burke Spiros Denaxas Steve Hay Todd Lipcon Tony Finch Toru Yamaguchi Yuri Karaban amire80 jefflee john9art murphy phrstbrn ruff Adam Kennedy sasao Sjogren Alex Kapranoff Andreas J. Koenig Bill Mann DAVIDRW Daniel Hedlund David E. Wheeler FWILES Father Chrysostomos Gavin Peters Graeme Thompson Hans-H. Froehlich
+
+=over 4
+
+=item *
+
+Ville Skyttä <ville.skytta@iki.fi>
+
+=item *
+
+Olaf Alders <olaf@wundersolutions.com>
+
+=item *
+
+Mark Stosberg <MARKSTOS@cpan.org>
+
+=item *
+
+Karen Etheridge <ether@cpan.org>
+
+=item *
+
+Chase Whitener <capoeirab@cpan.org>
+
+=item *
+
+Slaven Rezic <slaven@rezic.de>
+
+=item *
+
+Zefram <zefram@fysh.org>
+
+=item *
+
+Alexey Tourbin <at@altlinux.ru>
+
+=item *
+
+Bron Gondwana <brong@fastmail.fm>
+
+=item *
+
+Petr Písař <ppisar@redhat.com>
+
+=item *
+
+Mike Schilli <mschilli@yahoo-inc.com>
+
+=item *
+
+Tom Hukins <tom@eborcom.com>
+
+=item *
+
+Ian Kilgore <iank@cpan.org>
+
+=item *
+
+Jacob J <waif@chaos2.org>
+
+=item *
+
+Ondrej Hanak <ondrej.hanak@ubs.com>
+
+=item *
+
+Perlover <perlover@perlover.com>
+
+=item *
+
+Peter Rabbitson <ribasushi@cpan.org>
+
+=item *
+
+Robert Stone <talby@trap.mtview.ca.us>
+
+=item *
+
+Rolf Grossmann <rg@progtech.net>
+
+=item *
+
+Sean M. Burke <sburke@cpan.org>
+
+=item *
+
+Spiros Denaxas <s.denaxas@gmail.com>
+
+=item *
+
+Steve Hay <SteveHay@planit.com>
+
+=item *
+
+Todd Lipcon <todd@amiestreet.com>
+
+=item *
+
+Tony Finch <dot@dotat.at>
+
+=item *
+
+Toru Yamaguchi <zigorou@cpan.org>
+
+=item *
+
+Yuri Karaban <tech@askold.net>
+
+=item *
+
+amire80 <amir.aharoni@gmail.com>
+
+=item *
+
+jefflee <shaohua@gmail.com>
+
+=item *
+
+john9art <john9art@yahoo.com>
+
+=item *
+
+murphy <murphy@genome.chop.edu>
+
+=item *
+
+phrstbrn <phrstbrn@gmail.com>
+
+=item *
+
+ruff <ruff@ukrpost.net>
+
+=item *
+
+Adam Kennedy <adamk@cpan.org>
+
+=item *
+
+sasao <sasao@yugen.org>
+
+=item *
+
+Adam Sjogren <asjo@koldfront.dk>
+
+=item *
+
+Alex Kapranoff <ka@nadoby.ru>
+
+=item *
+
+Andreas J. Koenig <andreas.koenig@anima.de>
+
+=item *
+
+Bill Mann <wfmann@alum.mit.edu>
+
+=item *
+
+DAVIDRW <davidrw@cpan.org>
+
+=item *
+
+Daniel Hedlund <Daniel.Hedlund@eprize.com>
+
+=item *
+
+David E. Wheeler <david@justatheory.com>
+
+=item *
+
+FWILES <FWILES@cpan.org>
+
+=item *
+
+Father Chrysostomos <sprout@cpan.org>
+
+=item *
+
+Gavin Peters <gpeters@deepsky.com>
+
+=item *
+
+Graeme Thompson <Graeme.Thompson@mobilecohesion.com>
+
+=item *
+
+Hans-H. Froehlich <hfroehlich@co-de-co.de>
+
+=back
-=head1 COPYRIGHT
+=head1 COPYRIGHT AND LICENCE
-Copyright 1996-2003, Gisle Aas
+This software is copyright (c) 1995 by Gisle Aas.
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
+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
diff --git a/Master/tlpkg/tlperl/site/lib/HTTP/Date.pm b/Master/tlpkg/tlperl/site/lib/HTTP/Date.pm
index d05d21605ae..a57d0b8deda 100644
--- a/Master/tlpkg/tlperl/site/lib/HTTP/Date.pm
+++ b/Master/tlpkg/tlperl/site/lib/HTTP/Date.pm
@@ -1,175 +1,188 @@
package HTTP::Date;
-$VERSION = "6.02";
+use strict;
+
+our $VERSION = '6.05';
require Exporter;
-@ISA = qw(Exporter);
-@EXPORT = qw(time2str str2time);
-@EXPORT_OK = qw(parse_date time2iso time2isoz);
+our @ISA = qw(Exporter);
+our @EXPORT = qw(time2str str2time);
+our @EXPORT_OK = qw(parse_date time2iso time2isoz);
-use strict;
require Time::Local;
-use vars qw(@DoW @MoY %MoY);
-@DoW = qw(Sun Mon Tue Wed Thu Fri Sat);
-@MoY = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
-@MoY{@MoY} = (1..12);
-
-my %GMT_ZONE = (GMT => 1, UTC => 1, UT => 1, Z => 1);
+our ( @DoW, @MoY, %MoY );
+@DoW = qw(Sun Mon Tue Wed Thu Fri Sat);
+@MoY = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
+@MoY{@MoY} = ( 1 .. 12 );
+my %GMT_ZONE = ( GMT => 1, UTC => 1, UT => 1, Z => 1 );
-sub time2str (;$)
-{
+sub time2str (;$) {
my $time = shift;
$time = time unless defined $time;
- my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($time);
- sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
- $DoW[$wday],
- $mday, $MoY[$mon], $year+1900,
- $hour, $min, $sec);
+ my ( $sec, $min, $hour, $mday, $mon, $year, $wday ) = gmtime($time);
+ sprintf(
+ "%s, %02d %s %04d %02d:%02d:%02d GMT",
+ $DoW[$wday],
+ $mday, $MoY[$mon], $year + 1900,
+ $hour, $min, $sec
+ );
}
-
-sub str2time ($;$)
-{
+sub str2time ($;$) {
my $str = shift;
return undef unless defined $str;
# fast exit for strictly conforming string
- if ($str =~ /^[SMTWF][a-z][a-z], (\d\d) ([JFMAJSOND][a-z][a-z]) (\d\d\d\d) (\d\d):(\d\d):(\d\d) GMT$/) {
- return eval {
- my $t = Time::Local::timegm($6, $5, $4, $1, $MoY{$2}-1, $3);
- $t < 0 ? undef : $t;
- };
+ if ( $str
+ =~ /^[SMTWF][a-z][a-z], (\d\d) ([JFMAJSOND][a-z][a-z]) (\d\d\d\d) (\d\d):(\d\d):(\d\d) GMT$/
+ ) {
+ return eval {
+ my $t = Time::Local::timegm( $6, $5, $4, $1, $MoY{$2} - 1, $3 );
+ $t < 0 ? undef : $t;
+ };
}
my @d = parse_date($str);
return undef unless @d;
- $d[1]--; # month
+ $d[1]--; # month
my $tz = pop(@d);
- unless (defined $tz) {
- unless (defined($tz = shift)) {
- return eval { my $frac = $d[-1]; $frac -= ($d[-1] = int($frac));
- my $t = Time::Local::timelocal(reverse @d) + $frac;
- $t < 0 ? undef : $t;
- };
- }
+ unless ( defined $tz ) {
+ unless ( defined( $tz = shift ) ) {
+ return eval {
+ my $frac = $d[-1];
+ $frac -= ( $d[-1] = int($frac) );
+ my $t = Time::Local::timelocal( reverse @d ) + $frac;
+ $t < 0 ? undef : $t;
+ };
+ }
}
my $offset = 0;
- if ($GMT_ZONE{uc $tz}) {
- # offset already zero
+ if ( $GMT_ZONE{ uc $tz } ) {
+
+ # offset already zero
}
- elsif ($tz =~ /^([-+])?(\d\d?):?(\d\d)?$/) {
- $offset = 3600 * $2;
- $offset += 60 * $3 if $3;
- $offset *= -1 if $1 && $1 eq '-';
+ elsif ( $tz =~ /^([-+])?(\d\d?):?(\d\d)?$/ ) {
+ $offset = 3600 * $2;
+ $offset += 60 * $3 if $3;
+ $offset *= -1 if $1 && $1 eq '-';
}
else {
- eval { require Time::Zone } || return undef;
- $offset = Time::Zone::tz_offset($tz);
- return undef unless defined $offset;
+ eval { require Time::Zone } || return undef;
+ $offset = Time::Zone::tz_offset($tz);
+ return undef unless defined $offset;
}
- return eval { my $frac = $d[-1]; $frac -= ($d[-1] = int($frac));
- my $t = Time::Local::timegm(reverse @d) + $frac;
- $t < 0 ? undef : $t - $offset;
- };
+ return eval {
+ my $frac = $d[-1];
+ $frac -= ( $d[-1] = int($frac) );
+ my $t = Time::Local::timegm( reverse @d ) + $frac;
+ $t < 0 ? undef : $t - $offset;
+ };
}
-
-sub parse_date ($)
-{
- local($_) = shift;
+sub parse_date ($) {
+ local ($_) = shift;
return unless defined;
# More lax parsing below
- s/^\s+//; # kill leading space
- s/^(?:Sun|Mon|Tue|Wed|Thu|Fri|Sat)[a-z]*,?\s*//i; # Useless weekday
+ s/^\s+//; # kill leading space
+ s/^(?:Sun|Mon|Tue|Wed|Thu|Fri|Sat)[a-z]*,?\s*//i; # Useless weekday
- my($day, $mon, $yr, $hr, $min, $sec, $tz, $ampm);
+ my ( $day, $mon, $yr, $hr, $min, $sec, $tz, $ampm );
# Then we are able to check for most of the formats with this regexp
- (($day,$mon,$yr,$hr,$min,$sec,$tz) =
- /^
- (\d\d?) # day
- (?:\s+|[-\/])
- (\w+) # month
- (?:\s+|[-\/])
- (\d+) # year
- (?:
- (?:\s+|:) # separator before clock
- (\d\d?):(\d\d) # hour:min
- (?::(\d\d))? # optional seconds
- )? # optional clock
- \s*
- ([-+]?\d{2,4}|(?![APap][Mm]\b)[A-Za-z]+)? # timezone
- \s*
- (?:\(\w+\)|\w{3,})? # ASCII representation of timezone.
- \s*$
- /x)
-
- ||
-
- # Try the ctime and asctime format
- (($mon, $day, $hr, $min, $sec, $tz, $yr) =
- /^
- (\w{1,3}) # month
- \s+
- (\d\d?) # day
- \s+
- (\d\d?):(\d\d) # hour:min
- (?::(\d\d))? # optional seconds
- \s+
- (?:([A-Za-z]+)\s+)? # optional timezone
- (\d+) # year
- \s*$ # allow trailing whitespace
- /x)
-
- ||
-
- # Then the Unix 'ls -l' date format
- (($mon, $day, $yr, $hr, $min, $sec) =
- /^
- (\w{3}) # month
- \s+
- (\d\d?) # day
- \s+
- (?:
- (\d\d\d\d) | # year
- (\d{1,2}):(\d{2}) # hour:min
+ (
+ ( $day, $mon, $yr, $hr, $min, $sec, $tz )
+ = /^
+ (\d\d?) # day
+ (?:\s+|[-\/])
+ (\w+) # month
+ (?:\s+|[-\/])
+ (\d+) # year
+ (?:
+ (?:\s+|:) # separator before clock
+ (\d\d?):(\d\d) # hour:min
+ (?::(\d\d))? # optional seconds
+ )? # optional clock
+ \s*
+ ([-+]?\d{2,4}|(?![APap][Mm]\b)[A-Za-z]+)? # timezone
+ \s*
+ (?:\(\w+\)|\w{3,})? # ASCII representation of timezone.
+ \s*$
+ /x
+ )
+
+ ||
+
+ # Try the ctime and asctime format
+ (
+ ( $mon, $day, $hr, $min, $sec, $tz, $yr )
+ = /^
+ (\w{1,3}) # month
+ \s+
+ (\d\d?) # day
+ \s+
+ (\d\d?):(\d\d) # hour:min
+ (?::(\d\d))? # optional seconds
+ \s+
+ (?:([A-Za-z]+)\s+)? # optional timezone
+ (\d+) # year
+ \s*$ # allow trailing whitespace
+ /x
+ )
+
+ ||
+
+ # Then the Unix 'ls -l' date format
+ (
+ ( $mon, $day, $yr, $hr, $min, $sec )
+ = /^
+ (\w{3}) # month
+ \s+
+ (\d\d?) # day
+ \s+
+ (?:
+ (\d\d\d\d) | # year
+ (\d{1,2}):(\d{2}) # hour:min
(?::(\d\d))? # optional seconds
- )
- \s*$
- /x)
-
- ||
-
- # ISO 8601 format '1996-02-29 12:00:00 -0100' and variants
- (($yr, $mon, $day, $hr, $min, $sec, $tz) =
- /^
- (\d{4}) # year
- [-\/]?
- (\d\d?) # numerical month
- [-\/]?
- (\d\d?) # day
- (?:
- (?:\s+|[-:Tt]) # separator before clock
- (\d\d?):?(\d\d) # hour:min
- (?::?(\d\d(?:\.\d*)?))? # optional seconds (and fractional)
- )? # optional clock
- \s*
- ([-+]?\d\d?:?(:?\d\d)?
- |Z|z)? # timezone (Z is "zero meridian", i.e. GMT)
- \s*$
- /x)
-
- ||
-
- # Windows 'dir' 11-12-96 03:52PM
- (($mon, $day, $yr, $hr, $min, $ampm) =
- /^
+ )
+ \s*$
+ /x
+ )
+
+ ||
+
+ # ISO 8601 format '1996-02-29 12:00:00 -0100' and variants
+ (
+ ( $yr, $mon, $day, $hr, $min, $sec, $tz )
+ = /^
+ (\d{4}) # year
+ [-\/]?
+ (\d\d?) # numerical month
+ [-\/]?
+ (\d\d?) # day
+ (?:
+ (?:\s+|[-:Tt]) # separator before clock
+ (\d\d?):?(\d\d) # hour:min
+ (?::?(\d\d(?:\.\d*)?))? # optional seconds (and fractional)
+ )? # optional clock
+ \s*
+ ([-+]?\d\d?:?(:?\d\d)?
+ |Z|z)? # timezone (Z is "zero meridian", i.e. GMT)
+ \s*$
+ /x
+ )
+
+ ||
+
+ # Windows 'dir' 11-12-96 03:52PM
+ (
+ ( $mon, $day, $yr, $hr, $min, $ampm )
+ = /^
(\d{2}) # numerical month
-
(\d{2}) # day
@@ -178,36 +191,38 @@ sub parse_date ($)
\s+
(\d\d?):(\d\d)([APap][Mm]) # hour:min AM or PM
\s*$
- /x)
+ /x
+ )
- ||
- return; # unrecognized format
+ || return; # unrecognized format
# Translate month name to number
- $mon = $MoY{$mon} ||
- $MoY{"\u\L$mon"} ||
- ($mon =~ /^\d\d?$/ && $mon >= 1 && $mon <= 12 && int($mon)) ||
- return;
+ $mon
+ = $MoY{$mon}
+ || $MoY{"\u\L$mon"}
+ || ( $mon =~ /^\d\d?$/ && $mon >= 1 && $mon <= 12 && int($mon) )
+ || return;
# If the year is missing, we assume first date before the current,
# because of the formats we support such dates are mostly present
# on "ls -l" listings.
- unless (defined $yr) {
- my $cur_mon;
- ($cur_mon, $yr) = (localtime)[4, 5];
- $yr += 1900;
- $cur_mon++;
- $yr-- if $mon > $cur_mon;
+ unless ( defined $yr ) {
+ my $cur_mon;
+ ( $cur_mon, $yr ) = (localtime)[ 4, 5 ];
+ $yr += 1900;
+ $cur_mon++;
+ $yr-- if $mon > $cur_mon;
}
- elsif (length($yr) < 3) {
- # Find "obvious" year
- my $cur_yr = (localtime)[5] + 1900;
- my $m = $cur_yr % 100;
- my $tmp = $yr;
- $yr += $cur_yr - $m;
- $m -= $tmp;
- $yr += ($m > 0) ? 100 : -100
- if abs($m) > 50;
+ elsif ( length($yr) < 3 ) {
+
+ # Find "obvious" year
+ my $cur_yr = (localtime)[5] + 1900;
+ my $m = $cur_yr % 100;
+ my $tmp = $yr;
+ $yr += $cur_yr - $m;
+ $m -= $tmp;
+ $yr += ( $m > 0 ) ? 100 : -100
+ if abs($m) > 50;
}
# Make sure clock elements are defined
@@ -217,52 +232,64 @@ sub parse_date ($)
# Compensate for AM/PM
if ($ampm) {
- $ampm = uc $ampm;
- $hr = 0 if $hr == 12 && $ampm eq 'AM';
- $hr += 12 if $ampm eq 'PM' && $hr != 12;
+ $ampm = uc $ampm;
+ $hr = 0 if $hr == 12 && $ampm eq 'AM';
+ $hr += 12 if $ampm eq 'PM' && $hr != 12;
}
- return($yr, $mon, $day, $hr, $min, $sec, $tz)
- if wantarray;
+ return ( $yr, $mon, $day, $hr, $min, $sec, $tz )
+ if wantarray;
- if (defined $tz) {
- $tz = "Z" if $tz =~ /^(GMT|UTC?|[-+]?0+)$/;
+ if ( defined $tz ) {
+ $tz = "Z" if $tz =~ /^(GMT|UTC?|[-+]?0+)$/;
}
else {
- $tz = "";
+ $tz = "";
}
- return sprintf("%04d-%02d-%02d %02d:%02d:%02d%s",
- $yr, $mon, $day, $hr, $min, $sec, $tz);
+ return sprintf(
+ "%04d-%02d-%02d %02d:%02d:%02d%s",
+ $yr, $mon, $day, $hr, $min, $sec, $tz
+ );
}
-
-sub time2iso (;$)
-{
+sub time2iso (;$) {
my $time = shift;
$time = time unless defined $time;
- my($sec,$min,$hour,$mday,$mon,$year) = localtime($time);
- sprintf("%04d-%02d-%02d %02d:%02d:%02d",
- $year+1900, $mon+1, $mday, $hour, $min, $sec);
+ my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime($time);
+ sprintf(
+ "%04d-%02d-%02d %02d:%02d:%02d",
+ $year + 1900, $mon + 1, $mday, $hour, $min, $sec
+ );
}
-
-sub time2isoz (;$)
-{
+sub time2isoz (;$) {
my $time = shift;
$time = time unless defined $time;
- my($sec,$min,$hour,$mday,$mon,$year) = gmtime($time);
- sprintf("%04d-%02d-%02d %02d:%02d:%02dZ",
- $year+1900, $mon+1, $mday, $hour, $min, $sec);
+ my ( $sec, $min, $hour, $mday, $mon, $year ) = gmtime($time);
+ sprintf(
+ "%04d-%02d-%02d %02d:%02d:%02dZ",
+ $year + 1900, $mon + 1, $mday, $hour, $min, $sec
+ );
}
1;
+# ABSTRACT: HTTP::Date - date conversion routines
+#
__END__
+=pod
+
+=encoding UTF-8
+
=head1 NAME
-HTTP::Date - date conversion routines
+HTTP::Date - HTTP::Date - date conversion routines
+
+=head1 VERSION
+
+version 6.05
=head1 SYNOPSIS
@@ -371,18 +398,21 @@ string representing time in the local time zone.
Same as time2str(), but returns a "YYYY-MM-DD hh:mm:ssZ"-formatted
string representing Universal Time.
-
=back
=head1 SEE ALSO
L<perlfunc/time>, L<Time::Zone>
-=head1 COPYRIGHT
+=head1 AUTHOR
+
+Gisle Aas <gisle@activestate.com>
+
+=head1 COPYRIGHT AND LICENSE
-Copyright 1995-1999, Gisle Aas
+This software is copyright (c) 1995-2019 by Gisle Aas.
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
+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
diff --git a/Master/tlpkg/tlperl/site/lib/HTTP/Headers.pm b/Master/tlpkg/tlperl/site/lib/HTTP/Headers.pm
index 1c25c799828..4e7b1054a0d 100644
--- a/Master/tlpkg/tlperl/site/lib/HTTP/Headers.pm
+++ b/Master/tlpkg/tlperl/site/lib/HTTP/Headers.pm
@@ -3,7 +3,7 @@ package HTTP::Headers;
use strict;
use warnings;
-our $VERSION = '6.18';
+our $VERSION = '6.22';
use Carp ();
@@ -475,7 +475,7 @@ HTTP::Headers - Class encapsulating HTTP Message headers
=head1 VERSION
-version 6.18
+version 6.22
=head1 SYNOPSIS
diff --git a/Master/tlpkg/tlperl/site/lib/HTTP/Headers/Auth.pm b/Master/tlpkg/tlperl/site/lib/HTTP/Headers/Auth.pm
index 462cf628dac..0e9f16d8496 100644
--- a/Master/tlpkg/tlperl/site/lib/HTTP/Headers/Auth.pm
+++ b/Master/tlpkg/tlperl/site/lib/HTTP/Headers/Auth.pm
@@ -3,7 +3,7 @@ package HTTP::Headers::Auth;
use strict;
use warnings;
-our $VERSION = '6.18';
+our $VERSION = '6.22';
use HTTP::Headers;
@@ -111,7 +111,7 @@ HTTP::Headers::Auth
=head1 VERSION
-version 6.18
+version 6.22
=head1 AUTHOR
diff --git a/Master/tlpkg/tlperl/site/lib/HTTP/Headers/ETag.pm b/Master/tlpkg/tlperl/site/lib/HTTP/Headers/ETag.pm
index 02d6249b06c..e7013e7a4dc 100644
--- a/Master/tlpkg/tlperl/site/lib/HTTP/Headers/ETag.pm
+++ b/Master/tlpkg/tlperl/site/lib/HTTP/Headers/ETag.pm
@@ -3,7 +3,7 @@ package HTTP::Headers::ETag;
use strict;
use warnings;
-our $VERSION = '6.18';
+our $VERSION = '6.22';
require HTTP::Date;
@@ -107,7 +107,7 @@ HTTP::Headers::ETag
=head1 VERSION
-version 6.18
+version 6.22
=head1 AUTHOR
diff --git a/Master/tlpkg/tlperl/site/lib/HTTP/Headers/Util.pm b/Master/tlpkg/tlperl/site/lib/HTTP/Headers/Util.pm
index dc07eb32ad2..4a44b4235d9 100644
--- a/Master/tlpkg/tlperl/site/lib/HTTP/Headers/Util.pm
+++ b/Master/tlpkg/tlperl/site/lib/HTTP/Headers/Util.pm
@@ -3,7 +3,7 @@ package HTTP::Headers::Util;
use strict;
use warnings;
-our $VERSION = '6.18';
+our $VERSION = '6.22';
use base 'Exporter';
@@ -103,7 +103,7 @@ HTTP::Headers::Util - Header value parsing utility functions
=head1 VERSION
-version 6.18
+version 6.22
=head1 SYNOPSIS
diff --git a/Master/tlpkg/tlperl/site/lib/HTTP/Message.pm b/Master/tlpkg/tlperl/site/lib/HTTP/Message.pm
index 078209e8edf..c680b41f4ff 100644
--- a/Master/tlpkg/tlperl/site/lib/HTTP/Message.pm
+++ b/Master/tlpkg/tlperl/site/lib/HTTP/Message.pm
@@ -3,7 +3,7 @@ package HTTP::Message;
use strict;
use warnings;
-our $VERSION = '6.18';
+our $VERSION = '6.22';
require HTTP::Headers;
require Carp;
@@ -417,6 +417,7 @@ sub decodable
# should match the Content-Encoding values that decoded_content can deal with
my $self = shift;
my @enc;
+ local $@;
# XXX preferably we should determine if the modules are available without loading
# them here
eval {
@@ -781,7 +782,7 @@ HTTP::Message - HTTP style message (base class)
=head1 VERSION
-version 6.18
+version 6.22
=head1 SYNOPSIS
diff --git a/Master/tlpkg/tlperl/site/lib/HTTP/Request.pm b/Master/tlpkg/tlperl/site/lib/HTTP/Request.pm
index 8998ceda3b0..6eee474db2b 100644
--- a/Master/tlpkg/tlperl/site/lib/HTTP/Request.pm
+++ b/Master/tlpkg/tlperl/site/lib/HTTP/Request.pm
@@ -3,7 +3,7 @@ package HTTP::Request;
use strict;
use warnings;
-our $VERSION = '6.18';
+our $VERSION = '6.22';
use base 'HTTP::Message';
@@ -92,7 +92,17 @@ sub uri
sub uri_canonical
{
my $self = shift;
- return $self->{'_uri_canonical'} ||= $self->{'_uri'}->canonical;
+
+ my $uri = $self->{_uri};
+
+ if (defined (my $canon = $self->{_uri_canonical})) {
+ # early bailout if these are the exact same string; try to use
+ # the cheapest comparison method possible
+ return $canon if $$canon eq $$uri;
+ }
+
+ # otherwise we need to refresh the memoized value
+ $self->{_uri_canonical} = $uri->canonical;
}
@@ -145,7 +155,7 @@ HTTP::Request - HTTP style request message
=head1 VERSION
-version 6.18
+version 6.22
=head1 SYNOPSIS
@@ -251,14 +261,13 @@ to an endpoint.
use strict;
use warnings;
- use Encode qw(encode_utf8);
use HTTP::Request ();
use JSON::MaybeXS qw(encode_json);
my $url = 'https://www.example.com/api/user/123';
my $header = ['Content-Type' => 'application/json; charset=UTF-8'];
my $data = {foo => 'bar', baz => 'quux'};
- my $encoded_data = encode_utf8(encode_json($data));
+ my $encoded_data = encode_json($data);
my $r = HTTP::Request->new('POST', $url, $header, $encoded_data);
# at this point, we could send it via LWP::UserAgent
@@ -276,7 +285,6 @@ C<add_part> method from L<HTTP::Message> makes this simple.
use strict;
use warnings;
- use Encode qw(encode_utf8);
use HTTP::Request ();
use JSON::MaybeXS qw(encode_json);
@@ -317,7 +325,7 @@ C<add_part> method from L<HTTP::Message> makes this simple.
sub build_json_request {
my ($url, $href) = @_;
my $header = ['Authorization' => "Bearer $auth_token", 'Content-Type' => 'application/json; charset=UTF-8'];
- return HTTP::Request->new('POST', $url, $header, encode_utf8(encode_json($href)));
+ return HTTP::Request->new('POST', $url, $header, encode_json($href));
}
=head1 SEE ALSO
diff --git a/Master/tlpkg/tlperl/site/lib/HTTP/Request/Common.pm b/Master/tlpkg/tlperl/site/lib/HTTP/Request/Common.pm
index d70a9395710..17833c8f4f9 100644
--- a/Master/tlpkg/tlperl/site/lib/HTTP/Request/Common.pm
+++ b/Master/tlpkg/tlperl/site/lib/HTTP/Request/Common.pm
@@ -3,13 +3,13 @@ package HTTP::Request::Common;
use strict;
use warnings;
-our $VERSION = '6.18';
+our $VERSION = '6.22';
our $DYNAMIC_FILE_UPLOAD ||= 0; # make it defined (don't know why)
use Exporter 5.57 'import';
-our @EXPORT =qw(GET HEAD PUT PATCH POST);
+our @EXPORT =qw(GET HEAD PUT PATCH POST OPTIONS);
our @EXPORT_OK = qw($DYNAMIC_FILE_UPLOAD DELETE);
require HTTP::Request;
@@ -23,6 +23,7 @@ sub DELETE { _simple_req('DELETE', @_); }
sub PATCH { request_type_with_data('PATCH', @_); }
sub POST { request_type_with_data('POST', @_); }
sub PUT { request_type_with_data('PUT', @_); }
+sub OPTIONS { request_type_with_data('OPTIONS', @_); }
sub request_type_with_data
{
@@ -312,7 +313,7 @@ HTTP::Request::Common - Construct common HTTP::Request objects
=head1 VERSION
-version 6.18
+version 6.22
=head1 SYNOPSIS
@@ -322,6 +323,7 @@ version 6.18
$ua->request(POST 'http://somewhere/foo', [foo => bar, bar => foo]);
$ua->request(PATCH 'http://somewhere/foo', [foo => bar, bar => foo]);
$ua->request(PUT 'http://somewhere/foo', [foo => bar, bar => foo]);
+ $ua->request(OPTIONS 'http://somewhere/foo', [foo => bar, bar => foo]);
=head1 DESCRIPTION
@@ -398,6 +400,18 @@ The same as C<POST> below, but the method in the request is C<PATCH>.
The same as C<POST> below, but the method in the request is C<PUT>
+=item OPTIONS $url
+
+=item OPTIONS $url, Header => Value,...
+
+=item OPTIONS $url, $form_ref, Header => Value,...
+
+=item OPTIONS $url, Header => Value,..., Content => $form_ref
+
+=item OPTIONS $url, Header => Value,..., Content => $content
+
+The same as C<POST> below, but the method in the request is C<OPTIONS>
+
=item POST $url
=item POST $url, Header => Value,...
diff --git a/Master/tlpkg/tlperl/site/lib/HTTP/Response.pm b/Master/tlpkg/tlperl/site/lib/HTTP/Response.pm
index 31d7a387fe0..e212586d0b5 100644
--- a/Master/tlpkg/tlperl/site/lib/HTTP/Response.pm
+++ b/Master/tlpkg/tlperl/site/lib/HTTP/Response.pm
@@ -3,7 +3,7 @@ package HTTP::Response;
use strict;
use warnings;
-our $VERSION = '6.18';
+our $VERSION = '6.22';
use base 'HTTP::Message';
@@ -351,7 +351,7 @@ HTTP::Response - HTTP style response message
=head1 VERSION
-version 6.18
+version 6.22
=head1 SYNOPSIS
diff --git a/Master/tlpkg/tlperl/site/lib/HTTP/Status.pm b/Master/tlpkg/tlperl/site/lib/HTTP/Status.pm
index 8cf997464fa..b7cf8fc1f98 100644
--- a/Master/tlpkg/tlperl/site/lib/HTTP/Status.pm
+++ b/Master/tlpkg/tlperl/site/lib/HTTP/Status.pm
@@ -3,7 +3,7 @@ package HTTP::Status;
use strict;
use warnings;
-our $VERSION = '6.18';
+our $VERSION = '6.22';
require 5.002; # because we use prototypes
@@ -162,7 +162,7 @@ HTTP::Status - HTTP Status code processing
=head1 VERSION
-version 6.18
+version 6.22
=head1 SYNOPSIS