summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/HTTP
diff options
context:
space:
mode:
authorKarl Berry <karl@freefriends.org>2016-04-05 22:27:26 +0000
committerKarl Berry <karl@freefriends.org>2016-04-05 22:27:26 +0000
commitb56b320b5e2515160073fa1b469514002688fe11 (patch)
tree965a7100c5e45fca8ec803d22b8b6ce14fca4633 /Master/tlpkg/tlperl/lib/HTTP
parentd26c206452d2e285c3bbf949f34011e4a55fd8f9 (diff)
tlperl 5.22.1 from siep
git-svn-id: svn://tug.org/texlive/trunk@40252 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/HTTP')
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Config.pm436
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Cookies.pm781
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Cookies/Microsoft.pm329
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Cookies/Netscape.pm114
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Daemon.pm906
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Date.pm388
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Headers.pm854
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Headers/Auth.pm98
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Headers/ETag.pm94
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Headers/Util.pm199
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Message.pm1106
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Negotiate.pm528
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Request.pm242
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Request/Common.pm514
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Response.pm637
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Status.pm267
-rw-r--r--Master/tlpkg/tlperl/lib/HTTP/Tiny.pm726
17 files changed, 383 insertions, 7836 deletions
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Config.pm b/Master/tlpkg/tlperl/lib/HTTP/Config.pm
deleted file mode 100644
index 931f63db69d..00000000000
--- a/Master/tlpkg/tlperl/lib/HTTP/Config.pm
+++ /dev/null
@@ -1,436 +0,0 @@
-package HTTP::Config;
-
-use strict;
-use URI;
-use vars qw($VERSION);
-
-$VERSION = "6.00";
-
-sub new {
- my $class = shift;
- return bless [], $class;
-}
-
-sub entries {
- my $self = shift;
- @$self;
-}
-
-sub empty {
- my $self = shift;
- not @$self;
-}
-
-sub add {
- if (@_ == 2) {
- my $self = shift;
- push(@$self, shift);
- return;
- }
- my($self, %spec) = @_;
- push(@$self, \%spec);
- return;
-}
-
-sub find2 {
- my($self, %spec) = @_;
- my @found;
- my @rest;
- ITEM:
- for my $item (@$self) {
- for my $k (keys %spec) {
- if (!exists $item->{$k} || $spec{$k} ne $item->{$k}) {
- push(@rest, $item);
- next ITEM;
- }
- }
- push(@found, $item);
- }
- return \@found unless wantarray;
- return \@found, \@rest;
-}
-
-sub find {
- my $self = shift;
- my $f = $self->find2(@_);
- return @$f if wantarray;
- return $f->[0];
-}
-
-sub remove {
- my($self, %spec) = @_;
- my($removed, $rest) = $self->find2(%spec);
- @$self = @$rest if @$removed;
- return @$removed;
-}
-
-my %MATCH = (
- m_scheme => sub {
- my($v, $uri) = @_;
- return $uri->_scheme eq $v; # URI known to be canonical
- },
- m_secure => sub {
- my($v, $uri) = @_;
- my $secure = $uri->can("secure") ? $uri->secure : $uri->_scheme eq "https";
- return $secure == !!$v;
- },
- m_host_port => sub {
- my($v, $uri) = @_;
- return unless $uri->can("host_port");
- return $uri->host_port eq $v, 7;
- },
- m_host => sub {
- my($v, $uri) = @_;
- return unless $uri->can("host");
- return $uri->host eq $v, 6;
- },
- m_port => sub {
- my($v, $uri) = @_;
- return unless $uri->can("port");
- return $uri->port eq $v;
- },
- m_domain => sub {
- my($v, $uri) = @_;
- return unless $uri->can("host");
- my $h = $uri->host;
- $h = "$h.local" unless $h =~ /\./;
- $v = ".$v" unless $v =~ /^\./;
- return length($v), 5 if substr($h, -length($v)) eq $v;
- return 0;
- },
- m_path => sub {
- my($v, $uri) = @_;
- return unless $uri->can("path");
- return $uri->path eq $v, 4;
- },
- m_path_prefix => sub {
- my($v, $uri) = @_;
- return unless $uri->can("path");
- my $path = $uri->path;
- my $len = length($v);
- return $len, 3 if $path eq $v;
- return 0 if length($path) <= $len;
- $v .= "/" unless $v =~ m,/\z,,;
- return $len, 3 if substr($path, 0, length($v)) eq $v;
- return 0;
- },
- m_path_match => sub {
- my($v, $uri) = @_;
- return unless $uri->can("path");
- return $uri->path =~ $v;
- },
- m_uri__ => sub {
- my($v, $k, $uri) = @_;
- return unless $uri->can($k);
- return 1 unless defined $v;
- return $uri->$k eq $v;
- },
- m_method => sub {
- my($v, $uri, $request) = @_;
- return $request && $request->method eq $v;
- },
- m_proxy => sub {
- my($v, $uri, $request) = @_;
- return $request && ($request->{proxy} || "") eq $v;
- },
- m_code => sub {
- my($v, $uri, $request, $response) = @_;
- $v =~ s/xx\z//;
- return unless $response;
- return length($v), 2 if substr($response->code, 0, length($v)) eq $v;
- },
- m_media_type => sub { # for request too??
- my($v, $uri, $request, $response) = @_;
- return unless $response;
- return 1, 1 if $v eq "*/*";
- my $ct = $response->content_type;
- return 2, 1 if $v =~ s,/\*\z,, && $ct =~ m,^\Q$v\E/,;
- return 3, 1 if $v eq "html" && $response->content_is_html;
- return 4, 1 if $v eq "xhtml" && $response->content_is_xhtml;
- return 10, 1 if $v eq $ct;
- return 0;
- },
- m_header__ => sub {
- my($v, $k, $uri, $request, $response) = @_;
- return unless $request;
- return 1 if $request->header($k) eq $v;
- return 1 if $response && $response->header($k) eq $v;
- return 0;
- },
- m_response_attr__ => sub {
- my($v, $k, $uri, $request, $response) = @_;
- return unless $response;
- return 1 if !defined($v) && exists $response->{$k};
- return 0 unless exists $response->{$k};
- return 1 if $response->{$k} eq $v;
- return 0;
- },
-);
-
-sub matching {
- my $self = shift;
- if (@_ == 1) {
- if ($_[0]->can("request")) {
- unshift(@_, $_[0]->request);
- unshift(@_, undef) unless defined $_[0];
- }
- unshift(@_, $_[0]->uri_canonical) if $_[0] && $_[0]->can("uri_canonical");
- }
- my($uri, $request, $response) = @_;
- $uri = URI->new($uri) unless ref($uri);
-
- my @m;
- ITEM:
- for my $item (@$self) {
- my $order;
- for my $ikey (keys %$item) {
- my $mkey = $ikey;
- my $k;
- $k = $1 if $mkey =~ s/__(.*)/__/;
- if (my $m = $MATCH{$mkey}) {
- #print "$ikey $mkey\n";
- my($c, $o);
- my @arg = (
- defined($k) ? $k : (),
- $uri, $request, $response
- );
- my $v = $item->{$ikey};
- $v = [$v] unless ref($v) eq "ARRAY";
- for (@$v) {
- ($c, $o) = $m->($_, @arg);
- #print " - $_ ==> $c $o\n";
- last if $c;
- }
- next ITEM unless $c;
- $order->[$o || 0] += $c;
- }
- }
- $order->[7] ||= 0;
- $item->{_order} = join(".", reverse map sprintf("%03d", $_ || 0), @$order);
- push(@m, $item);
- }
- @m = sort { $b->{_order} cmp $a->{_order} } @m;
- delete $_->{_order} for @m;
- return @m if wantarray;
- return $m[0];
-}
-
-sub add_item {
- my $self = shift;
- my $item = shift;
- return $self->add(item => $item, @_);
-}
-
-sub remove_items {
- my $self = shift;
- return map $_->{item}, $self->remove(@_);
-}
-
-sub matching_items {
- my $self = shift;
- return map $_->{item}, $self->matching(@_);
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-HTTP::Config - Configuration for request and response objects
-
-=head1 SYNOPSIS
-
- use HTTP::Config;
- my $c = HTTP::Config->new;
- $c->add(m_domain => ".example.com", m_scheme => "http", verbose => 1);
-
- use HTTP::Request;
- my $request = HTTP::Request->new(GET => "http://www.example.com");
-
- if (my @m = $c->matching($request)) {
- print "Yadayada\n" if $m[0]->{verbose};
- }
-
-=head1 DESCRIPTION
-
-An C<HTTP::Config> object is a list of entries that
-can be matched against request or request/response pairs. Its
-purpose is to hold configuration data that can be looked up given a
-request or response object.
-
-Each configuration entry is a hash. Some keys specify matching to
-occur against attributes of request/response objects. Other keys can
-be used to hold user data.
-
-The following methods are provided:
-
-=over 4
-
-=item $conf = HTTP::Config->new
-
-Constructs a new empty C<HTTP::Config> object and returns it.
-
-=item $conf->entries
-
-Returns the list of entries in the configuration object.
-In scalar context returns the number of entries.
-
-=item $conf->empty
-
-Return true if there are no entries in the configuration object.
-This is just a shorthand for C<< not $conf->entries >>.
-
-=item $conf->add( %matchspec, %other )
-
-=item $conf->add( \%entry )
-
-Adds a new entry to the configuration.
-You can either pass separate key/value pairs or a hash reference.
-
-=item $conf->remove( %spec )
-
-Removes (and returns) the entries that have matches for all the key/value pairs in %spec.
-If %spec is empty this will match all entries; so it will empty the configuation object.
-
-=item $conf->matching( $uri, $request, $response )
-
-=item $conf->matching( $uri )
-
-=item $conf->matching( $request )
-
-=item $conf->matching( $response )
-
-Returns the entries that match the given $uri, $request and $response triplet.
-
-If called with a single $request object then the $uri is obtained by calling its 'uri_canonical' method.
-If called with a single $response object, then the request object is obtained by calling its 'request' method;
-and then the $uri is obtained as if a single $request was provided.
-
-The entries are returned with the most specific matches first.
-In scalar context returns the most specific match or C<undef> in none match.
-
-=item $conf->add_item( $item, %matchspec )
-
-=item $conf->remove_items( %spec )
-
-=item $conf->matching_items( $uri, $request, $response )
-
-Wrappers that hides the entries themselves.
-
-=back
-
-=head2 Matching
-
-The following keys on a configuration entry specify matching. For all
-of these you can provide an array of values instead of a single value.
-The entry matches if at least one of the values in the array matches.
-
-Entries that require match against a response object attribute will never match
-unless a response object was provided.
-
-=over
-
-=item m_scheme => $scheme
-
-Matches if the URI uses the specified scheme; e.g. "http".
-
-=item m_secure => $bool
-
-If $bool is TRUE; matches if the URI uses a secure scheme. If $bool
-is FALSE; matches if the URI does not use a secure scheme. An example
-of a secure scheme is "https".
-
-=item m_host_port => "$hostname:$port"
-
-Matches if the URI's host_port method return the specified value.
-
-=item m_host => $hostname
-
-Matches if the URI's host method returns the specified value.
-
-=item m_port => $port
-
-Matches if the URI's port method returns the specified value.
-
-=item m_domain => ".$domain"
-
-Matches if the URI's host method return a value that within the given
-domain. The hostname "www.example.com" will for instance match the
-domain ".com".
-
-=item m_path => $path
-
-Matches if the URI's path method returns the specified value.
-
-=item m_path_prefix => $path
-
-Matches if the URI's path is the specified path or has the specified
-path as prefix.
-
-=item m_path_match => $Regexp
-
-Matches if the regular expression matches the URI's path. Eg. qr/\.html$/.
-
-=item m_method => $method
-
-Matches if the request method matches the specified value. Eg. "GET" or "POST".
-
-=item m_code => $digit
-
-=item m_code => $status_code
-
-Matches if the response status code matches. If a single digit is
-specified; matches for all response status codes beginning with that digit.
-
-=item m_proxy => $url
-
-Matches if the request is to be sent to the given Proxy server.
-
-=item m_media_type => "*/*"
-
-=item m_media_type => "text/*"
-
-=item m_media_type => "html"
-
-=item m_media_type => "xhtml"
-
-=item m_media_type => "text/html"
-
-Matches if the response media type matches.
-
-With a value of "html" matches if $response->content_is_html returns TRUE.
-With a value of "xhtml" matches if $response->content_is_xhtml returns TRUE.
-
-=item m_uri__I<$method> => undef
-
-Matches if the URI object provides the method.
-
-=item m_uri__I<$method> => $string
-
-Matches if the URI's $method method returns the given value.
-
-=item m_header__I<$field> => $string
-
-Matches if either the request or the response have a header $field with the given value.
-
-=item m_response_attr__I<$key> => undef
-
-=item m_response_attr__I<$key> => $string
-
-Matches if the response object has that key, or the entry has the given value.
-
-=back
-
-=head1 SEE ALSO
-
-L<URI>, L<HTTP::Request>, L<HTTP::Response>
-
-=head1 COPYRIGHT
-
-Copyright 2008, Gisle Aas
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Cookies.pm b/Master/tlpkg/tlperl/lib/HTTP/Cookies.pm
deleted file mode 100644
index 79ac4f27f84..00000000000
--- a/Master/tlpkg/tlperl/lib/HTTP/Cookies.pm
+++ /dev/null
@@ -1,781 +0,0 @@
-package HTTP::Cookies;
-
-use strict;
-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 = "6.01";
-
-# 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}.
-
-sub new
-{
- my $class = shift;
- my $self = bless {
- COOKIES => {},
- }, $class;
- my %cnf = @_;
- for (keys %cnf) {
- $self->{lc($_)} = $cnf{$_};
- }
- $self->load;
- $self;
-}
-
-
-sub add_cookie_header
-{
- my $self = shift;
- my $request = shift || return;
- my $url = $request->uri;
- my $scheme = $url->scheme;
- unless ($scheme =~ /^https?\z/) {
- return;
- }
-
- my $domain = _host($request, $url);
- $domain = "$domain.local" unless $domain =~ /\./;
- my $secure_request = ($scheme eq "https");
- my $req_path = _url_path($url);
- my $req_port = $url->port;
- my $now = time();
- _normalize_path($req_path) if $req_path =~ /%/;
-
- my @cval; # cookie values for the "Cookie" header
- my $set_ver;
- my $netscape_only = 0; # An exact domain match applies to any cookie
-
- while ($domain =~ /\./) {
- # Checking $domain for cookies"
- my $cookies = $self->{COOKIES}{$domain};
- next unless $cookies;
- if ($self->{delayload} && defined($cookies->{'//+delayload'})) {
- my $cookie_data = $cookies->{'//+delayload'}{'cookie'};
- delete $self->{COOKIES}{$domain};
- $self->load_cookie($cookie_data->[1]);
- $cookies = $self->{COOKIES}{$domain};
- next unless $cookies; # should not really happen
- }
-
- # Want to add cookies corresponding to the most specific paths
- # first (i.e. longest path first)
- my $path;
- for $path (sort {length($b) <=> length($a) } keys %$cookies) {
- if (index($req_path, $path) != 0) {
- next;
- }
-
- my($key,$array);
- while (($key,$array) = each %{$cookies->{$path}}) {
- my($version,$val,$port,$path_spec,$secure,$expires) = @$array;
- if ($secure && !$secure_request) {
- next;
- }
- if ($expires && $expires < $now) {
- next;
- }
- if ($port) {
- my $found;
- if ($port =~ s/^_//) {
- # The corresponding Set-Cookie attribute was empty
- $found++ if $port eq $req_port;
- $port = "";
- }
- else {
- my $p;
- for $p (split(/,/, $port)) {
- $found++, last if $p eq $req_port;
- }
- }
- unless ($found) {
- next;
- }
- }
- if ($version > 0 && $netscape_only) {
- next;
- }
-
- # set version number of cookie header.
- # XXX: What should it be if multiple matching
- # Set-Cookie headers have different versions themselves
- if (!$set_ver++) {
- if ($version >= 1) {
- push(@cval, "\$Version=$version");
- }
- elsif (!$self->{hide_cookie2}) {
- $request->header(Cookie2 => '$Version="1"');
- }
- }
-
- # do we need to quote the value
- if ($val =~ /\W/ && $version) {
- $val =~ s/([\\\"])/\\$1/g;
- $val = qq("$val");
- }
-
- # and finally remember this cookie
- push(@cval, "$key=$val");
- if ($version >= 1) {
- push(@cval, qq(\$Path="$path")) if $path_spec;
- push(@cval, qq(\$Domain="$domain")) if $domain =~ /^\./;
- if (defined $port) {
- my $p = '$Port';
- $p .= qq(="$port") if length $port;
- push(@cval, $p);
- }
- }
-
- }
- }
-
- } continue {
- # Try with a more general domain, alternately stripping
- # leading name components and leading dots. When this
- # results in a domain with no leading dot, it is for
- # Netscape cookie compatibility only:
- #
- # a.b.c.net Any cookie
- # .b.c.net Any cookie
- # b.c.net Netscape cookie only
- # .c.net Any cookie
-
- if ($domain =~ s/^\.+//) {
- $netscape_only = 1;
- }
- else {
- $domain =~ s/[^.]*//;
- $netscape_only = 0;
- }
- }
-
- if (@cval) {
- if (my $old = $request->header("Cookie")) {
- unshift(@cval, $old);
- }
- $request->header(Cookie => join("; ", @cval));
- }
-
- $request;
-}
-
-
-sub extract_cookies
-{
- my $self = shift;
- my $response = shift || return;
-
- my @set = _split_header_words($response->_header("Set-Cookie2"));
- my @ns_set = $response->_header("Set-Cookie");
-
- return $response unless @set || @ns_set; # quick exit
-
- my $request = $response->request;
- my $url = $request->uri;
- my $req_host = _host($request, $url);
- $req_host = "$req_host.local" unless $req_host =~ /\./;
- my $req_port = $url->port;
- my $req_path = _url_path($url);
- _normalize_path($req_path) if $req_path =~ /%/;
-
- if (@ns_set) {
- # The old Netscape cookie format for Set-Cookie
- # http://curl.haxx.se/rfc/cookie_spec.html
- # can for instance contain an unquoted "," in the expires
- # field, so we have to use this ad-hoc parser.
- my $now = time();
-
- # Build a hash of cookies that was present in Set-Cookie2
- # headers. We need to skip them if we also find them in a
- # Set-Cookie header.
- my %in_set2;
- for (@set) {
- $in_set2{$_->[0]}++;
- }
-
- my $set;
- for $set (@ns_set) {
- $set =~ s/^\s+//;
- my @cur;
- my $param;
- my $expires;
- my $first_param = 1;
- for $param (split(/;\s*/, $set)) {
- next unless length($param);
- my($k,$v) = split(/\s*=\s*/, $param, 2);
- if (defined $v) {
- $v =~ s/\s+$//;
- #print "$k => $v\n";
- }
- else {
- $k =~ s/\s+$//;
- #print "$k => undef";
- }
- if (!$first_param && lc($k) eq "expires") {
- my $etime = str2time($v);
- if (defined $etime) {
- push(@cur, "Max-Age" => $etime - $now);
- $expires++;
- }
- else {
- # parse_date can deal with years outside the range of time_t,
- my($year, $mon, $day, $hour, $min, $sec, $tz) = parse_date($v);
- if ($year) {
- my $thisyear = (gmtime)[5] + 1900;
- if ($year < $thisyear) {
- push(@cur, "Max-Age" => -1); # any negative value will do
- $expires++;
- }
- elsif ($year >= $thisyear + 10) {
- # the date is at least 10 years into the future, just replace
- # it with something approximate
- push(@cur, "Max-Age" => 10 * 365 * 24 * 60 * 60);
- $expires++;
- }
- }
- }
- }
- elsif (!$first_param && lc($k) =~ /^(?:version|discard|ns-cookie)/) {
- # ignore
- }
- else {
- push(@cur, $k => $v);
- }
- $first_param = 0;
- }
- next unless @cur;
- next if $in_set2{$cur[0]};
-
-# push(@cur, "Port" => $req_port);
- push(@cur, "Discard" => undef) unless $expires;
- push(@cur, "Version" => 0);
- push(@cur, "ns-cookie" => 1);
- push(@set, \@cur);
- }
- }
-
- SET_COOKIE:
- for my $set (@set) {
- next unless @$set >= 2;
-
- my $key = shift @$set;
- my $val = shift @$set;
-
- my %hash;
- while (@$set) {
- my $k = shift @$set;
- my $v = shift @$set;
- my $lc = lc($k);
- # don't loose case distinction for unknown fields
- $k = $lc if $lc =~ /^(?:discard|domain|max-age|
- path|port|secure|version)$/x;
- if ($k eq "discard" || $k eq "secure") {
- $v = 1 unless defined $v;
- }
- next if exists $hash{$k}; # only first value is significant
- $hash{$k} = $v;
- };
-
- my %orig_hash = %hash;
- my $version = delete $hash{version};
- $version = 1 unless defined($version);
- my $discard = delete $hash{discard};
- my $secure = delete $hash{secure};
- my $maxage = delete $hash{'max-age'};
- my $ns_cookie = delete $hash{'ns-cookie'};
-
- # Check domain
- my $domain = delete $hash{domain};
- $domain = lc($domain) if defined $domain;
- if (defined($domain)
- && $domain ne $req_host && $domain ne ".$req_host") {
- if ($domain !~ /\./ && $domain ne "local") {
- next SET_COOKIE;
- }
- $domain = ".$domain" unless $domain =~ /^\./;
- if ($domain =~ /\.\d+$/) {
- next SET_COOKIE;
- }
- my $len = length($domain);
- unless (substr($req_host, -$len) eq $domain) {
- next SET_COOKIE;
- }
- my $hostpre = substr($req_host, 0, length($req_host) - $len);
- if ($hostpre =~ /\./ && !$ns_cookie) {
- next SET_COOKIE;
- }
- }
- else {
- $domain = $req_host;
- }
-
- my $path = delete $hash{path};
- my $path_spec;
- if (defined $path && $path ne '') {
- $path_spec++;
- _normalize_path($path) if $path =~ /%/;
- if (!$ns_cookie &&
- substr($req_path, 0, length($path)) ne $path) {
- next SET_COOKIE;
- }
- }
- else {
- $path = $req_path;
- $path =~ s,/[^/]*$,,;
- $path = "/" unless length($path);
- }
-
- my $port;
- if (exists $hash{port}) {
- $port = delete $hash{port};
- if (defined $port) {
- $port =~ s/\s+//g;
- my $found;
- for my $p (split(/,/, $port)) {
- unless ($p =~ /^\d+$/) {
- next SET_COOKIE;
- }
- $found++ if $p eq $req_port;
- }
- unless ($found) {
- next SET_COOKIE;
- }
- }
- else {
- $port = "_$req_port";
- }
- }
- $self->set_cookie($version,$key,$val,$path,$domain,$port,$path_spec,$secure,$maxage,$discard, \%hash)
- if $self->set_cookie_ok(\%orig_hash);
- }
-
- $response;
-}
-
-sub set_cookie_ok
-{
- 1;
-}
-
-
-sub set_cookie
-{
- my $self = shift;
- my($version,
- $key, $val, $path, $domain, $port,
- $path_spec, $secure, $maxage, $discard, $rest) = @_;
-
- # path and key can not be empty (key can't start with '$')
- return $self if !defined($path) || $path !~ m,^/, ||
- !defined($key) || $key =~ m,^\$,;
-
- # ensure legal port
- if (defined $port) {
- return $self unless $port =~ /^_?\d+(?:,\d+)*$/;
- }
-
- my $expires;
- if (defined $maxage) {
- if ($maxage <= 0) {
- delete $self->{COOKIES}{$domain}{$path}{$key};
- return $self;
- }
- $expires = time() + $maxage;
- }
- $version = 0 unless defined $version;
-
- my @array = ($version, $val,$port,
- $path_spec,
- $secure, $expires, $discard);
- push(@array, {%$rest}) if defined($rest) && %$rest;
- # trim off undefined values at end
- pop(@array) while !defined $array[-1];
-
- $self->{COOKIES}{$domain}{$path}{$key} = \@array;
- $self;
-}
-
-
-sub save
-{
- my $self = shift;
- my $file = shift || $self->{'file'} || return;
- local(*FILE);
- open(FILE, ">$file") or die "Can't open $file: $!";
- print FILE "#LWP-Cookies-1.0\n";
- print FILE $self->as_string(!$self->{ignore_discard});
- close(FILE);
- 1;
-}
-
-
-sub load
-{
- my $self = shift;
- my $file = shift || $self->{'file'} || return;
- local(*FILE, $_);
- local $/ = "\n"; # make sure we got standard record separator
- open(FILE, $file) or return;
- my $magic = <FILE>;
- unless ($magic =~ /^\#LWP-Cookies-(\d+\.\d+)/) {
- warn "$file does not seem to contain cookies";
- return;
- }
- while (<FILE>) {
- next unless s/^Set-Cookie3:\s*//;
- chomp;
- my $cookie;
- for $cookie (_split_header_words($_)) {
- my($key,$val) = splice(@$cookie, 0, 2);
- my %hash;
- while (@$cookie) {
- my $k = shift @$cookie;
- my $v = shift @$cookie;
- $hash{$k} = $v;
- }
- my $version = delete $hash{version};
- my $path = delete $hash{path};
- my $domain = delete $hash{domain};
- my $port = delete $hash{port};
- my $expires = str2time(delete $hash{expires});
-
- my $path_spec = exists $hash{path_spec}; delete $hash{path_spec};
- my $secure = exists $hash{secure}; delete $hash{secure};
- my $discard = exists $hash{discard}; delete $hash{discard};
-
- my @array = ($version,$val,$port,
- $path_spec,$secure,$expires,$discard);
- push(@array, \%hash) if %hash;
- $self->{COOKIES}{$domain}{$path}{$key} = \@array;
- }
- }
- close(FILE);
- 1;
-}
-
-
-sub revert
-{
- my $self = shift;
- $self->clear->load;
- $self;
-}
-
-
-sub clear
-{
- my $self = shift;
- if (@_ == 0) {
- $self->{COOKIES} = {};
- }
- elsif (@_ == 1) {
- delete $self->{COOKIES}{$_[0]};
- }
- elsif (@_ == 2) {
- delete $self->{COOKIES}{$_[0]}{$_[1]};
- }
- elsif (@_ == 3) {
- delete $self->{COOKIES}{$_[0]}{$_[1]}{$_[2]};
- }
- else {
- require Carp;
- Carp::carp('Usage: $c->clear([domain [,path [,key]]])');
- }
- $self;
-}
-
-
-sub clear_temporary_cookies
-{
- my($self) = @_;
-
- $self->scan(sub {
- if($_[9] or # "Discard" flag set
- not $_[8]) { # No expire field?
- $_[8] = -1; # Set the expire/max_age field
- $self->set_cookie(@_); # Clear the cookie
- }
- });
-}
-
-
-sub DESTROY
-{
- my $self = shift;
- local($., $@, $!, $^E, $?);
- $self->save if $self->{'autosave'};
-}
-
-
-sub scan
-{
- my($self, $cb) = @_;
- my($domain,$path,$key);
- for $domain (sort keys %{$self->{COOKIES}}) {
- for $path (sort keys %{$self->{COOKIES}{$domain}}) {
- for $key (sort keys %{$self->{COOKIES}{$domain}{$path}}) {
- my($version,$val,$port,$path_spec,
- $secure,$expires,$discard,$rest) =
- @{$self->{COOKIES}{$domain}{$path}{$key}};
- $rest = {} unless defined($rest);
- &$cb($version,$key,$val,$path,$domain,$port,
- $path_spec,$secure,$expires,$discard,$rest);
- }
- }
- }
-}
-
-
-sub as_string
-{
- my($self, $skip_discard) = @_;
- my @res;
- $self->scan(sub {
- my($version,$key,$val,$path,$domain,$port,
- $path_spec,$secure,$expires,$discard,$rest) = @_;
- return if $discard && $skip_discard;
- my @h = ($key, $val);
- push(@h, "path", $path);
- push(@h, "domain" => $domain);
- push(@h, "port" => $port) if defined $port;
- push(@h, "path_spec" => undef) if $path_spec;
- push(@h, "secure" => undef) if $secure;
- push(@h, "expires" => HTTP::Date::time2isoz($expires)) if $expires;
- push(@h, "discard" => undef) if $discard;
- my $k;
- for $k (sort keys %$rest) {
- push(@h, $k, $rest->{$k});
- }
- push(@h, "version" => $version);
- push(@res, "Set-Cookie3: " . join_header_words(\@h));
- });
- join("\n", @res, "");
-}
-
-sub _host
-{
- my($request, $url) = @_;
- if (my $h = $request->header("Host")) {
- $h =~ s/:\d+$//; # might have a port as well
- return lc($h);
- }
- return lc($url->host);
-}
-
-sub _url_path
-{
- my $url = shift;
- my $path;
- if($url->can('epath')) {
- $path = $url->epath; # URI::URL method
- }
- else {
- $path = $url->path; # URI::_generic method
- }
- $path = "/" unless length $path;
- $path;
-}
-
-sub _normalize_path # so that plain string compare can be used
-{
- my $x;
- $_[0] =~ s/%([0-9a-fA-F][0-9a-fA-F])/
- $x = uc($1);
- $x eq "2F" || $x eq "25" ? "%$x" :
- pack("C", hex($x));
- /eg;
- $_[0] =~ s/([\0-\x20\x7f-\xff])/sprintf("%%%02X",ord($1))/eg;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-HTTP::Cookies - HTTP cookie jars
-
-=head1 SYNOPSIS
-
- use HTTP::Cookies;
- $cookie_jar = HTTP::Cookies->new(
- file => "$ENV{'HOME'}/lwp_cookies.dat",
- autosave => 1,
- );
-
- use LWP;
- my $browser = LWP::UserAgent->new;
- $browser->cookie_jar($cookie_jar);
-
-Or for an empty and temporary cookie jar:
-
- use LWP;
- my $browser = LWP::UserAgent->new;
- $browser->cookie_jar( {} );
-
-=head1 DESCRIPTION
-
-This class is for objects that represent a "cookie jar" -- that is, a
-database of all the HTTP cookies that a given LWP::UserAgent object
-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
-new style cookies described in I<RFC 2965>.
-The two variants of cookies are supposed to be able to coexist happily.
-
-Instances of the class I<HTTP::Cookies> are able to store a collection
-of Set-Cookie2: and Set-Cookie: headers and are able to use this
-information to initialize Cookie-headers in I<HTTP::Request> objects.
-The state of a I<HTTP::Cookies> object can be saved in and restored from
-files.
-
-=head1 METHODS
-
-The following methods are provided:
-
-=over 4
-
-=item $cookie_jar = HTTP::Cookies->new
-
-The constructor takes hash style parameters. The following
-parameters are recognized:
-
- file: name of the file to restore cookies from and save cookies to
- autosave: save during destruction (bool)
- ignore_discard: save even cookies that are requested to be discarded (bool)
- hide_cookie2: do not add Cookie2 header to requests
-
-Future parameters might include (not yet implemented):
-
- max_cookies 300
- max_cookies_per_domain 20
- max_cookie_size 4096
-
- no_cookies list of domain names that we never return cookies to
-
-=item $cookie_jar->add_cookie_header( $request )
-
-The add_cookie_header() method will set the appropriate Cookie:-header
-for the I<HTTP::Request> object given as argument. The $request must
-have a valid url attribute before this method is called.
-
-=item $cookie_jar->extract_cookies( $response )
-
-The extract_cookies() method will look for Set-Cookie: and
-Set-Cookie2: headers in the I<HTTP::Response> object passed as
-argument. Any of these headers that are found are used to update
-the state of the $cookie_jar.
-
-=item $cookie_jar->set_cookie( $version, $key, $val, $path, $domain, $port, $path_spec, $secure, $maxage, $discard, \%rest )
-
-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 <= 0 will delete this cookie. %rest defines
-various other attributes like "Comment" and "CommentURL".
-
-=item $cookie_jar->save
-
-=item $cookie_jar->save( $file )
-
-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.
-
-The default is to save a sequence of "Set-Cookie3" lines.
-"Set-Cookie3" is a proprietary LWP format, not known to be compatible
-with any browser. The I<HTTP::Cookies::Netscape> sub-class can
-be used to save in a format compatible with Netscape.
-
-=item $cookie_jar->load
-
-=item $cookie_jar->load( $file )
-
-This method reads the cookies from the file and adds them to the
-$cookie_jar. The file must be in the format written by the save()
-method.
-
-=item $cookie_jar->revert
-
-This method empties the $cookie_jar and re-loads the $cookie_jar
-from the last save file.
-
-=item $cookie_jar->clear
-
-=item $cookie_jar->clear( $domain )
-
-=item $cookie_jar->clear( $domain, $path )
-
-=item $cookie_jar->clear( $domain, $path, $key )
-
-Invoking this method without arguments will empty the whole
-$cookie_jar. If given a single argument only cookies belonging to
-that domain will be removed. If given two arguments, cookies
-belonging to the specified path within that domain are removed. If
-given three arguments, then the cookie with the specified key, path
-and domain is removed.
-
-=item $cookie_jar->clear_temporary_cookies
-
-Discard all temporary cookies. Scans for all cookies in the jar
-with either no expire field or a true C<discard> flag. To be
-called when the user agent shuts down according to RFC 2965.
-
-=item $cookie_jar->scan( \&callback )
-
-The argument is a subroutine that will be invoked for each cookie
-stored in the $cookie_jar. The subroutine will be invoked with
-the following arguments:
-
- 0 version
- 1 key
- 2 val
- 3 path
- 4 domain
- 5 port
- 6 path_spec
- 7 secure
- 8 expires
- 9 discard
- 10 hash
-
-=item $cookie_jar->as_string
-
-=item $cookie_jar->as_string( $skip_discardables )
-
-The as_string() method will return the state of the $cookie_jar
-represented as a sequence of "Set-Cookie3" header lines separated by
-"\n". If $skip_discardables is TRUE, it will not return lines for
-cookies with the I<Discard> attribute.
-
-=back
-
-=head1 SEE ALSO
-
-L<HTTP::Cookies::Netscape>, L<HTTP::Cookies::Microsoft>
-
-=head1 COPYRIGHT
-
-Copyright 1997-2002 Gisle Aas
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Cookies/Microsoft.pm b/Master/tlpkg/tlperl/lib/HTTP/Cookies/Microsoft.pm
deleted file mode 100644
index 9c69fa364cf..00000000000
--- a/Master/tlpkg/tlperl/lib/HTTP/Cookies/Microsoft.pm
+++ /dev/null
@@ -1,329 +0,0 @@
-package HTTP::Cookies::Microsoft;
-
-use strict;
-
-use vars qw(@ISA $VERSION);
-
-$VERSION = "6.00";
-
-require HTTP::Cookies;
-@ISA=qw(HTTP::Cookies);
-
-sub load_cookies_from_file
-{
- my ($file) = @_;
- my @cookies;
- my ($key, $value, $domain_path, $flags, $lo_expire, $hi_expire);
- my ($lo_create, $hi_create, $sep);
-
- open(COOKIES, $file) || return;
-
- while ($key = <COOKIES>)
- {
- chomp($key);
- chomp($value = <COOKIES>);
- chomp($domain_path= <COOKIES>);
- chomp($flags = <COOKIES>); # 0x0001 bit is for secure
- chomp($lo_expire = <COOKIES>);
- chomp($hi_expire = <COOKIES>);
- chomp($lo_create = <COOKIES>);
- chomp($hi_create = <COOKIES>);
- chomp($sep = <COOKIES>);
-
- if (!defined($key) || !defined($value) || !defined($domain_path) ||
- !defined($flags) || !defined($hi_expire) || !defined($lo_expire) ||
- !defined($hi_create) || !defined($lo_create) || !defined($sep) ||
- ($sep ne '*'))
- {
- last;
- }
-
- if ($domain_path =~ /^([^\/]+)(\/.*)$/)
- {
- my $domain = $1;
- my $path = $2;
-
- push(@cookies, {KEY => $key, VALUE => $value, DOMAIN => $domain,
- PATH => $path, FLAGS =>$flags, HIXP =>$hi_expire,
- LOXP => $lo_expire, HICREATE => $hi_create,
- LOCREATE => $lo_create});
- }
- }
-
- return \@cookies;
-}
-
-sub get_user_name
-{
- use Win32;
- use locale;
- my $user = lc(Win32::LoginName());
-
- return $user;
-}
-
-# MSIE stores create and expire times as Win32 FILETIME,
-# which is 64 bits of 100 nanosecond intervals since Jan 01 1601
-#
-# But Cookies code expects time in 32-bit value expressed
-# in seconds since Jan 01 1970
-#
-sub epoch_time_offset_from_win32_filetime
-{
- my ($high, $low) = @_;
-
- #--------------------------------------------------------
- # USEFUL CONSTANT
- #--------------------------------------------------------
- # 0x019db1de 0xd53e8000 is 1970 Jan 01 00:00:00 in Win32 FILETIME
- #
- # 100 nanosecond intervals == 0.1 microsecond intervals
-
- my $filetime_low32_1970 = 0xd53e8000;
- my $filetime_high32_1970 = 0x019db1de;
-
- #------------------------------------
- # ALGORITHM
- #------------------------------------
- # To go from 100 nanosecond intervals to seconds since 00:00 Jan 01 1970:
- #
- # 1. Adjust 100 nanosecond intervals to Jan 01 1970 base
- # 2. Divide by 10 to get to microseconds (1/millionth second)
- # 3. Divide by 1000000 (10 ^ 6) to get to seconds
- #
- # We can combine Step 2 & 3 into one divide.
- #
- # After much trial and error, I came up with the following code which
- # avoids using Math::BigInt or floating pt, but still gives correct answers
-
- # If the filetime is before the epoch, return 0
- if (($high < $filetime_high32_1970) ||
- (($high == $filetime_high32_1970) && ($low < $filetime_low32_1970)))
- {
- return 0;
- }
-
- # Can't multiply by 0x100000000, (1 << 32),
- # without Perl issuing an integer overflow warning
- #
- # So use two multiplies by 0x10000 instead of one multiply by 0x100000000
- #
- # The result is the same.
- #
- my $date1970 = (($filetime_high32_1970 * 0x10000) * 0x10000) + $filetime_low32_1970;
- my $time = (($high * 0x10000) * 0x10000) + $low;
-
- $time -= $date1970;
- $time /= 10000000;
-
- return $time;
-}
-
-sub load_cookie
-{
- my($self, $file) = @_;
- my $now = time() - $HTTP::Cookies::EPOCH_OFFSET;
- my $cookie_data;
-
- if (-f $file)
- {
- # open the cookie file and get the data
- $cookie_data = load_cookies_from_file($file);
-
- foreach my $cookie (@{$cookie_data})
- {
- my $secure = ($cookie->{FLAGS} & 1) != 0;
- my $expires = epoch_time_offset_from_win32_filetime($cookie->{HIXP}, $cookie->{LOXP});
-
- $self->set_cookie(undef, $cookie->{KEY}, $cookie->{VALUE},
- $cookie->{PATH}, $cookie->{DOMAIN}, undef,
- 0, $secure, $expires-$now, 0);
- }
- }
-}
-
-sub load
-{
- my($self, $cookie_index) = @_;
- my $now = time() - $HTTP::Cookies::EPOCH_OFFSET;
- my $cookie_dir = '';
- my $delay_load = (defined($self->{'delayload'}) && $self->{'delayload'});
- my $user_name = get_user_name();
- my $data;
-
- $cookie_index ||= $self->{'file'} || return;
- if ($cookie_index =~ /[\\\/][^\\\/]+$/)
- {
- $cookie_dir = $` . "\\";
- }
-
- local(*INDEX, $_);
-
- open(INDEX, $cookie_index) || return;
- binmode(INDEX);
- if (256 != read(INDEX, $data, 256))
- {
- warn "$cookie_index file is not large enough";
- close(INDEX);
- return;
- }
-
- # Cookies' index.dat file starts with 32 bytes of signature
- # followed by an offset to the first record, stored as a little-endian DWORD
- my ($sig, $size) = unpack('a32 V', $data);
-
- if (($sig !~ /^Client UrlCache MMF Ver 5\.2/) || # check that sig is valid (only tested in IE6.0)
- (0x4000 != $size))
- {
- warn "$cookie_index ['$sig' $size] does not seem to contain cookies";
- close(INDEX);
- return;
- }
-
- if (0 == seek(INDEX, $size, 0)) # move the file ptr to start of the first record
- {
- close(INDEX);
- return;
- }
-
- # Cookies are usually stored in 'URL ' records in two contiguous 0x80 byte sectors (256 bytes)
- # so read in two 0x80 byte sectors and adjust if not a Cookie.
- while (256 == read(INDEX, $data, 256))
- {
- # each record starts with a 4-byte signature
- # and a count (little-endian DWORD) of 0x80 byte sectors for the record
- ($sig, $size) = unpack('a4 V', $data);
-
- # Cookies are found in 'URL ' records
- if ('URL ' ne $sig)
- {
- # skip over uninteresting record: I've seen 'HASH' and 'LEAK' records
- if (($sig eq 'HASH') || ($sig eq 'LEAK'))
- {
- # '-2' takes into account the two 0x80 byte sectors we've just read in
- if (($size > 0) && ($size != 2))
- {
- if (0 == seek(INDEX, ($size-2)*0x80, 1))
- {
- # Seek failed. Something's wrong. Gonna stop.
- last;
- }
- }
- }
- next;
- }
-
- #$REMOVE Need to check if URL records in Cookies' index.dat will
- # ever use more than two 0x80 byte sectors
- if ($size > 2)
- {
- my $more_data = ($size-2)*0x80;
-
- if ($more_data != read(INDEX, $data, $more_data, 256))
- {
- last;
- }
- }
-
- (my $user_name2 = $user_name) =~ s/ /_/g;
- if ($data =~ /Cookie\:\Q$user_name\E\@([\x21-\xFF]+).*?((?:\Q$user_name\E|\Q$user_name2\E)\@[\x21-\xFF]+\.txt)/)
- {
- my $cookie_file = $cookie_dir . $2; # form full pathname
-
- if (!$delay_load)
- {
- $self->load_cookie($cookie_file);
- }
- else
- {
- my $domain = $1;
-
- # grab only the domain name, drop everything from the first dir sep on
- if ($domain =~ m{[\\/]})
- {
- $domain = $`;
- }
-
- # 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);
- }
- }
- }
-
- close(INDEX);
-
- 1;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-HTTP::Cookies::Microsoft - access to Microsoft cookies files
-
-=head1 SYNOPSIS
-
- use LWP;
- use HTTP::Cookies::Microsoft;
- use Win32::TieRegistry(Delimiter => "/");
- my $cookies_dir = $Registry->
- {"CUser/Software/Microsoft/Windows/CurrentVersion/Explorer/Shell Folders/Cookies"};
-
- $cookie_jar = HTTP::Cookies::Microsoft->new(
- file => "$cookies_dir\\index.dat",
- 'delayload' => 1,
- );
- my $browser = LWP::UserAgent->new;
- $browser->cookie_jar( $cookie_jar );
-
-=head1 DESCRIPTION
-
-This is a subclass of C<HTTP::Cookies> which
-loads Microsoft Internet Explorer 5.x and 6.x for Windows (MSIE)
-cookie files.
-
-See the documentation for L<HTTP::Cookies>.
-
-=head1 METHODS
-
-The following methods are provided:
-
-=over 4
-
-=item $cookie_jar = HTTP::Cookies::Microsoft->new;
-
-The constructor takes hash style parameters. In addition
-to the regular HTTP::Cookies parameters, HTTP::Cookies::Microsoft
-recognizes the following:
-
- delayload: delay loading of cookie data until a request
- is actually made. This results in faster
- runtime unless you use most of the cookies
- since only the domain's cookie data
- is loaded on demand.
-
-=back
-
-=head1 CAVEATS
-
-Please note that the code DOESN'T support saving to the MSIE
-cookie file format.
-
-=head1 AUTHOR
-
-Johnny Lee <typo_pl@hotmail.com>
-
-=head1 COPYRIGHT
-
-Copyright 2002 Johnny Lee
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=cut
-
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Cookies/Netscape.pm b/Master/tlpkg/tlperl/lib/HTTP/Cookies/Netscape.pm
deleted file mode 100644
index 5972029e558..00000000000
--- a/Master/tlpkg/tlperl/lib/HTTP/Cookies/Netscape.pm
+++ /dev/null
@@ -1,114 +0,0 @@
-package HTTP::Cookies::Netscape;
-
-use strict;
-use vars qw(@ISA $VERSION);
-
-$VERSION = "6.00";
-
-require HTTP::Cookies;
-@ISA=qw(HTTP::Cookies);
-
-sub load
-{
- my($self, $file) = @_;
- $file ||= $self->{'file'} || return;
- local(*FILE, $_);
- local $/ = "\n"; # make sure we got standard record separator
- my @cookies;
- open(FILE, $file) || return;
- my $magic = <FILE>;
- unless ($magic =~ /^\#(?: Netscape)? HTTP Cookie File/) {
- warn "$file does not look like a netscape cookies file" if $^W;
- close(FILE);
- return;
- }
- my $now = time() - $HTTP::Cookies::EPOCH_OFFSET;
- while (<FILE>) {
- next if /^\s*\#/;
- next if /^\s*$/;
- tr/\n\r//d;
- my($domain,$bool1,$path,$secure, $expires,$key,$val) = split(/\t/, $_);
- $secure = ($secure eq "TRUE");
- $self->set_cookie(undef,$key,$val,$path,$domain,undef,
- 0,$secure,$expires-$now, 0);
- }
- close(FILE);
- 1;
-}
-
-sub save
-{
- my($self, $file) = @_;
- $file ||= $self->{'file'} || return;
- local(*FILE, $_);
- open(FILE, ">$file") || return;
-
- # Use old, now broken link to the old cookie spec just in case something
- # else (not us!) requires the comment block exactly this way.
- print FILE <<EOT;
-# Netscape HTTP Cookie File
-# http://www.netscape.com/newsref/std/cookie_spec.html
-# This is a generated file! Do not edit.
-
-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};
- $expires = $expires ? $expires - $HTTP::Cookies::EPOCH_OFFSET : 0;
- return if $now > $expires;
- $secure = $secure ? "TRUE" : "FALSE";
- my $bool = $domain =~ /^\./ ? "TRUE" : "FALSE";
- print FILE join("\t", $domain, $bool, $path, $secure, $expires, $key, $val), "\n";
- });
- close(FILE);
- 1;
-}
-
-1;
-__END__
-
-=head1 NAME
-
-HTTP::Cookies::Netscape - access to Netscape cookies files
-
-=head1 SYNOPSIS
-
- use LWP;
- use HTTP::Cookies::Netscape;
- $cookie_jar = HTTP::Cookies::Netscape->new(
- file => "c:/program files/netscape/users/ZombieCharity/cookies.txt",
- );
- my $browser = LWP::UserAgent->new;
- $browser->cookie_jar( $cookie_jar );
-
-=head1 DESCRIPTION
-
-This is a subclass of C<HTTP::Cookies> that reads (and optionally
-writes) Netscape/Mozilla cookie files.
-
-See the documentation for L<HTTP::Cookies>.
-
-=head1 CAVEATS
-
-Please note that the Netscape/Mozilla cookie file format can't store
-all the information available in the Set-Cookie2 headers, so you will
-probably lose some information if you save in this format.
-
-At time of writing, this module seems to work fine with Mozilla
-Phoenix/Firebird.
-
-=head1 SEE ALSO
-
-L<HTTP::Cookies::Microsoft>
-
-=head1 COPYRIGHT
-
-Copyright 2002-2003 Gisle Aas
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Daemon.pm b/Master/tlpkg/tlperl/lib/HTTP/Daemon.pm
deleted file mode 100644
index 27a7bf4e173..00000000000
--- a/Master/tlpkg/tlperl/lib/HTTP/Daemon.pm
+++ /dev/null
@@ -1,906 +0,0 @@
-package HTTP::Daemon;
-
-use strict;
-use vars qw($VERSION @ISA $PROTO $DEBUG);
-
-$VERSION = "6.01";
-
-use IO::Socket qw(AF_INET INADDR_ANY INADDR_LOOPBACK inet_ntoa);
-@ISA=qw(IO::Socket::INET);
-
-$PROTO = "HTTP/1.1";
-
-
-sub new
-{
- my($class, %args) = @_;
- $args{Listen} ||= 5;
- $args{Proto} ||= 'tcp';
- return $class->SUPER::new(%args);
-}
-
-
-sub accept
-{
- my $self = shift;
- my $pkg = shift || "HTTP::Daemon::ClientConn";
- my ($sock, $peer) = $self->SUPER::accept($pkg);
- if ($sock) {
- ${*$sock}{'httpd_daemon'} = $self;
- return wantarray ? ($sock, $peer) : $sock;
- }
- else {
- return;
- }
-}
-
-
-sub url
-{
- my $self = shift;
- my $url = $self->_default_scheme . "://";
- my $addr = $self->sockaddr;
- if (!$addr || $addr eq INADDR_ANY) {
- 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);
- }
- my $port = $self->sockport;
- $url .= ":$port" if $port != $self->_default_port;
- $url .= "/";
- $url;
-}
-
-
-sub _default_port {
- 80;
-}
-
-
-sub _default_scheme {
- "http";
-}
-
-
-sub product_tokens
-{
- "libwww-perl-daemon/$HTTP::Daemon::VERSION";
-}
-
-
-
-package HTTP::Daemon::ClientConn;
-
-use vars qw(@ISA $DEBUG);
-use IO::Socket ();
-@ISA=qw(IO::Socket::INET);
-*DEBUG = \$HTTP::Daemon::DEBUG;
-
-use HTTP::Request ();
-use HTTP::Response ();
-use HTTP::Status;
-use HTTP::Date qw(time2str);
-use LWP::MediaTypes qw(guess_media_type);
-use Carp ();
-
-my $CRLF = "\015\012"; # "\r\n" is not portable
-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) = @_;
- if (${*$self}{'httpd_nomore'}) {
- $self->reason("No more requests from this connection");
- return;
- }
-
- $self->reason("");
- my $buf = ${*$self}{'httpd_rbuf'};
- $buf = "" unless defined $buf;
-
- my $timeout = $ {*$self}{'io_socket_timeout'};
- my $fdset = "";
- vec($fdset, $self->fileno, 1) = 1;
- local($_);
-
- 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);
- }
- 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;
- }
- my $method = $1;
- 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);
- $r->protocol($proto);
- ${*$self}{'httpd_client_proto'} = $proto = _http_version($proto);
- ${*$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;
- }
-
- my $conn = $r->header('Connection');
- if ($proto >= $HTTP_1_1) {
- ${*$self}{'httpd_nomore'}++ if $conn && lc($conn) =~ /\bclose\b/;
- }
- else {
- ${*$self}{'httpd_nomore'}++ unless $conn &&
- lc($conn) =~ /\bkeep-alive\b/;
- }
-
- if ($only_headers) {
- ${*$self}{'httpd_rbuf'} = $buf;
- return $r;
- }
-
- # Find out how much content to read
- my $te = $r->header('Transfer-Encoding');
- my $ct = $r->header('Content-Type');
- 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' ) {
- $self->send_status_line(100);
- $self->send_crlf;
- }
- else {
- $self->send_error(417);
- $self->reason("Unsupported Expect header value");
- return;
- }
- }
-
- 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;
-
- }
- elsif ($te) {
- $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='';
- }
- }
- 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) = '';
-
- }
- ${*$self}{'httpd_rbuf'} = $buf;
-
- $r;
-}
-
-
-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;
- }
- }
- print STDERR "sysread()\n" if $DEBUG;
- my $n = sysread($self, $_[0], 2048, length($_[0]));
- $self->reason(defined($n) ? "Client closed" : "sysread: $!") unless $n;
- $n;
-}
-
-
-sub read_buffer
-{
- my $self = shift;
- my $old = ${*$self}{'httpd_rbuf'};
- if (@_) {
- ${*$self}{'httpd_rbuf'} = shift;
- }
- $old;
-}
-
-
-sub reason
-{
- my $self = shift;
- my $old = ${*$self}{'httpd_reason'};
- if (@_) {
- ${*$self}{'httpd_reason'} = shift;
- }
- $old;
-}
-
-
-sub proto_ge
-{
- my $self = shift;
- ${*$self}{'httpd_client_proto'} >= _http_version(shift);
-}
-
-
-sub _http_version
-{
- local($_) = shift;
- return 0 unless m,^(?:HTTP/)?(\d+)\.(\d+)$,i;
- $1 * 1000 + $2;
-}
-
-
-sub antique_client
-{
- my $self = shift;
- ${*$self}{'httpd_client_proto'} < $HTTP_1_0;
-}
-
-
-sub force_last_request
-{
- my $self = shift;
- ${*$self}{'httpd_nomore'}++;
-}
-
-sub head_request
-{
- my $self = shift;
- ${*$self}{'httpd_head'};
-}
-
-
-sub send_status_line
-{
- my($self, $status, $message, $proto) = @_;
- return if $self->antique_client;
- $status ||= RC_OK;
- $message ||= status_message($status) || "";
- $proto ||= $HTTP::Daemon::PROTO || "HTTP/1.1";
- print $self "$proto $status $message$CRLF";
-}
-
-
-sub send_crlf
-{
- my $self = shift;
- print $self $CRLF;
-}
-
-
-sub send_basic_header
-{
- my $self = shift;
- return if $self->antique_client;
- $self->send_status_line(@_);
- print $self "Date: ", time2str(time), $CRLF;
- my $product = $self->daemon->product_tokens;
- print $self "Server: $product$CRLF" if $product;
-}
-
-
-sub send_header
-{
- my $self = shift;
- while (@_) {
- my($k, $v) = splice(@_, 0, 2);
- $v = "" unless defined($v);
- print $self "$k: $v$CRLF";
- }
-}
-
-
-sub send_response
-{
- my $self = shift;
- my $res = shift;
- if (!ref $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
- }
- if ($self->head_request) {
- # 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
- }
- elsif (length $content) {
- print $self $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);
- my $base = $self->daemon->url;
- $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";
- }
- print $self $CRLF;
- print $self $content if $content && !$self->head_request;
- $self->force_last_request; # no use keeping the connection open
-}
-
-
-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 ||= "";
- $mess = <<EOT;
-<title>$status $mess</title>
-<h1>$status $mess</h1>
-$error
-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 $CRLF;
- }
- print $self $mess unless $self->head_request;
- $status;
-}
-
-
-sub send_file_response
-{
- my($self, $file) = @_;
- if (-d $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;
- }
- else {
- $self->send_error(RC_NOT_FOUND);
- }
-}
-
-
-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) = @_;
- my $opened = 0;
- local(*FILE);
- if (!ref($file)) {
- 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;
- }
- close($file) if $opened;
- $cnt;
-}
-
-
-sub daemon
-{
- my $self = shift;
- ${*$self}{'httpd_daemon'};
-}
-
-
-1;
-
-__END__
-
-=head1 NAME
-
-HTTP::Daemon - a simple http server class
-
-=head1 SYNOPSIS
-
- use HTTP::Daemon;
- use HTTP::Status;
-
- my $d = HTTP::Daemon->new || die;
- print "Please contact me at: <URL:", $d->url, ">\n";
- while (my $c = $d->accept) {
- while (my $r = $c->get_request) {
- if ($r->method eq 'GET' and $r->uri->path eq "/xyzzy") {
- # remember, this is *not* recommended practice :-)
- $c->send_file_response("/etc/passwd");
- }
- else {
- $c->send_error(RC_FORBIDDEN)
- }
- }
- $c->close;
- undef($c);
- }
-
-=head1 DESCRIPTION
-
-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
-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
-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.
-
-This HTTP daemon does not fork(2) for you. Your application, i.e. the
-user of the C<HTTP::Daemon> is responsible for forking if that is
-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:
-
-=over 4
-
-=item $d = HTTP::Daemon->new
-
-=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
-be called without any arguments. The daemon will then set up a listen
-queue of 5 connections and allocate some random port number.
-
-A server that wants to bind to some specific address on the standard
-HTTP port will be constructed like this:
-
- $d = HTTP::Daemon->new(
- LocalAddr => 'www.thisplace.com',
- LocalPort => 80,
- );
-
-See L<IO::Socket::INET> for a description of other arguments that can
-be used configure the daemon during construction.
-
-=item $c = $d->accept
-
-=item $c = $d->accept( $pkg )
-
-=item ($c, $peer_addr) = $d->accept
-
-This method works the same the one provided by the base class, but it
-returns an C<HTTP::Daemon::ClientConn> reference by default. If a
-package name is provided as argument, then the returned object will be
-blessed into the given class. It is probably a good idea to make that
-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>.
-
-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
-details.
-
-=item $d->url
-
-Returns a URL string that can be used to access the server root.
-
-=item $d->product_tokens
-
-Returns the name that this server will use to identify itself. This
-is the string that is sent with the C<Server> response header. The
-main reason to have this method is that subclasses can override it if
-they want to use another product name.
-
-The default is the string "libwww-perl-daemon/#.##" where "#.##" is
-replaced with the version number of this module.
-
-=back
-
-The C<HTTP::Daemon::ClientConn> is a C<IO::Socket::INET>
-subclass. Instances of this class are returned by the accept() method
-of C<HTTP::Daemon>. The following methods are provided:
-
-=over 4
-
-=item $c->get_request
-
-=item $c->get_request( $headers_only )
-
-This method reads data from the client and turns it into an
-C<HTTP::Request> object which is returned. It returns C<undef>
-if reading fails. If it fails, then the C<HTTP::Daemon::ClientConn>
-object ($c) should be discarded, and you should not try call this
-method again on it. The $c->reason method might give you some
-information about why $c->get_request failed.
-
-The get_request() method will normally not return until the whole
-request has been received from the client. This might not be what you
-want if the request is an upload of a large file (and with chunked
-transfer encoding HTTP can even support infinite request messages -
-uploading live audio for instance). If you pass a TRUE value as the
-$headers_only argument, then get_request() will return immediately
-after parsing the request headers and you are responsible for reading
-the rest of the request content. If you are going to call
-$c->get_request again on the same connection you better read the
-correct number of bytes.
-
-=item $c->read_buffer
-
-=item $c->read_buffer( $new_value )
-
-Bytes read by $c->get_request, but not used are placed in the I<read
-buffer>. The next time $c->get_request is called it will consume the
-bytes in this buffer before reading more data from the network
-connection itself. The read buffer is invalid after $c->get_request
-has failed.
-
-If you handle the reading of the request content yourself you need to
-empty this buffer before you read more and you need to place
-unconsumed bytes here. You also need this buffer if you implement
-services like I<101 Switching Protocols>.
-
-This method always returns the old buffer content and can optionally
-replace the buffer content if you pass it an argument.
-
-=item $c->reason
-
-When $c->get_request returns C<undef> you can obtain a short string
-describing why it happened by calling $c->reason.
-
-=item $c->proto_ge( $proto )
-
-Return TRUE if the client announced a protocol with version number
-greater or equal to the given argument. The $proto argument can be a
-string like "HTTP/1.1" or just "1.1".
-
-=item $c->antique_client
-
-Return TRUE if the client speaks the HTTP/0.9 protocol. No status
-code and no headers should be returned to such a client. This should
-be the same as !$c->proto_ge("HTTP/1.0").
-
-=item $c->head_request
-
-Return TRUE if the last request was a C<HEAD> request. No content
-body must be generated for these requests.
-
-=item $c->force_last_request
-
-Make sure that $c->get_request will not try to read more requests off
-this connection. If you generate a response that is not self
-delimiting, then you should signal this fact by calling this method.
-
-This attribute is turned on automatically if the client announces
-protocol HTTP/1.0 or worse and does not include a "Connection:
-Keep-Alive" header. It is also turned on automatically when HTTP/1.1
-or better clients send the "Connection: close" request header.
-
-=item $c->send_status_line
-
-=item $c->send_status_line( $code )
-
-=item $c->send_status_line( $code, $mess )
-
-=item $c->send_status_line( $code, $mess, $proto )
-
-Send the status line back to the client. If $code is omitted 200 is
-assumed. If $mess is omitted, then a message corresponding to $code
-is inserted. If $proto is missing the content of the
-$HTTP::Daemon::PROTO variable is used.
-
-=item $c->send_crlf
-
-Send the CRLF sequence to the client.
-
-=item $c->send_basic_header
-
-=item $c->send_basic_header( $code )
-
-=item $c->send_basic_header( $code, $mess )
-
-=item $c->send_basic_header( $code, $mess, $proto )
-
-Send the status line and the "Date:" and "Server:" headers back to
-the client. This header is assumed to be continued and does not end
-with an empty CRLF line.
-
-See the description of send_status_line() for the description of the
-accepted arguments.
-
-=item $c->send_header( $field, $value )
-
-=item $c->send_header( $field1, $value1, $field2, $value2, ... )
-
-Send one or more header lines.
-
-=item $c->send_response( $res )
-
-Write a C<HTTP::Response> object to the
-client as a response. We try hard to make sure that the response is
-self delimiting so that the connection can stay persistent for further
-request/response exchanges.
-
-The content attribute of the C<HTTP::Response> object can be a normal
-string or a subroutine reference. If it is a subroutine, then
-whatever this callback routine returns is written back to the
-client as the response content. The routine will be called until it
-return an undefined or empty value. If the client is HTTP/1.1 aware
-then we will use chunked transfer encoding for the response.
-
-=item $c->send_redirect( $loc )
-
-=item $c->send_redirect( $loc, $code )
-
-=item $c->send_redirect( $loc, $code, $entity_body )
-
-Send a redirect response back to the client. The location ($loc) can
-be an absolute or relative URL. The $code must be one the redirect
-status codes, and defaults to "301 Moved Permanently"
-
-=item $c->send_error
-
-=item $c->send_error( $code )
-
-=item $c->send_error( $code, $error_message )
-
-Send an error response back to the client. If the $code is missing a
-"Bad Request" error is reported. The $error_message is a string that
-is incorporated in the body of the HTML entity body.
-
-=item $c->send_file_response( $filename )
-
-Send back a response with the specified $filename as content. If the
-file is a directory we try to generate an HTML index of it.
-
-=item $c->send_file( $filename )
-
-=item $c->send_file( $fd )
-
-Copy the file to the client. The file can be a string (which
-will be interpreted as a filename) or a reference to an C<IO::Handle>
-or glob.
-
-=item $c->daemon
-
-Return a reference to the corresponding C<HTTP::Daemon> object.
-
-=back
-
-=head1 SEE ALSO
-
-RFC 2616
-
-L<IO::Socket::INET>, L<IO::Socket>
-
-=head1 COPYRIGHT
-
-Copyright 1996-2003, Gisle Aas
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Date.pm b/Master/tlpkg/tlperl/lib/HTTP/Date.pm
deleted file mode 100644
index d05d21605ae..00000000000
--- a/Master/tlpkg/tlperl/lib/HTTP/Date.pm
+++ /dev/null
@@ -1,388 +0,0 @@
-package HTTP::Date;
-
-$VERSION = "6.02";
-
-require Exporter;
-@ISA = qw(Exporter);
-@EXPORT = qw(time2str str2time);
-@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);
-
-
-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);
-}
-
-
-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;
- };
- }
-
- my @d = parse_date($str);
- return undef unless @d;
- $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;
- };
- }
- }
-
- my $offset = 0;
- 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 '-';
- }
- else {
- 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;
- };
-}
-
-
-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
-
- 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
- (?::(\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) =
- /^
- (\d{2}) # numerical month
- -
- (\d{2}) # day
- -
- (\d{2}) # year
- \s+
- (\d\d?):(\d\d)([APap][Mm]) # hour:min AM or PM
- \s*$
- /x)
-
- ||
- 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;
-
- # 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;
- }
- 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
- $hr = 0 unless defined($hr);
- $min = 0 unless defined($min);
- $sec = 0 unless defined($sec);
-
- # 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;
- }
-
- return($yr, $mon, $day, $hr, $min, $sec, $tz)
- if wantarray;
-
- if (defined $tz) {
- $tz = "Z" if $tz =~ /^(GMT|UTC?|[-+]?0+)$/;
- }
- else {
- $tz = "";
- }
- return sprintf("%04d-%02d-%02d %02d:%02d:%02d%s",
- $yr, $mon, $day, $hr, $min, $sec, $tz);
-}
-
-
-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);
-}
-
-
-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);
-}
-
-1;
-
-
-__END__
-
-=head1 NAME
-
-HTTP::Date - date conversion routines
-
-=head1 SYNOPSIS
-
- use HTTP::Date;
-
- $string = time2str($time); # Format as GMT ASCII time
- $time = str2time($string); # convert ASCII date to machine time
-
-=head1 DESCRIPTION
-
-This module provides functions that deal the date formats used by the
-HTTP protocol (and then some more). Only the first two functions,
-time2str() and str2time(), are exported by default.
-
-=over 4
-
-=item time2str( [$time] )
-
-The time2str() function converts a machine time (seconds since epoch)
-to a string. If the function is called without an argument or with an
-undefined argument, it will use the current time.
-
-The string returned is in the format preferred for the HTTP protocol.
-This is a fixed length subset of the format defined by RFC 1123,
-represented in Universal Time (GMT). An example of a time stamp
-in this format is:
-
- Sun, 06 Nov 1994 08:49:37 GMT
-
-=item str2time( $str [, $zone] )
-
-The str2time() function converts a string to machine time. It returns
-C<undef> if the format of $str is unrecognized, otherwise whatever the
-C<Time::Local> functions can make out of the parsed time. Dates
-before the system's epoch may not work on all operating systems. The
-time formats recognized are the same as for parse_date().
-
-The function also takes an optional second argument that specifies the
-default time zone to use when converting the date. This parameter is
-ignored if the zone is found in the date string itself. If this
-parameter is missing, and the date string format does not contain any
-zone specification, then the local time zone is assumed.
-
-If the zone is not "C<GMT>" or numerical (like "C<-0800>" or
-"C<+0100>"), then the C<Time::Zone> module must be installed in order
-to get the date recognized.
-
-=item parse_date( $str )
-
-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
-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 (C<undef> in
-scalar context).
-
-The function is able to parse the following formats:
-
- "Wed, 09 Feb 1994 22:23:32 GMT" -- HTTP format
- "Thu Feb 3 17:03:55 GMT 1994" -- ctime(3) format
- "Thu Feb 3 00:00:00 1994", -- ANSI C asctime() format
- "Tuesday, 08-Feb-94 14:15:29 GMT" -- old rfc850 HTTP format
- "Tuesday, 08-Feb-1994 14:15:29 GMT" -- broken rfc850 HTTP format
-
- "03/Feb/1994:17:03:55 -0700" -- common logfile format
- "09 Feb 1994 22:23:32 GMT" -- HTTP format (no weekday)
- "08-Feb-94 14:15:29 GMT" -- rfc850 format (no weekday)
- "08-Feb-1994 14:15:29 GMT" -- broken rfc850 format (no weekday)
-
- "1994-02-03 14:15:29 -0100" -- ISO 8601 format
- "1994-02-03 14:15:29" -- zone is optional
- "1994-02-03" -- only date
- "1994-02-03T14:15:29" -- Use T as separator
- "19940203T141529Z" -- ISO 8601 compact format
- "19940203" -- only date
-
- "08-Feb-94" -- old rfc850 HTTP format (no weekday, no time)
- "08-Feb-1994" -- broken rfc850 HTTP format (no weekday, no time)
- "09 Feb 1994" -- proposed new HTTP format (no weekday, no time)
- "03/Feb/1994" -- common logfile format (no time, no offset)
-
- "Feb 3 1994" -- Unix 'ls -l' format
- "Feb 3 17:03" -- Unix 'ls -l' format
-
- "11-15-96 03:52PM" -- Windows 'dir' format
-
-The parser ignores leading and trailing whitespace. It also allow the
-seconds to be missing and the month to be numerical in most formats.
-
-If the year is missing, then we assume that the date is the first
-matching date I<before> current month. If the year is given with only
-2 digits, then parse_date() will select the century that makes the
-year closest to the current date.
-
-=item time2iso( [$time] )
-
-Same as time2str(), but returns a "YYYY-MM-DD hh:mm:ss"-formatted
-string representing time in the local time zone.
-
-=item time2isoz( [$time] )
-
-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
-
-Copyright 1995-1999, Gisle Aas
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Headers.pm b/Master/tlpkg/tlperl/lib/HTTP/Headers.pm
deleted file mode 100644
index 532fefed8e8..00000000000
--- a/Master/tlpkg/tlperl/lib/HTTP/Headers.pm
+++ /dev/null
@@ -1,854 +0,0 @@
-package HTTP::Headers;
-
-use strict;
-use Carp ();
-
-use vars qw($VERSION $TRANSLATE_UNDERSCORE);
-$VERSION = "6.05";
-
-# The $TRANSLATE_UNDERSCORE variable controls whether '_' can be used
-# as a replacement for '-' in header field names.
-$TRANSLATE_UNDERSCORE = 1 unless defined $TRANSLATE_UNDERSCORE;
-
-# "Good Practice" order of HTTP message headers:
-# - General-Headers
-# - Request-Headers
-# - Response-Headers
-# - Entity-Headers
-
-my @general_headers = qw(
- Cache-Control Connection Date Pragma Trailer Transfer-Encoding Upgrade
- Via Warning
-);
-
-my @request_headers = qw(
- Accept Accept-Charset Accept-Encoding Accept-Language
- Authorization Expect From Host
- If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since
- Max-Forwards Proxy-Authorization Range Referer TE User-Agent
-);
-
-my @response_headers = qw(
- Accept-Ranges Age ETag Location Proxy-Authenticate Retry-After Server
- Vary WWW-Authenticate
-);
-
-my @entity_headers = qw(
- Allow Content-Encoding Content-Language Content-Length Content-Location
- Content-MD5 Content-Range Content-Type Expires Last-Modified
-);
-
-my %entity_header = map { lc($_) => 1 } @entity_headers;
-
-my @header_order = (
- @general_headers,
- @request_headers,
- @response_headers,
- @entity_headers,
-);
-
-# Make alternative representations of @header_order. This is used
-# for sorting and case matching.
-my %header_order;
-my %standard_case;
-
-{
- my $i = 0;
- for (@header_order) {
- my $lc = lc $_;
- $header_order{$lc} = ++$i;
- $standard_case{$lc} = $_;
- }
-}
-
-
-
-sub new
-{
- my($class) = shift;
- my $self = bless {}, $class;
- $self->header(@_) if @_; # set up initial headers
- $self;
-}
-
-
-sub header
-{
- my $self = shift;
- Carp::croak('Usage: $h->header($field, ...)') unless @_;
- my(@old);
- my %seen;
- while (@_) {
- my $field = shift;
- my $op = @_ ? ($seen{lc($field)}++ ? 'PUSH' : 'SET') : 'GET';
- @old = $self->_header($field, shift, $op);
- }
- return @old if wantarray;
- return $old[0] if @old <= 1;
- join(", ", @old);
-}
-
-sub clear
-{
- my $self = shift;
- %$self = ();
-}
-
-
-sub push_header
-{
- my $self = shift;
- return $self->_header(@_, 'PUSH_H') if @_ == 2;
- while (@_) {
- $self->_header(splice(@_, 0, 2), 'PUSH_H');
- }
-}
-
-
-sub init_header
-{
- Carp::croak('Usage: $h->init_header($field, $val)') if @_ != 3;
- shift->_header(@_, 'INIT');
-}
-
-
-sub remove_header
-{
- my($self, @fields) = @_;
- my $field;
- my @values;
- foreach $field (@fields) {
- $field =~ tr/_/-/ if $field !~ /^:/ && $TRANSLATE_UNDERSCORE;
- my $v = delete $self->{lc $field};
- push(@values, ref($v) eq 'ARRAY' ? @$v : $v) if defined $v;
- }
- return @values;
-}
-
-sub remove_content_headers
-{
- my $self = shift;
- unless (defined(wantarray)) {
- # fast branch that does not create return object
- delete @$self{grep $entity_header{$_} || /^content-/, keys %$self};
- return;
- }
-
- my $c = ref($self)->new;
- for my $f (grep $entity_header{$_} || /^content-/, keys %$self) {
- $c->{$f} = delete $self->{$f};
- }
- if (exists $self->{'::std_case'}) {
- $c->{'::std_case'} = $self->{'::std_case'};
- }
- $c;
-}
-
-
-sub _header
-{
- my($self, $field, $val, $op) = @_;
-
- Carp::croak("Illegal field name '$field'")
- if rindex($field, ':') > 1 || !length($field);
-
- unless ($field =~ /^:/) {
- $field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE;
- my $old = $field;
- $field = lc $field;
- unless($standard_case{$field} || $self->{'::std_case'}{$field}) {
- # generate a %std_case entry for this field
- $old =~ s/\b(\w)/\u$1/g;
- $self->{'::std_case'}{$field} = $old;
- }
- }
-
- $op ||= defined($val) ? 'SET' : 'GET';
- if ($op eq 'PUSH_H') {
- # Like PUSH but where we don't care about the return value
- if (exists $self->{$field}) {
- my $h = $self->{$field};
- if (ref($h) eq 'ARRAY') {
- push(@$h, ref($val) eq "ARRAY" ? @$val : $val);
- }
- else {
- $self->{$field} = [$h, ref($val) eq "ARRAY" ? @$val : $val]
- }
- return;
- }
- $self->{$field} = $val;
- return;
- }
-
- my $h = $self->{$field};
- my @old = ref($h) eq 'ARRAY' ? @$h : (defined($h) ? ($h) : ());
-
- unless ($op eq 'GET' || ($op eq 'INIT' && @old)) {
- if (defined($val)) {
- my @new = ($op eq 'PUSH') ? @old : ();
- if (ref($val) ne 'ARRAY') {
- push(@new, $val);
- }
- else {
- push(@new, @$val);
- }
- $self->{$field} = @new > 1 ? \@new : $new[0];
- }
- elsif ($op ne 'PUSH') {
- delete $self->{$field};
- }
- }
- @old;
-}
-
-
-sub _sorted_field_names
-{
- my $self = shift;
- return [ sort {
- ($header_order{$a} || 999) <=> ($header_order{$b} || 999) ||
- $a cmp $b
- } grep !/^::/, keys %$self ];
-}
-
-
-sub header_field_names {
- my $self = shift;
- return map $standard_case{$_} || $self->{'::std_case'}{$_} || $_, @{ $self->_sorted_field_names },
- if wantarray;
- return grep !/^::/, keys %$self;
-}
-
-
-sub scan
-{
- my($self, $sub) = @_;
- my $key;
- for $key (@{ $self->_sorted_field_names }) {
- my $vals = $self->{$key};
- if (ref($vals) eq 'ARRAY') {
- my $val;
- for $val (@$vals) {
- $sub->($standard_case{$key} || $self->{'::std_case'}{$key} || $key, $val);
- }
- }
- else {
- $sub->($standard_case{$key} || $self->{'::std_case'}{$key} || $key, $vals);
- }
- }
-}
-
-
-sub as_string
-{
- my($self, $endl) = @_;
- $endl = "\n" unless defined $endl;
-
- my @result = ();
- for my $key (@{ $self->_sorted_field_names }) {
- next if index($key, '_') == 0;
- my $vals = $self->{$key};
- if ( ref($vals) eq 'ARRAY' ) {
- for my $val (@$vals) {
- my $field = $standard_case{$key} || $self->{'::std_case'}{$key} || $key;
- $field =~ s/^://;
- if ( index($val, "\n") >= 0 ) {
- $val = _process_newline($val, $endl);
- }
- push @result, $field . ': ' . $val;
- }
- }
- else {
- my $field = $standard_case{$key} || $self->{'::std_case'}{$key} || $key;
- $field =~ s/^://;
- if ( index($vals, "\n") >= 0 ) {
- $vals = _process_newline($vals, $endl);
- }
- push @result, $field . ': ' . $vals;
- }
- }
-
- join($endl, @result, '');
-}
-
-sub _process_newline {
- local $_ = shift;
- my $endl = shift;
- # must handle header values with embedded newlines with care
- s/\s+$//; # trailing newlines and space must go
- s/\n(\x0d?\n)+/\n/g; # no empty lines
- s/\n([^\040\t])/\n $1/g; # initial space for continuation
- s/\n/$endl/g; # substitute with requested line ending
- $_;
-}
-
-
-
-if (eval { require Storable; 1 }) {
- *clone = \&Storable::dclone;
-} else {
- *clone = sub {
- my $self = shift;
- my $clone = HTTP::Headers->new;
- $self->scan(sub { $clone->push_header(@_);} );
- $clone;
- };
-}
-
-
-sub _date_header
-{
- require HTTP::Date;
- my($self, $header, $time) = @_;
- my($old) = $self->_header($header);
- if (defined $time) {
- $self->_header($header, HTTP::Date::time2str($time));
- }
- $old =~ s/;.*// if defined($old);
- HTTP::Date::str2time($old);
-}
-
-
-sub date { shift->_date_header('Date', @_); }
-sub expires { shift->_date_header('Expires', @_); }
-sub if_modified_since { shift->_date_header('If-Modified-Since', @_); }
-sub if_unmodified_since { shift->_date_header('If-Unmodified-Since', @_); }
-sub last_modified { shift->_date_header('Last-Modified', @_); }
-
-# This is used as a private LWP extension. The Client-Date header is
-# added as a timestamp to a response when it has been received.
-sub client_date { shift->_date_header('Client-Date', @_); }
-
-# The retry_after field is dual format (can also be a expressed as
-# number of seconds from now), so we don't provide an easy way to
-# access it until we have know how both these interfaces can be
-# addressed. One possibility is to return a negative value for
-# relative seconds and a positive value for epoch based time values.
-#sub retry_after { shift->_date_header('Retry-After', @_); }
-
-sub content_type {
- my $self = shift;
- my $ct = $self->{'content-type'};
- $self->{'content-type'} = shift if @_;
- $ct = $ct->[0] if ref($ct) eq 'ARRAY';
- return '' unless defined($ct) && length($ct);
- my @ct = split(/;\s*/, $ct, 2);
- for ($ct[0]) {
- s/\s+//g;
- $_ = lc($_);
- }
- wantarray ? @ct : $ct[0];
-}
-
-sub content_type_charset {
- my $self = shift;
- require HTTP::Headers::Util;
- my $h = $self->{'content-type'};
- $h = $h->[0] if ref($h);
- $h = "" unless defined $h;
- my @v = HTTP::Headers::Util::split_header_words($h);
- if (@v) {
- my($ct, undef, %ct_param) = @{$v[0]};
- my $charset = $ct_param{charset};
- if ($ct) {
- $ct = lc($ct);
- $ct =~ s/\s+//;
- }
- if ($charset) {
- $charset = uc($charset);
- $charset =~ s/^\s+//; $charset =~ s/\s+\z//;
- undef($charset) if $charset eq "";
- }
- return $ct, $charset if wantarray;
- return $charset;
- }
- return undef, undef if wantarray;
- return undef;
-}
-
-sub content_is_text {
- my $self = shift;
- return $self->content_type =~ m,^text/,;
-}
-
-sub content_is_html {
- my $self = shift;
- return $self->content_type eq 'text/html' || $self->content_is_xhtml;
-}
-
-sub content_is_xhtml {
- my $ct = shift->content_type;
- return $ct eq "application/xhtml+xml" ||
- $ct eq "application/vnd.wap.xhtml+xml";
-}
-
-sub content_is_xml {
- my $ct = shift->content_type;
- return 1 if $ct eq "text/xml";
- return 1 if $ct eq "application/xml";
- return 1 if $ct =~ /\+xml$/;
- return 0;
-}
-
-sub referer {
- my $self = shift;
- if (@_ && $_[0] =~ /#/) {
- # Strip fragment per RFC 2616, section 14.36.
- my $uri = shift;
- if (ref($uri)) {
- $uri = $uri->clone;
- $uri->fragment(undef);
- }
- else {
- $uri =~ s/\#.*//;
- }
- unshift @_, $uri;
- }
- ($self->_header('Referer', @_))[0];
-}
-*referrer = \&referer; # on tchrist's request
-
-sub title { (shift->_header('Title', @_))[0] }
-sub content_encoding { (shift->_header('Content-Encoding', @_))[0] }
-sub content_language { (shift->_header('Content-Language', @_))[0] }
-sub content_length { (shift->_header('Content-Length', @_))[0] }
-
-sub user_agent { (shift->_header('User-Agent', @_))[0] }
-sub server { (shift->_header('Server', @_))[0] }
-
-sub from { (shift->_header('From', @_))[0] }
-sub warning { (shift->_header('Warning', @_))[0] }
-
-sub www_authenticate { (shift->_header('WWW-Authenticate', @_))[0] }
-sub authorization { (shift->_header('Authorization', @_))[0] }
-
-sub proxy_authenticate { (shift->_header('Proxy-Authenticate', @_))[0] }
-sub proxy_authorization { (shift->_header('Proxy-Authorization', @_))[0] }
-
-sub authorization_basic { shift->_basic_auth("Authorization", @_) }
-sub proxy_authorization_basic { shift->_basic_auth("Proxy-Authorization", @_) }
-
-sub _basic_auth {
- require MIME::Base64;
- my($self, $h, $user, $passwd) = @_;
- my($old) = $self->_header($h);
- if (defined $user) {
- Carp::croak("Basic authorization user name can't contain ':'")
- if $user =~ /:/;
- $passwd = '' unless defined $passwd;
- $self->_header($h => 'Basic ' .
- MIME::Base64::encode("$user:$passwd", ''));
- }
- if (defined $old && $old =~ s/^\s*Basic\s+//) {
- my $val = MIME::Base64::decode($old);
- return $val unless wantarray;
- return split(/:/, $val, 2);
- }
- return;
-}
-
-
-1;
-
-__END__
-
-=head1 NAME
-
-HTTP::Headers - Class encapsulating HTTP Message headers
-
-=head1 SYNOPSIS
-
- require HTTP::Headers;
- $h = HTTP::Headers->new;
-
- $h->header('Content-Type' => 'text/plain'); # set
- $ct = $h->header('Content-Type'); # get
- $h->remove_header('Content-Type'); # delete
-
-=head1 DESCRIPTION
-
-The C<HTTP::Headers> class encapsulates HTTP-style message headers.
-The headers consist of attribute-value pairs also called fields, which
-may be repeated, and which are printed in a particular order. The
-field names are cases insensitive.
-
-Instances of this class are usually created as member variables of the
-C<HTTP::Request> and C<HTTP::Response> classes, internal to the
-library.
-
-The following methods are available:
-
-=over 4
-
-=item $h = HTTP::Headers->new
-
-Constructs a new C<HTTP::Headers> object. You might pass some initial
-attribute-value pairs as parameters to the constructor. I<E.g.>:
-
- $h = HTTP::Headers->new(
- Date => 'Thu, 03 Feb 1994 00:00:00 GMT',
- Content_Type => 'text/html; version=3.2',
- Content_Base => 'http://www.perl.org/');
-
-The constructor arguments are passed to the C<header> method which is
-described below.
-
-=item $h->clone
-
-Returns a copy of this C<HTTP::Headers> object.
-
-=item $h->header( $field )
-
-=item $h->header( $field => $value )
-
-=item $h->header( $f1 => $v1, $f2 => $v2, ... )
-
-Get or set the value of one or more header fields. The header field
-name ($field) is not case sensitive. To make the life easier for perl
-users who wants to avoid quoting before the => operator, you can use
-'_' as a replacement for '-' in header names.
-
-The header() method accepts multiple ($field => $value) pairs, which
-means that you can update several fields with a single invocation.
-
-The $value argument may be a plain string or a reference to an array
-of strings for a multi-valued field. If the $value is provided as
-C<undef> then the field is removed. If the $value is not given, then
-that header field will remain unchanged.
-
-The old value (or values) of the last of the header fields is returned.
-If no such field exists C<undef> will be returned.
-
-A multi-valued field will be returned as separate values in list
-context and will be concatenated with ", " as separator in scalar
-context. The HTTP spec (RFC 2616) promise that joining multiple
-values in this way will not change the semantic of a header field, but
-in practice there are cases like old-style Netscape cookies (see
-L<HTTP::Cookies>) where "," is used as part of the syntax of a single
-field value.
-
-Examples:
-
- $header->header(MIME_Version => '1.0',
- User_Agent => 'My-Web-Client/0.01');
- $header->header(Accept => "text/html, text/plain, image/*");
- $header->header(Accept => [qw(text/html text/plain image/*)]);
- @accepts = $header->header('Accept'); # get multiple values
- $accepts = $header->header('Accept'); # get values as a single string
-
-=item $h->push_header( $field => $value )
-
-=item $h->push_header( $f1 => $v1, $f2 => $v2, ... )
-
-Add a new field value for the specified header field. Previous values
-for the same field are retained.
-
-As for the header() method, the field name ($field) is not case
-sensitive and '_' can be used as a replacement for '-'.
-
-The $value argument may be a scalar or a reference to a list of
-scalars.
-
- $header->push_header(Accept => 'image/jpeg');
- $header->push_header(Accept => [map "image/$_", qw(gif png tiff)]);
-
-=item $h->init_header( $field => $value )
-
-Set the specified header to the given value, but only if no previous
-value for that field is set.
-
-The header field name ($field) is not case sensitive and '_'
-can be used as a replacement for '-'.
-
-The $value argument may be a scalar or a reference to a list of
-scalars.
-
-=item $h->remove_header( $field, ... )
-
-This function removes the header fields with the specified names.
-
-The header field names ($field) are not case sensitive and '_'
-can be used as a replacement for '-'.
-
-The return value is the values of the fields removed. In scalar
-context the number of fields removed is returned.
-
-Note that if you pass in multiple field names then it is generally not
-possible to tell which of the returned values belonged to which field.
-
-=item $h->remove_content_headers
-
-This will remove all the header fields used to describe the content of
-a message. All header field names prefixed with C<Content-> fall
-into this category, as well as C<Allow>, C<Expires> and
-C<Last-Modified>. RFC 2616 denotes these fields as I<Entity Header
-Fields>.
-
-The return value is a new C<HTTP::Headers> object that contains the
-removed headers only.
-
-=item $h->clear
-
-This will remove all header fields.
-
-=item $h->header_field_names
-
-Returns the list of distinct names for the fields present in the
-header. The field names have case as suggested by HTTP spec, and the
-names are returned in the recommended "Good Practice" order.
-
-In scalar context return the number of distinct field names.
-
-=item $h->scan( \&process_header_field )
-
-Apply a subroutine to each header field in turn. The callback routine
-is called with two parameters; the name of the field and a single
-value (a string). If a header field is multi-valued, then the
-routine is called once for each value. The field name passed to the
-callback routine has case as suggested by HTTP spec, and the headers
-will be visited in the recommended "Good Practice" order.
-
-Any return values of the callback routine are ignored. The loop can
-be broken by raising an exception (C<die>), but the caller of scan()
-would have to trap the exception itself.
-
-=item $h->as_string
-
-=item $h->as_string( $eol )
-
-Return the header fields as a formatted MIME header. Since it
-internally uses the C<scan> method to build the string, the result
-will use case as suggested by HTTP spec, and it will follow
-recommended "Good Practice" of ordering the header fields. Long header
-values are not folded.
-
-The optional $eol parameter specifies the line ending sequence to
-use. The default is "\n". Embedded "\n" characters in header field
-values will be substituted with this line ending sequence.
-
-=back
-
-=head1 CONVENIENCE METHODS
-
-The most frequently used headers can also be accessed through the
-following convenience methods. Most of these methods can both be used to read
-and to set the value of a header. The header value is set if you pass
-an argument to the method. The old header value is always returned.
-If the given header did not exist then C<undef> is returned.
-
-Methods that deal with dates/times always convert their value to system
-time (seconds since Jan 1, 1970) and they also expect this kind of
-value when the header value is set.
-
-=over 4
-
-=item $h->date
-
-This header represents the date and time at which the message was
-originated. I<E.g.>:
-
- $h->date(time); # set current date
-
-=item $h->expires
-
-This header gives the date and time after which the entity should be
-considered stale.
-
-=item $h->if_modified_since
-
-=item $h->if_unmodified_since
-
-These header fields are used to make a request conditional. If the requested
-resource has (or has not) been modified since the time specified in this field,
-then the server will return a C<304 Not Modified> response instead of
-the document itself.
-
-=item $h->last_modified
-
-This header indicates the date and time at which the resource was last
-modified. I<E.g.>:
-
- # check if document is more than 1 hour old
- if (my $last_mod = $h->last_modified) {
- if ($last_mod < time - 60*60) {
- ...
- }
- }
-
-=item $h->content_type
-
-The Content-Type header field indicates the media type of the message
-content. I<E.g.>:
-
- $h->content_type('text/html');
-
-The value returned will be converted to lower case, and potential
-parameters will be chopped off and returned as a separate value if in
-an array context. If there is no such header field, then the empty
-string is returned. This makes it safe to do the following:
-
- if ($h->content_type eq 'text/html') {
- # we enter this place even if the real header value happens to
- # be 'TEXT/HTML; version=3.0'
- ...
- }
-
-=item $h->content_type_charset
-
-Returns the upper-cased charset specified in the Content-Type header. In list
-context return the lower-cased bare content type followed by the upper-cased
-charset. Both values will be C<undef> if not specified in the header.
-
-=item $h->content_is_text
-
-Returns TRUE if the Content-Type header field indicate that the
-content is textual.
-
-=item $h->content_is_html
-
-Returns TRUE if the Content-Type header field indicate that the
-content is some kind of HTML (including XHTML). This method can't be
-used to set Content-Type.
-
-=item $h->content_is_xhtml
-
-Returns TRUE if the Content-Type header field indicate that the
-content is XHTML. This method can't be used to set Content-Type.
-
-=item $h->content_is_xml
-
-Returns TRUE if the Content-Type header field indicate that the
-content is XML. This method can't be used to set Content-Type.
-
-=item $h->content_encoding
-
-The Content-Encoding header field is used as a modifier to the
-media type. When present, its value indicates what additional
-encoding mechanism has been applied to the resource.
-
-=item $h->content_length
-
-A decimal number indicating the size in bytes of the message content.
-
-=item $h->content_language
-
-The natural language(s) of the intended audience for the message
-content. The value is one or more language tags as defined by RFC
-1766. Eg. "no" for some kind of Norwegian and "en-US" for English the
-way it is written in the US.
-
-=item $h->title
-
-The title of the document. In libwww-perl this header will be
-initialized automatically from the E<lt>TITLE>...E<lt>/TITLE> element
-of HTML documents. I<This header is no longer part of the HTTP
-standard.>
-
-=item $h->user_agent
-
-This header field is used in request messages and contains information
-about the user agent originating the request. I<E.g.>:
-
- $h->user_agent('Mozilla/5.0 (compatible; MSIE 7.0; Windows NT 6.0)');
-
-=item $h->server
-
-The server header field contains information about the software being
-used by the originating server program handling the request.
-
-=item $h->from
-
-This header should contain an Internet e-mail address for the human
-user who controls the requesting user agent. The address should be
-machine-usable, as defined by RFC822. E.g.:
-
- $h->from('King Kong <king@kong.com>');
-
-I<This header is no longer part of the HTTP standard.>
-
-=item $h->referer
-
-Used to specify the address (URI) of the document from which the
-requested resource address was obtained.
-
-The "Free On-line Dictionary of Computing" as this to say about the
-word I<referer>:
-
- <World-Wide Web> A misspelling of "referrer" which
- somehow made it into the {HTTP} standard. A given {web
- page}'s referer (sic) is the {URL} of whatever web page
- contains the link that the user followed to the current
- page. Most browsers pass this information as part of a
- request.
-
- (1998-10-19)
-
-By popular demand C<referrer> exists as an alias for this method so you
-can avoid this misspelling in your programs and still send the right
-thing on the wire.
-
-When setting the referrer, this method removes the fragment from the
-given URI if it is present, as mandated by RFC2616. Note that
-the removal does I<not> happen automatically if using the header(),
-push_header() or init_header() methods to set the referrer.
-
-=item $h->www_authenticate
-
-This header must be included as part of a C<401 Unauthorized> response.
-The field value consist of a challenge that indicates the
-authentication scheme and parameters applicable to the requested URI.
-
-=item $h->proxy_authenticate
-
-This header must be included in a C<407 Proxy Authentication Required>
-response.
-
-=item $h->authorization
-
-=item $h->proxy_authorization
-
-A user agent that wishes to authenticate itself with a server or a
-proxy, may do so by including these headers.
-
-=item $h->authorization_basic
-
-This method is used to get or set an authorization header that use the
-"Basic Authentication Scheme". In array context it will return two
-values; the user name and the password. In scalar context it will
-return I<"uname:password"> as a single string value.
-
-When used to set the header value, it expects two arguments. I<E.g.>:
-
- $h->authorization_basic($uname, $password);
-
-The method will croak if the $uname contains a colon ':'.
-
-=item $h->proxy_authorization_basic
-
-Same as authorization_basic() but will set the "Proxy-Authorization"
-header instead.
-
-=back
-
-=head1 NON-CANONICALIZED FIELD NAMES
-
-The header field name spelling is normally canonicalized including the
-'_' to '-' translation. There are some application where this is not
-appropriate. Prefixing field names with ':' allow you to force a
-specific spelling. For example if you really want a header field name
-to show up as C<foo_bar> instead of "Foo-Bar", you might set it like
-this:
-
- $h->header(":foo_bar" => 1);
-
-These field names are returned with the ':' intact for
-$h->header_field_names and the $h->scan callback, but the colons do
-not show in $h->as_string.
-
-=head1 COPYRIGHT
-
-Copyright 1995-2005 Gisle Aas.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Headers/Auth.pm b/Master/tlpkg/tlperl/lib/HTTP/Headers/Auth.pm
deleted file mode 100644
index 64e204ce388..00000000000
--- a/Master/tlpkg/tlperl/lib/HTTP/Headers/Auth.pm
+++ /dev/null
@@ -1,98 +0,0 @@
-package HTTP::Headers::Auth;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = "6.00";
-
-use HTTP::Headers;
-
-package HTTP::Headers;
-
-BEGIN {
- # we provide a new (and better) implementations below
- undef(&www_authenticate);
- undef(&proxy_authenticate);
-}
-
-require HTTP::Headers::Util;
-
-sub _parse_authenticate
-{
- my @ret;
- for (HTTP::Headers::Util::split_header_words(@_)) {
- if (!defined($_->[1])) {
- # this is a new auth scheme
- push(@ret, shift(@$_) => {});
- shift @$_;
- }
- if (@ret) {
- # this a new parameter pair for the last auth scheme
- while (@$_) {
- my $k = shift @$_;
- my $v = shift @$_;
- $ret[-1]{$k} = $v;
- }
- }
- else {
- # something wrong, parameter pair without any scheme seen
- # IGNORE
- }
- }
- @ret;
-}
-
-sub _authenticate
-{
- my $self = shift;
- my $header = shift;
- my @old = $self->_header($header);
- if (@_) {
- $self->remove_header($header);
- my @new = @_;
- while (@new) {
- my $a_scheme = shift(@new);
- if ($a_scheme =~ /\s/) {
- # assume complete valid value, pass it through
- $self->push_header($header, $a_scheme);
- }
- else {
- my @param;
- if (@new) {
- my $p = $new[0];
- if (ref($p) eq "ARRAY") {
- @param = @$p;
- shift(@new);
- }
- elsif (ref($p) eq "HASH") {
- @param = %$p;
- shift(@new);
- }
- }
- my $val = ucfirst(lc($a_scheme));
- if (@param) {
- my $sep = " ";
- while (@param) {
- my $k = shift @param;
- my $v = shift @param;
- if ($v =~ /[^0-9a-zA-Z]/ || lc($k) eq "realm") {
- # must quote the value
- $v =~ s,([\\\"]),\\$1,g;
- $v = qq("$v");
- }
- $val .= "$sep$k=$v";
- $sep = ", ";
- }
- }
- $self->push_header($header, $val);
- }
- }
- }
- return unless defined wantarray;
- wantarray ? _parse_authenticate(@old) : join(", ", @old);
-}
-
-
-sub www_authenticate { shift->_authenticate("WWW-Authenticate", @_) }
-sub proxy_authenticate { shift->_authenticate("Proxy-Authenticate", @_) }
-
-1;
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Headers/ETag.pm b/Master/tlpkg/tlperl/lib/HTTP/Headers/ETag.pm
deleted file mode 100644
index e0b2c7e255c..00000000000
--- a/Master/tlpkg/tlperl/lib/HTTP/Headers/ETag.pm
+++ /dev/null
@@ -1,94 +0,0 @@
-package HTTP::Headers::ETag;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = "6.00";
-
-require HTTP::Date;
-
-require HTTP::Headers;
-package HTTP::Headers;
-
-sub _etags
-{
- my $self = shift;
- my $header = shift;
- my @old = _split_etag_list($self->_header($header));
- if (@_) {
- $self->_header($header => join(", ", _split_etag_list(@_)));
- }
- wantarray ? @old : join(", ", @old);
-}
-
-sub etag { shift->_etags("ETag", @_); }
-sub if_match { shift->_etags("If-Match", @_); }
-sub if_none_match { shift->_etags("If-None-Match", @_); }
-
-sub if_range {
- # Either a date or an entity-tag
- my $self = shift;
- my @old = $self->_header("If-Range");
- if (@_) {
- my $new = shift;
- if (!defined $new) {
- $self->remove_header("If-Range");
- }
- elsif ($new =~ /^\d+$/) {
- $self->_date_header("If-Range", $new);
- }
- else {
- $self->_etags("If-Range", $new);
- }
- }
- return unless defined(wantarray);
- for (@old) {
- my $t = HTTP::Date::str2time($_);
- $_ = $t if $t;
- }
- wantarray ? @old : join(", ", @old);
-}
-
-
-# Split a list of entity tag values. The return value is a list
-# consisting of one element per entity tag. Suitable for parsing
-# headers like C<If-Match>, C<If-None-Match>. You might even want to
-# use it on C<ETag> and C<If-Range> entity tag values, because it will
-# normalize them to the common form.
-#
-# entity-tag = [ weak ] opaque-tag
-# weak = "W/"
-# opaque-tag = quoted-string
-
-
-sub _split_etag_list
-{
- my(@val) = @_;
- my @res;
- for (@val) {
- while (length) {
- my $weak = "";
- $weak = "W/" if s,^\s*[wW]/,,;
- my $etag = "";
- if (s/^\s*(\"[^\"\\]*(?:\\.[^\"\\]*)*\")//) {
- push(@res, "$weak$1");
- }
- elsif (s/^\s*,//) {
- push(@res, qq(W/"")) if $weak;
- }
- elsif (s/^\s*([^,\s]+)//) {
- $etag = $1;
- $etag =~ s/([\"\\])/\\$1/g;
- push(@res, qq($weak"$etag"));
- }
- elsif (s/^\s+// || !length) {
- push(@res, qq(W/"")) if $weak;
- }
- else {
- die "This should not happen: '$_'";
- }
- }
- }
- @res;
-}
-
-1;
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Headers/Util.pm b/Master/tlpkg/tlperl/lib/HTTP/Headers/Util.pm
deleted file mode 100644
index fdcf501b8e5..00000000000
--- a/Master/tlpkg/tlperl/lib/HTTP/Headers/Util.pm
+++ /dev/null
@@ -1,199 +0,0 @@
-package HTTP::Headers::Util;
-
-use strict;
-use vars qw($VERSION @ISA @EXPORT_OK);
-
-$VERSION = "6.03";
-
-require Exporter;
-@ISA=qw(Exporter);
-
-@EXPORT_OK=qw(split_header_words _split_header_words join_header_words);
-
-
-
-sub split_header_words {
- my @res = &_split_header_words;
- for my $arr (@res) {
- for (my $i = @$arr - 2; $i >= 0; $i -= 2) {
- $arr->[$i] = lc($arr->[$i]);
- }
- }
- return @res;
-}
-
-sub _split_header_words
-{
- my(@val) = @_;
- my @res;
- for (@val) {
- my @cur;
- while (length) {
- if (s/^\s*(=*[^\s=;,]+)//) { # 'token' or parameter 'attribute'
- push(@cur, $1);
- # a quoted value
- if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) {
- my $val = $1;
- $val =~ s/\\(.)/$1/g;
- push(@cur, $val);
- # some unquoted value
- }
- elsif (s/^\s*=\s*([^;,\s]*)//) {
- my $val = $1;
- $val =~ s/\s+$//;
- push(@cur, $val);
- # no value, a lone token
- }
- else {
- push(@cur, undef);
- }
- }
- elsif (s/^\s*,//) {
- push(@res, [@cur]) if @cur;
- @cur = ();
- }
- elsif (s/^\s*;// || s/^\s+//) {
- # continue
- }
- else {
- die "This should not happen: '$_'";
- }
- }
- push(@res, \@cur) if @cur;
- }
- @res;
-}
-
-
-sub join_header_words
-{
- @_ = ([@_]) if @_ && !ref($_[0]);
- my @res;
- for (@_) {
- my @cur = @$_;
- my @attr;
- while (@cur) {
- my $k = shift @cur;
- my $v = shift @cur;
- if (defined $v) {
- if ($v =~ /[\x00-\x20()<>@,;:\\\"\/\[\]?={}\x7F-\xFF]/ || !length($v)) {
- $v =~ s/([\"\\])/\\$1/g; # escape " and \
- $k .= qq(="$v");
- }
- else {
- # token
- $k .= "=$v";
- }
- }
- push(@attr, $k);
- }
- push(@res, join("; ", @attr)) if @attr;
- }
- join(", ", @res);
-}
-
-
-1;
-
-__END__
-
-=head1 NAME
-
-HTTP::Headers::Util - Header value parsing utility functions
-
-=head1 SYNOPSIS
-
- use HTTP::Headers::Util qw(split_header_words);
- @values = split_header_words($h->header("Content-Type"));
-
-=head1 DESCRIPTION
-
-This module provides a few functions that helps parsing and
-construction of valid HTTP header values. None of the functions are
-exported by default.
-
-The following functions are available:
-
-=over 4
-
-
-=item split_header_words( @header_values )
-
-This function will parse the header values given as argument into a
-list of anonymous arrays containing key/value pairs. The function
-knows how to deal with ",", ";" and "=" as well as quoted values after
-"=". A list of space separated tokens are parsed as if they were
-separated by ";".
-
-If the @header_values passed as argument contains multiple values,
-then they are treated as if they were a single value separated by
-comma ",".
-
-This means that this function is useful for parsing header fields that
-follow this syntax (BNF as from the HTTP/1.1 specification, but we relax
-the requirement for tokens).
-
- headers = #header
- header = (token | parameter) *( [";"] (token | parameter))
-
- token = 1*<any CHAR except CTLs or separators>
- separators = "(" | ")" | "<" | ">" | "@"
- | "," | ";" | ":" | "\" | <">
- | "/" | "[" | "]" | "?" | "="
- | "{" | "}" | SP | HT
-
- quoted-string = ( <"> *(qdtext | quoted-pair ) <"> )
- qdtext = <any TEXT except <">>
- quoted-pair = "\" CHAR
-
- parameter = attribute "=" value
- attribute = token
- value = token | quoted-string
-
-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 necessarily be parsed as you
-would want.
-
-This is easier to describe with some examples:
-
- split_header_words('foo="bar"; port="80,81"; DISCARD, BAR=baz');
- split_header_words('text/html; charset="iso-8859-1"');
- split_header_words('Basic realm="\\"foo\\\\bar\\""');
-
-will return
-
- [foo=>'bar', port=>'80,81', discard=> undef], [bar=>'baz' ]
- ['text/html' => undef, charset => 'iso-8859-1']
- [basic => undef, realm => "\"foo\\bar\""]
-
-If you don't want the function to convert tokens and attribute keys to
-lower case you can call it as C<_split_header_words> instead (with a
-leading underscore).
-
-=item join_header_words( @arrays )
-
-This will do the opposite of the conversion done by split_header_words().
-It takes a list of anonymous arrays as arguments (or a list of
-key/value pairs) and produces a single header value. Attribute values
-are quoted if needed.
-
-Example:
-
- join_header_words(["text/plain" => undef, charset => "iso-8859/1"]);
- join_header_words("text/plain" => undef, charset => "iso-8859/1");
-
-will both return the string:
-
- text/plain; charset="iso-8859/1"
-
-=back
-
-=head1 COPYRIGHT
-
-Copyright 1997-1998, Gisle Aas
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Message.pm b/Master/tlpkg/tlperl/lib/HTTP/Message.pm
deleted file mode 100644
index 3eeebfbfd3b..00000000000
--- a/Master/tlpkg/tlperl/lib/HTTP/Message.pm
+++ /dev/null
@@ -1,1106 +0,0 @@
-package HTTP::Message;
-
-use strict;
-use vars qw($VERSION $AUTOLOAD);
-$VERSION = "6.06";
-
-require HTTP::Headers;
-require Carp;
-
-my $CRLF = "\015\012"; # "\r\n" is not portable
-unless ($HTTP::URI_CLASS) {
- if ($ENV{PERL_HTTP_URI_CLASS}
- && $ENV{PERL_HTTP_URI_CLASS} =~ /^([\w:]+)$/) {
- $HTTP::URI_CLASS = $1;
- } else {
- $HTTP::URI_CLASS = "URI";
- }
-}
-eval "require $HTTP::URI_CLASS"; die $@ if $@;
-
-*_utf8_downgrade = defined(&utf8::downgrade) ?
- sub {
- utf8::downgrade($_[0], 1) or
- Carp::croak("HTTP::Message content must be bytes")
- }
- :
- sub {
- };
-
-sub new
-{
- my($class, $header, $content) = @_;
- if (defined $header) {
- Carp::croak("Bad header argument") unless ref $header;
- if (ref($header) eq "ARRAY") {
- $header = HTTP::Headers->new(@$header);
- }
- else {
- $header = $header->clone;
- }
- }
- else {
- $header = HTTP::Headers->new;
- }
- if (defined $content) {
- _utf8_downgrade($content);
- }
- else {
- $content = '';
- }
-
- bless {
- '_headers' => $header,
- '_content' => $content,
- }, $class;
-}
-
-
-sub parse
-{
- my($class, $str) = @_;
-
- my @hdr;
- while (1) {
- if ($str =~ s/^([^\s:]+)[ \t]*: ?(.*)\n?//) {
- push(@hdr, $1, $2);
- $hdr[-1] =~ s/\r\z//;
- }
- elsif (@hdr && $str =~ s/^([ \t].*)\n?//) {
- $hdr[-1] .= "\n$1";
- $hdr[-1] =~ s/\r\z//;
- }
- else {
- $str =~ s/^\r?\n//;
- last;
- }
- }
- local $HTTP::Headers::TRANSLATE_UNDERSCORE;
- new($class, \@hdr, $str);
-}
-
-
-sub clone
-{
- my $self = shift;
- my $clone = HTTP::Message->new($self->headers,
- $self->content);
- $clone->protocol($self->protocol);
- $clone;
-}
-
-
-sub clear {
- my $self = shift;
- $self->{_headers}->clear;
- $self->content("");
- delete $self->{_parts};
- return;
-}
-
-
-sub protocol {
- shift->_elem('_protocol', @_);
-}
-
-sub headers {
- my $self = shift;
-
- # recalculation of _content might change headers, so we
- # need to force it now
- $self->_content unless exists $self->{_content};
-
- $self->{_headers};
-}
-
-sub headers_as_string {
- shift->headers->as_string(@_);
-}
-
-
-sub content {
-
- my $self = $_[0];
- if (defined(wantarray)) {
- $self->_content unless exists $self->{_content};
- my $old = $self->{_content};
- $old = $$old if ref($old) eq "SCALAR";
- &_set_content if @_ > 1;
- return $old;
- }
-
- if (@_ > 1) {
- &_set_content;
- }
- else {
- Carp::carp("Useless content call in void context") if $^W;
- }
-}
-
-
-sub _set_content {
- my $self = $_[0];
- _utf8_downgrade($_[1]);
- if (!ref($_[1]) && ref($self->{_content}) eq "SCALAR") {
- ${$self->{_content}} = $_[1];
- }
- else {
- die "Can't set content to be a scalar reference" if ref($_[1]) eq "SCALAR";
- $self->{_content} = $_[1];
- delete $self->{_content_ref};
- }
- delete $self->{_parts} unless $_[2];
-}
-
-
-sub add_content
-{
- my $self = shift;
- $self->_content unless exists $self->{_content};
- my $chunkref = \$_[0];
- $chunkref = $$chunkref if ref($$chunkref); # legacy
-
- _utf8_downgrade($$chunkref);
-
- my $ref = ref($self->{_content});
- if (!$ref) {
- $self->{_content} .= $$chunkref;
- }
- elsif ($ref eq "SCALAR") {
- ${$self->{_content}} .= $$chunkref;
- }
- else {
- Carp::croak("Can't append to $ref content");
- }
- delete $self->{_parts};
-}
-
-sub add_content_utf8 {
- my($self, $buf) = @_;
- utf8::upgrade($buf);
- utf8::encode($buf);
- $self->add_content($buf);
-}
-
-sub content_ref
-{
- my $self = shift;
- $self->_content unless exists $self->{_content};
- delete $self->{_parts};
- my $old = \$self->{_content};
- my $old_cref = $self->{_content_ref};
- if (@_) {
- my $new = shift;
- Carp::croak("Setting content_ref to a non-ref") unless ref($new);
- delete $self->{_content}; # avoid modifying $$old
- $self->{_content} = $new;
- $self->{_content_ref}++;
- }
- $old = $$old if $old_cref;
- return $old;
-}
-
-
-sub content_charset
-{
- my $self = shift;
- if (my $charset = $self->content_type_charset) {
- return $charset;
- }
-
- # time to start guessing
- my $cref = $self->decoded_content(ref => 1, charset => "none");
-
- # Unicode BOM
- for ($$cref) {
- return "UTF-8" if /^\xEF\xBB\xBF/;
- return "UTF-32LE" if /^\xFF\xFE\x00\x00/;
- return "UTF-32BE" if /^\x00\x00\xFE\xFF/;
- return "UTF-16LE" if /^\xFF\xFE/;
- return "UTF-16BE" if /^\xFE\xFF/;
- }
-
- if ($self->content_is_xml) {
- # http://www.w3.org/TR/2006/REC-xml-20060816/#sec-guessing
- # XML entity not accompanied by external encoding information and not
- # in UTF-8 or UTF-16 encoding must begin with an XML encoding declaration,
- # in which the first characters must be '<?xml'
- for ($$cref) {
- return "UTF-32BE" if /^\x00\x00\x00</;
- return "UTF-32LE" if /^<\x00\x00\x00/;
- return "UTF-16BE" if /^(?:\x00\s)*\x00</;
- return "UTF-16LE" if /^(?:\s\x00)*<\x00/;
- if (/^\s*(<\?xml[^\x00]*?\?>)/) {
- if ($1 =~ /\sencoding\s*=\s*(["'])(.*?)\1/) {
- my $enc = $2;
- $enc =~ s/^\s+//; $enc =~ s/\s+\z//;
- return $enc if $enc;
- }
- }
- }
- return "UTF-8";
- }
- elsif ($self->content_is_html) {
- # look for <META charset="..."> or <META content="...">
- # http://dev.w3.org/html5/spec/Overview.html#determining-the-character-encoding
- require IO::HTML;
- # Use relaxed search to match previous versions of HTTP::Message:
- my $encoding = IO::HTML::find_charset_in($$cref, { encoding => 1,
- need_pragma => 0 });
- return $encoding->mime_name if $encoding;
- }
- elsif ($self->content_type eq "application/json") {
- for ($$cref) {
- # RFC 4627, ch 3
- return "UTF-32BE" if /^\x00\x00\x00./s;
- return "UTF-32LE" if /^.\x00\x00\x00/s;
- return "UTF-16BE" if /^\x00.\x00./s;
- return "UTF-16LE" if /^.\x00.\x00/s;
- return "UTF-8";
- }
- }
- if ($self->content_type =~ /^text\//) {
- for ($$cref) {
- if (length) {
- return "US-ASCII" unless /[\x80-\xFF]/;
- require Encode;
- eval {
- Encode::decode_utf8($_, Encode::FB_CROAK() | Encode::LEAVE_SRC());
- };
- return "UTF-8" unless $@;
- return "ISO-8859-1";
- }
- }
- }
-
- return undef;
-}
-
-
-sub decoded_content
-{
- my($self, %opt) = @_;
- my $content_ref;
- my $content_ref_iscopy;
-
- eval {
- $content_ref = $self->content_ref;
- die "Can't decode ref content" if ref($content_ref) ne "SCALAR";
-
- if (my $h = $self->header("Content-Encoding")) {
- $h =~ s/^\s+//;
- $h =~ s/\s+$//;
- for my $ce (reverse split(/\s*,\s*/, lc($h))) {
- next unless $ce;
- next if $ce eq "identity";
- if ($ce eq "gzip" || $ce eq "x-gzip") {
- require IO::Uncompress::Gunzip;
- my $output;
- IO::Uncompress::Gunzip::gunzip($content_ref, \$output, Transparent => 0)
- or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError";
- $content_ref = \$output;
- $content_ref_iscopy++;
- }
- elsif ($ce eq "x-bzip2" or $ce eq "bzip2") {
- require IO::Uncompress::Bunzip2;
- my $output;
- IO::Uncompress::Bunzip2::bunzip2($content_ref, \$output, Transparent => 0)
- or die "Can't bunzip content: $IO::Uncompress::Bunzip2::Bunzip2Error";
- $content_ref = \$output;
- $content_ref_iscopy++;
- }
- elsif ($ce eq "deflate") {
- require IO::Uncompress::Inflate;
- my $output;
- my $status = IO::Uncompress::Inflate::inflate($content_ref, \$output, Transparent => 0);
- my $error = $IO::Uncompress::Inflate::InflateError;
- unless ($status) {
- # "Content-Encoding: deflate" is supposed to mean the
- # "zlib" format of RFC 1950, but Microsoft got that
- # wrong, so some servers sends the raw compressed
- # "deflate" data. This tries to inflate this format.
- $output = undef;
- require IO::Uncompress::RawInflate;
- unless (IO::Uncompress::RawInflate::rawinflate($content_ref, \$output)) {
- $self->push_header("Client-Warning" =>
- "Could not raw inflate content: $IO::Uncompress::RawInflate::RawInflateError");
- $output = undef;
- }
- }
- die "Can't inflate content: $error" unless defined $output;
- $content_ref = \$output;
- $content_ref_iscopy++;
- }
- elsif ($ce eq "compress" || $ce eq "x-compress") {
- die "Can't uncompress content";
- }
- elsif ($ce eq "base64") { # not really C-T-E, but should be harmless
- require MIME::Base64;
- $content_ref = \MIME::Base64::decode($$content_ref);
- $content_ref_iscopy++;
- }
- elsif ($ce eq "quoted-printable") { # not really C-T-E, but should be harmless
- require MIME::QuotedPrint;
- $content_ref = \MIME::QuotedPrint::decode($$content_ref);
- $content_ref_iscopy++;
- }
- else {
- die "Don't know how to decode Content-Encoding '$ce'";
- }
- }
- }
-
- if ($self->content_is_text || (my $is_xml = $self->content_is_xml)) {
- my $charset = lc(
- $opt{charset} ||
- $self->content_type_charset ||
- $opt{default_charset} ||
- $self->content_charset ||
- "ISO-8859-1"
- );
- 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());
- };
- if ($@) {
- my $retried;
- if ($@ =~ /^Unknown encoding/) {
- my $alt_charset = lc($opt{alt_charset} || "");
- if ($alt_charset && $charset ne $alt_charset) {
- # 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 eq "none";
- $retried++;
- }
- }
- die unless $retried;
- }
- die "Encode::decode() returned undef improperly" unless defined $$content_ref;
- if ($is_xml) {
- # Get rid of the XML encoding declaration if present
- $$content_ref =~ s/^\x{FEFF}//;
- if ($$content_ref =~ /^(\s*<\?xml[^\x00]*?\?>)/) {
- substr($$content_ref, 0, length($1)) =~ s/\sencoding\s*=\s*(["']).*?\1//;
- }
- }
- }
- }
- };
- if ($@) {
- Carp::croak($@) if $opt{raise_error};
- return undef;
- }
-
- return $opt{ref} ? $content_ref : $$content_ref;
-}
-
-
-sub decodable
-{
- # should match the Content-Encoding values that decoded_content can deal with
- my $self = shift;
- my @enc;
- # XXX preferably we should determine if the modules are available without loading
- # them here
- eval {
- require IO::Uncompress::Gunzip;
- push(@enc, "gzip", "x-gzip");
- };
- eval {
- require IO::Uncompress::Inflate;
- require IO::Uncompress::RawInflate;
- push(@enc, "deflate");
- };
- eval {
- require IO::Uncompress::Bunzip2;
- push(@enc, "x-bzip2");
- };
- # we don't care about announcing the 'identity', 'base64' and
- # 'quoted-printable' stuff
- return wantarray ? @enc : join(", ", @enc);
-}
-
-
-sub decode
-{
- my $self = shift;
- return 1 unless $self->header("Content-Encoding");
- if (defined(my $content = $self->decoded_content(charset => "none"))) {
- $self->remove_header("Content-Encoding", "Content-Length", "Content-MD5");
- $self->content($content);
- return 1;
- }
- return 0;
-}
-
-
-sub encode
-{
- my($self, @enc) = @_;
-
- Carp::croak("Can't encode multipart/* messages") if $self->content_type =~ m,^multipart/,;
- Carp::croak("Can't encode message/* messages") if $self->content_type =~ m,^message/,;
-
- return 1 unless @enc; # nothing to do
-
- my $content = $self->content;
- for my $encoding (@enc) {
- if ($encoding eq "identity") {
- # nothing to do
- }
- elsif ($encoding eq "base64") {
- require MIME::Base64;
- $content = MIME::Base64::encode($content);
- }
- elsif ($encoding eq "gzip" || $encoding eq "x-gzip") {
- require IO::Compress::Gzip;
- my $output;
- IO::Compress::Gzip::gzip(\$content, \$output, Minimal => 1)
- or die "Can't gzip content: $IO::Compress::Gzip::GzipError";
- $content = $output;
- }
- elsif ($encoding eq "deflate") {
- require IO::Compress::Deflate;
- my $output;
- IO::Compress::Deflate::deflate(\$content, \$output)
- or die "Can't deflate content: $IO::Compress::Deflate::DeflateError";
- $content = $output;
- }
- elsif ($encoding eq "x-bzip2") {
- require IO::Compress::Bzip2;
- my $output;
- IO::Compress::Bzip2::bzip2(\$content, \$output)
- or die "Can't bzip2 content: $IO::Compress::Bzip2::Bzip2Error";
- $content = $output;
- }
- elsif ($encoding eq "rot13") { # for the fun of it
- $content =~ tr/A-Za-z/N-ZA-Mn-za-m/;
- }
- else {
- return 0;
- }
- }
- my $h = $self->header("Content-Encoding");
- unshift(@enc, $h) if $h;
- $self->header("Content-Encoding", join(", ", @enc));
- $self->remove_header("Content-Length", "Content-MD5");
- $self->content($content);
- return 1;
-}
-
-
-sub as_string
-{
- my($self, $eol) = @_;
- $eol = "\n" unless defined $eol;
-
- # The calculation of content might update the headers
- # so we need to do that first.
- my $content = $self->content;
-
- return join("", $self->{'_headers'}->as_string($eol),
- $eol,
- $content,
- (@_ == 1 && length($content) &&
- $content !~ /\n\z/) ? "\n" : "",
- );
-}
-
-
-sub dump
-{
- my($self, %opt) = @_;
- my $content = $self->content;
- my $chopped = 0;
- if (!ref($content)) {
- my $maxlen = $opt{maxlength};
- $maxlen = 512 unless defined($maxlen);
- if ($maxlen && length($content) > $maxlen * 1.1 + 3) {
- $chopped = length($content) - $maxlen;
- $content = substr($content, 0, $maxlen) . "...";
- }
-
- $content =~ s/\\/\\\\/g;
- $content =~ s/\t/\\t/g;
- $content =~ s/\r/\\r/g;
-
- # no need for 3 digits in escape for these
- $content =~ s/([\0-\11\13-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
-
- $content =~ s/([\0-\11\13-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
- $content =~ s/([^\12\040-\176])/sprintf('\\x{%X}',ord($1))/eg;
-
- # remaining whitespace
- $content =~ s/( +)\n/("\\40" x length($1)) . "\n"/eg;
- $content =~ s/(\n+)\n/("\\n" x length($1)) . "\n"/eg;
- $content =~ s/\n\z/\\n/;
-
- my $no_content = $opt{no_content};
- $no_content = "(no content)" unless defined $no_content;
- if ($content eq $no_content) {
- # escape our $no_content marker
- $content =~ s/^(.)/sprintf('\\x%02X',ord($1))/eg;
- }
- elsif ($content eq "") {
- $content = $no_content;
- }
- }
-
- my @dump;
- push(@dump, $opt{preheader}) if $opt{preheader};
- push(@dump, $self->{_headers}->as_string, $content);
- push(@dump, "(+ $chopped more bytes not shown)") if $chopped;
-
- my $dump = join("\n", @dump, "");
- $dump =~ s/^/$opt{prefix}/gm if $opt{prefix};
-
- print $dump unless defined wantarray;
- return $dump;
-}
-
-
-sub parts {
- my $self = shift;
- if (defined(wantarray) && (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR")) {
- $self->_parts;
- }
- my $old = $self->{_parts};
- if (@_) {
- my @parts = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_;
- my $ct = $self->content_type || "";
- if ($ct =~ m,^message/,) {
- Carp::croak("Only one part allowed for $ct content")
- if @parts > 1;
- }
- elsif ($ct !~ m,^multipart/,) {
- $self->remove_content_headers;
- $self->content_type("multipart/mixed");
- }
- $self->{_parts} = \@parts;
- _stale_content($self);
- }
- return @$old if wantarray;
- return $old->[0];
-}
-
-sub add_part {
- my $self = shift;
- if (($self->content_type || "") !~ m,^multipart/,) {
- my $p = HTTP::Message->new($self->remove_content_headers,
- $self->content(""));
- $self->content_type("multipart/mixed");
- $self->{_parts} = [];
- if ($p->headers->header_field_names || $p->content ne "") {
- push(@{$self->{_parts}}, $p);
- }
- }
- elsif (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR") {
- $self->_parts;
- }
-
- push(@{$self->{_parts}}, @_);
- _stale_content($self);
- return;
-}
-
-sub _stale_content {
- my $self = shift;
- if (ref($self->{_content}) eq "SCALAR") {
- # must recalculate now
- $self->_content;
- }
- else {
- # just invalidate cache
- delete $self->{_content};
- delete $self->{_content_ref};
- }
-}
-
-
-# delegate all other method calls the the headers object.
-sub AUTOLOAD
-{
- my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
-
- # We create the function here so that it will not need to be
- # autoloaded the next time.
- no strict 'refs';
- *$method = sub { local $Carp::Internal{+__PACKAGE__} = 1; shift->headers->$method(@_) };
- goto &$method;
-}
-
-
-sub DESTROY {} # avoid AUTOLOADing it
-
-
-# Private method to access members in %$self
-sub _elem
-{
- my $self = shift;
- my $elem = shift;
- my $old = $self->{$elem};
- $self->{$elem} = $_[0] if @_;
- return $old;
-}
-
-
-# Create private _parts attribute from current _content
-sub _parts {
- my $self = shift;
- my $ct = $self->content_type;
- if ($ct =~ m,^multipart/,) {
- require HTTP::Headers::Util;
- my @h = HTTP::Headers::Util::split_header_words($self->header("Content-Type"));
- die "Assert" unless @h;
- my %h = @{$h[0]};
- if (defined(my $b = $h{boundary})) {
- my $str = $self->content;
- $str =~ s/\r?\n--\Q$b\E--.*//s;
- if ($str =~ s/(^|.*?\r?\n)--\Q$b\E\r?\n//s) {
- $self->{_parts} = [map HTTP::Message->parse($_),
- split(/\r?\n--\Q$b\E\r?\n/, $str)]
- }
- }
- }
- elsif ($ct eq "message/http") {
- require HTTP::Request;
- require HTTP::Response;
- my $content = $self->content;
- my $class = ($content =~ m,^(HTTP/.*)\n,) ?
- "HTTP::Response" : "HTTP::Request";
- $self->{_parts} = [$class->parse($content)];
- }
- elsif ($ct =~ m,^message/,) {
- $self->{_parts} = [ HTTP::Message->parse($self->content) ];
- }
-
- $self->{_parts} ||= [];
-}
-
-
-# Create private _content attribute from current _parts
-sub _content {
- my $self = shift;
- my $ct = $self->{_headers}->header("Content-Type") || "multipart/mixed";
- if ($ct =~ m,^\s*message/,i) {
- _set_content($self, $self->{_parts}[0]->as_string($CRLF), 1);
- return;
- }
-
- require HTTP::Headers::Util;
- my @v = HTTP::Headers::Util::split_header_words($ct);
- Carp::carp("Multiple Content-Type headers") if @v > 1;
- @v = @{$v[0]};
-
- my $boundary;
- my $boundary_index;
- for (my @tmp = @v; @tmp;) {
- my($k, $v) = splice(@tmp, 0, 2);
- if ($k eq "boundary") {
- $boundary = $v;
- $boundary_index = @v - @tmp - 1;
- last;
- }
- }
-
- my @parts = map $_->as_string($CRLF), @{$self->{_parts}};
-
- my $bno = 0;
- $boundary = _boundary() unless defined $boundary;
- CHECK_BOUNDARY:
- {
- for (@parts) {
- if (index($_, $boundary) >= 0) {
- # must have a better boundary
- $boundary = _boundary(++$bno);
- redo CHECK_BOUNDARY;
- }
- }
- }
-
- if ($boundary_index) {
- $v[$boundary_index] = $boundary;
- }
- else {
- push(@v, boundary => $boundary);
- }
-
- $ct = HTTP::Headers::Util::join_header_words(@v);
- $self->{_headers}->header("Content-Type", $ct);
-
- _set_content($self, "--$boundary$CRLF" .
- join("$CRLF--$boundary$CRLF", @parts) .
- "$CRLF--$boundary--$CRLF",
- 1);
-}
-
-
-sub _boundary
-{
- my $size = shift || return "xYzZY";
- require MIME::Base64;
- my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), "");
- $b =~ s/[\W]/X/g; # ensure alnum only
- $b;
-}
-
-
-1;
-
-
-__END__
-
-=head1 NAME
-
-HTTP::Message - HTTP style message (base class)
-
-=head1 SYNOPSIS
-
- use base 'HTTP::Message';
-
-=head1 DESCRIPTION
-
-An C<HTTP::Message> object contains some headers and a content body.
-The following methods are available:
-
-=over 4
-
-=item $mess = HTTP::Message->new
-
-=item $mess = HTTP::Message->new( $headers )
-
-=item $mess = HTTP::Message->new( $headers, $content )
-
-This constructs a new message object. Normally you would want
-construct C<HTTP::Request> or C<HTTP::Response> objects instead.
-
-The optional $header argument should be a reference to an
-C<HTTP::Headers> object or a plain array reference of key/value pairs.
-If an C<HTTP::Headers> object is provided then a copy of it will be
-embedded into the constructed message, i.e. it will not be owned and
-can be modified afterwards without affecting the message.
-
-The optional $content argument should be a string of bytes.
-
-=item $mess = HTTP::Message->parse( $str )
-
-This constructs a new message object by parsing the given string.
-
-=item $mess->headers
-
-Returns the embedded C<HTTP::Headers> object.
-
-=item $mess->headers_as_string
-
-=item $mess->headers_as_string( $eol )
-
-Call the as_string() method for the headers in the
-message. This will be the same as
-
- $mess->headers->as_string
-
-but it will make your program a whole character shorter :-)
-
-=item $mess->content
-
-=item $mess->content( $bytes )
-
-The content() method sets the raw content if an argument is given. If no
-argument is given the content is not touched. In either case the
-original raw content is returned.
-
-Note that the content should be a string of bytes. Strings in perl
-can contain characters outside the range of a byte. The C<Encode>
-module can be used to turn such strings into a string of bytes.
-
-=item $mess->add_content( $bytes )
-
-The add_content() methods appends more data bytes to the end of the
-current content buffer.
-
-=item $mess->add_content_utf8( $string )
-
-The add_content_utf8() method appends the UTF-8 bytes representing the
-string to the end of the current content buffer.
-
-=item $mess->content_ref
-
-=item $mess->content_ref( \$bytes )
-
-The content_ref() method will return a reference to content buffer string.
-It can be more efficient to access the content this way if the content
-is huge, and it can even be used for direct manipulation of the content,
-for instance:
-
- ${$res->content_ref} =~ s/\bfoo\b/bar/g;
-
-This example would modify the content buffer in-place.
-
-If an argument is passed it will setup the content to reference some
-external source. The content() and add_content() methods
-will automatically dereference scalar references passed this way. For
-other references content() will return the reference itself and
-add_content() will refuse to do anything.
-
-=item $mess->content_charset
-
-This returns the charset used by the content in the message. The
-charset is either found as the charset attribute of the
-C<Content-Type> header or by guessing.
-
-See L<http://www.w3.org/TR/REC-html40/charset.html#spec-char-encoding>
-for details about how charset is determined.
-
-=item $mess->decoded_content( %options )
-
-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.
-
-=over
-
-=item C<charset>
-
-This override the charset parameter for text content. The value
-C<none> can used to suppress decoding of the charset.
-
-=item C<default_charset>
-
-This override the default charset guessed by content_charset() or
-if that fails "ISO-8859-1".
-
-=item C<alt_charset>
-
-If decoding fails because the charset specified in the Content-Type header
-isn't recognized by Perl's Encode module, then try decoding using this charset
-instead of failing. The C<alt_charset> might be specified as C<none> to simply
-return the string without any decoding of charset as alternative.
-
-=item C<charset_strict>
-
-Abort decoding if malformed characters is found in the content. By
-default you get the substitution character ("\x{FFFD}") in place of
-malformed characters.
-
-=item C<raise_error>
-
-If TRUE then raise an exception if not able to decode content. Reason
-might be that the specified C<Content-Encoding> or C<charset> is not
-supported. If this option is FALSE, then decoded_content() will return
-C<undef> on errors, but will still set $@.
-
-=item C<ref>
-
-If TRUE then a reference to decoded content is returned. This might
-be more efficient in cases where the decoded content is identical to
-the raw content as no data copying is required in this case.
-
-=back
-
-=item $mess->decodable
-
-=item HTTP::Message::decodable()
-
-This returns the encoding identifiers that decoded_content() can
-process. In scalar context returns a comma separated string of
-identifiers.
-
-This value is suitable for initializing the C<Accept-Encoding> request
-header field.
-
-=item $mess->decode
-
-This method tries to replace the content of the message with the
-decoded version and removes the C<Content-Encoding> header. Returns
-TRUE if successful and FALSE if not.
-
-If the message does not have a C<Content-Encoding> header this method
-does nothing and returns TRUE.
-
-Note that the content of the message is still bytes after this method
-has been called and you still need to call decoded_content() if you
-want to process its content as a string.
-
-=item $mess->encode( $encoding, ... )
-
-Apply the given encodings to the content of the message. Returns TRUE
-if successful. The "identity" (non-)encoding is always supported; other
-currently supported encodings, subject to availability of required
-additional modules, are "gzip", "deflate", "x-bzip2" and "base64".
-
-A successful call to this function will set the C<Content-Encoding>
-header.
-
-Note that C<multipart/*> or C<message/*> messages can't be encoded and
-this method will croak if you try.
-
-=item $mess->parts
-
-=item $mess->parts( @parts )
-
-=item $mess->parts( \@parts )
-
-Messages can be composite, i.e. contain other messages. The composite
-messages have a content type of C<multipart/*> or C<message/*>. This
-method give access to the contained messages.
-
-The argumentless form will return a list of C<HTTP::Message> objects.
-If the content type of $msg is not C<multipart/*> or C<message/*> then
-this will return the empty list. In scalar context only the first
-object is returned. The returned message parts should be regarded as
-read-only (future versions of this library might make it possible
-to modify the parent by modifying the parts).
-
-If the content type of $msg is C<message/*> then there will only be
-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 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
-should not be modified or made part of other messages.
-
-When updating the message with this method and the old content type of
-$mess is not C<multipart/*> or C<message/*>, then the content type is
-set to C<multipart/mixed> and all other content headers are cleared.
-
-This method will croak if the content type is C<message/*> and more
-than one part is provided.
-
-=item $mess->add_part( $part )
-
-This will add a part to a message. The $part argument should be
-another C<HTTP::Message> object. If the previous content type of
-$mess is not C<multipart/*> then the old content (together with all
-content headers) will be made part #1 and the content type made
-C<multipart/mixed> before the new part is added. The $part object is
-owned by $mess after this call and should not be modified or made part
-of other messages.
-
-There is no return value.
-
-=item $mess->clear
-
-Will clear the headers and set the content to the empty string. There
-is no return value
-
-=item $mess->protocol
-
-=item $mess->protocol( $proto )
-
-Sets the HTTP protocol used for the message. The protocol() is a string
-like C<HTTP/1.0> or C<HTTP/1.1>.
-
-=item $mess->clone
-
-Returns a copy of the message object.
-
-=item $mess->as_string
-
-=item $mess->as_string( $eol )
-
-Returns the message formatted as a single string.
-
-The optional $eol parameter specifies the line ending sequence to use.
-The default is "\n". If no $eol is given then as_string will ensure
-that the returned string is newline terminated (even when the message
-content is not). No extra newline is appended if an explicit $eol is
-passed.
-
-=item $mess->dump( %opt )
-
-Returns the message formatted as a string. In void context print the string.
-
-This differs from C<< $mess->as_string >> in that it escapes the bytes
-of the content so that it's safe to print them and it limits how much
-content to print. The escapes syntax used is the same as for Perl's
-double quoted strings. If there is no content the string "(no
-content)" is shown in its place.
-
-Options to influence the output can be passed as key/value pairs. The
-following options are recognized:
-
-=over
-
-=item maxlength => $num
-
-How much of the content to show. The default is 512. Set this to 0
-for unlimited.
-
-If the content is longer then the string is chopped at the limit and
-the string "...\n(### more bytes not shown)" appended.
-
-=item no_content => $str
-
-Replaces the "(no content)" marker.
-
-=item prefix => $str
-
-A string that will be prefixed to each line of the dump.
-
-=back
-
-=back
-
-All methods unknown to C<HTTP::Message> itself are delegated to the
-C<HTTP::Headers> object that is part of every message. This allows
-convenient access to these methods. Refer to L<HTTP::Headers> for
-details of these methods:
-
- $mess->header( $field => $val )
- $mess->push_header( $field => $val )
- $mess->init_header( $field => $val )
- $mess->remove_header( $field )
- $mess->remove_content_headers
- $mess->header_field_names
- $mess->scan( \&doit )
-
- $mess->date
- $mess->expires
- $mess->if_modified_since
- $mess->if_unmodified_since
- $mess->last_modified
- $mess->content_type
- $mess->content_encoding
- $mess->content_length
- $mess->content_language
- $mess->title
- $mess->user_agent
- $mess->server
- $mess->from
- $mess->referer
- $mess->www_authenticate
- $mess->authorization
- $mess->proxy_authorization
- $mess->authorization_basic
- $mess->proxy_authorization_basic
-
-=head1 COPYRIGHT
-
-Copyright 1995-2004 Gisle Aas.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Negotiate.pm b/Master/tlpkg/tlperl/lib/HTTP/Negotiate.pm
deleted file mode 100644
index d293ce86d97..00000000000
--- a/Master/tlpkg/tlperl/lib/HTTP/Negotiate.pm
+++ /dev/null
@@ -1,528 +0,0 @@
-package HTTP::Negotiate;
-
-$VERSION = "6.01";
-sub Version { $VERSION; }
-
-require Exporter;
-@ISA = qw(Exporter);
-@EXPORT = qw(choose);
-
-require HTTP::Headers;
-
-$DEBUG = 0;
-
-sub choose ($;$)
-{
- my($variants, $request) = @_;
- my(%accept);
-
- unless (defined $request) {
- # Create a request object from the CGI environment variables
- $request = HTTP::Headers->new;
- $request->header('Accept', $ENV{HTTP_ACCEPT})
- if $ENV{HTTP_ACCEPT};
- $request->header('Accept-Charset', $ENV{HTTP_ACCEPT_CHARSET})
- if $ENV{HTTP_ACCEPT_CHARSET};
- $request->header('Accept-Encoding', $ENV{HTTP_ACCEPT_ENCODING})
- if $ENV{HTTP_ACCEPT_ENCODING};
- $request->header('Accept-Language', $ENV{HTTP_ACCEPT_LANGUAGE})
- if $ENV{HTTP_ACCEPT_LANGUAGE};
- }
-
- # Get all Accept values from the request. Build a hash initialized
- # like this:
- #
- # %accept = ( type => { 'audio/*' => { q => 0.2, mbx => 20000 },
- # 'audio/basic' => { q => 1 },
- # },
- # language => { 'no' => { q => 1 },
- # }
- # );
-
- $request->scan(sub {
- my($key, $val) = @_;
-
- my $type;
- if ($key =~ s/^Accept-//) {
- $type = lc($key);
- }
- elsif ($key eq "Accept") {
- $type = "type";
- }
- else {
- return;
- }
-
- $val =~ s/\s+//g;
- my $default_q = 1;
- for my $name (split(/,/, $val)) {
- my(%param, $param);
- if ($name =~ s/;(.*)//) {
- for $param (split(/;/, $1)) {
- my ($pk, $pv) = split(/=/, $param, 2);
- $param{lc $pk} = $pv;
- }
- }
- $name = lc $name;
- if (defined $param{'q'}) {
- $param{'q'} = 1 if $param{'q'} > 1;
- $param{'q'} = 0 if $param{'q'} < 0;
- }
- else {
- $param{'q'} = $default_q;
-
- # This makes sure that the first ones are slightly better off
- # and therefore more likely to be chosen.
- $default_q -= 0.0001;
- }
- $accept{$type}{$name} = \%param;
- }
- });
-
- # Check if any of the variants specify a language. We do this
- # because it influences how we treat those without (they default to
- # 0.5 instead of 1).
- my $any_lang = 0;
- for $var (@$variants) {
- if ($var->[5]) {
- $any_lang = 1;
- last;
- }
- }
-
- if ($DEBUG) {
- print "Negotiation parameters in the request\n";
- for $type (keys %accept) {
- print " $type:\n";
- for $name (keys %{$accept{$type}}) {
- print " $name\n";
- for $pv (keys %{$accept{$type}{$name}}) {
- print " $pv = $accept{$type}{$name}{$pv}\n";
- }
- }
- }
- }
-
- my @Q = (); # This is where we collect the results of the
- # quality calculations
-
- # Calculate quality for all the variants that are available.
- for (@$variants) {
- my($id, $qs, $ct, $enc, $cs, $lang, $bs) = @$_;
- $qs = 1 unless defined $qs;
- $ct = '' unless defined $ct;
- $bs = 0 unless defined $bs;
- $lang = lc($lang) if $lang; # lg tags are always case-insensitive
- if ($DEBUG) {
- print "\nEvaluating $id (ct='$ct')\n";
- printf " qs = %.3f\n", $qs;
- print " enc = $enc\n" if $enc && !ref($enc);
- print " enc = @$enc\n" if $enc && ref($enc);
- print " cs = $cs\n" if $cs;
- print " lang = $lang\n" if $lang;
- print " bs = $bs\n" if $bs;
- }
-
- # Calculate encoding quality
- my $qe = 1;
- # If the variant has no assigned Content-Encoding, or if no
- # Accept-Encoding field is present, then the value assigned
- # is "qe=1". If *all* of the variant's content encodings
- # are listed in the Accept-Encoding field, then the value
- # assigned is "qw=1". If *any* of the variant's content
- # encodings are not listed in the provided Accept-Encoding
- # field, then the value assigned is "qe=0"
- if (exists $accept{'encoding'} && $enc) {
- my @enc = ref($enc) ? @$enc : ($enc);
- for (@enc) {
- print "Is encoding $_ accepted? " if $DEBUG;
- unless(exists $accept{'encoding'}{$_}) {
- print "no\n" if $DEBUG;
- $qe = 0;
- last;
- }
- else {
- print "yes\n" if $DEBUG;
- }
- }
- }
-
- # Calculate charset quality
- my $qc = 1;
- # If the variant's media-type has no charset parameter,
- # or the variant's charset is US-ASCII, or if no Accept-Charset
- # field is present, then the value assigned is "qc=1". If the
- # variant's charset is listed in the Accept-Charset field,
- # then the value assigned is "qc=1. Otherwise, if the variant's
- # charset is not listed in the provided Accept-Encoding field,
- # then the value assigned is "qc=0".
- if (exists $accept{'charset'} && $cs && $cs ne 'us-ascii' ) {
- $qc = 0 unless $accept{'charset'}{$cs};
- }
-
- # Calculate language quality
- my $ql = 1;
- if ($lang && exists $accept{'language'}) {
- my @lang = ref($lang) ? @$lang : ($lang);
- # If any of the variant's content languages are listed
- # in the Accept-Language field, the the value assigned is
- # the largest of the "q" parameter values for those language
- # tags.
- my $q = undef;
- for (@lang) {
- next unless exists $accept{'language'}{$_};
- my $this_q = $accept{'language'}{$_}{'q'};
- $q = $this_q unless defined $q;
- $q = $this_q if $this_q > $q;
- }
- if(defined $q) {
- $DEBUG and print " -- Exact language match at q=$q\n";
- }
- else {
- # If there was no exact match and at least one of
- # the Accept-Language field values is a complete
- # subtag prefix of the content language tag(s), then
- # the "q" parameter value of the largest matching
- # prefix is used.
- $DEBUG and print " -- No exact language match\n";
- my $selected = undef;
- for $al (keys %{ $accept{'language'} }) {
- if (index($al, "$lang-") == 0) {
- # $lang starting with $al isn't enough, or else
- # Accept-Language: hu (Hungarian) would seem
- # to accept a document in hup (Hupa)
- $DEBUG and print " -- $al ISA $lang\n";
- $selected = $al unless defined $selected;
- $selected = $al if length($al) > length($selected);
- }
- else {
- $DEBUG and print " -- $lang isn't a $al\n";
- }
- }
- $q = $accept{'language'}{$selected}{'q'} if $selected;
-
- # If none of the variant's content language tags or
- # tag prefixes are listed in the provided
- # Accept-Language field, then the value assigned
- # is "ql=0.001"
- $q = 0.001 unless defined $q;
- }
- $ql = $q;
- }
- else {
- $ql = 0.5 if $any_lang && exists $accept{'language'};
- }
-
- my $q = 1;
- my $mbx = undef;
- # If no Accept field is given, then the value assigned is "q=1".
- # If at least one listed media range matches the variant's media
- # type, then the "q" parameter value assigned to the most specific
- # of those matched is used (e.g. "text/html;version=3.0" is more
- # specific than "text/html", which is more specific than "text/*",
- # which in turn is more specific than "*/*"). If not media range
- # in the provided Accept field matches the variant's media type,
- # then the value assigned is "q=0".
- if (exists $accept{'type'} && $ct) {
- # First we clean up our content-type
- $ct =~ s/\s+//g;
- my $params = "";
- $params = $1 if $ct =~ s/;(.*)//;
- my($type, $subtype) = split("/", $ct, 2);
- my %param = ();
- for $param (split(/;/, $params)) {
- my($pk,$pv) = split(/=/, $param, 2);
- $param{$pk} = $pv;
- }
-
- my $sel_q = undef;
- my $sel_mbx = undef;
- my $sel_specificness = 0;
-
- ACCEPT_TYPE:
- for $at (keys %{ $accept{'type'} }) {
- print "Consider $at...\n" if $DEBUG;
- my($at_type, $at_subtype) = split("/", $at, 2);
- # Is it a match on the type
- next if $at_type ne '*' && $at_type ne $type;
- next if $at_subtype ne '*' && $at_subtype ne $subtype;
- my $specificness = 0;
- $specificness++ if $at_type ne '*';
- $specificness++ if $at_subtype ne '*';
- # Let's see if content-type parameters also match
- while (($pk, $pv) = each %param) {
- print "Check if $pk = $pv is true\n" if $DEBUG;
- next unless exists $accept{'type'}{$at}{$pk};
- next ACCEPT_TYPE
- unless $accept{'type'}{$at}{$pk} eq $pv;
- print "yes it is!!\n" if $DEBUG;
- $specificness++;
- }
- print "Hurray, type match with specificness = $specificness\n"
- if $DEBUG;
-
- if (!defined($sel_q) || $sel_specificness < $specificness) {
- $sel_q = $accept{'type'}{$at}{'q'};
- $sel_mbx = $accept{'type'}{$at}{'mbx'};
- $sel_specificness = $specificness;
- }
- }
- $q = $sel_q || 0;
- $mbx = $sel_mbx;
- }
-
- my $Q;
- if (!defined($mbx) || $mbx >= $bs) {
- $Q = $qs * $qe * $qc * $ql * $q;
- }
- else {
- $Q = 0;
- print "Variant's size is too large ==> Q=0\n" if $DEBUG;
- }
-
- if ($DEBUG) {
- $mbx = "undef" unless defined $mbx;
- printf "Q=%.4f", $Q;
- print " (q=$q, mbx=$mbx, qe=$qe, qc=$qc, ql=$ql, qs=$qs)\n";
- }
-
- push(@Q, [$id, $Q, $bs]);
- }
-
-
- @Q = sort { $b->[1] <=> $a->[1] || $a->[2] <=> $b->[2] } @Q;
-
- return @Q if wantarray;
- return undef unless @Q;
- return undef if $Q[0][1] == 0;
- $Q[0][0];
-}
-
-1;
-
-__END__
-
-
-=head1 NAME
-
-HTTP::Negotiate - choose a variant to serve
-
-=head1 SYNOPSIS
-
- use HTTP::Negotiate qw(choose);
-
- # ID QS Content-Type Encoding Char-Set Lang Size
- $variants =
- [['var1', 1.000, 'text/html', undef, 'iso-8859-1', 'en', 3000],
- ['var2', 0.950, 'text/plain', 'gzip', 'us-ascii', 'no', 400],
- ['var3', 0.3, 'image/gif', undef, undef, undef, 43555],
- ];
-
- @preferred = choose($variants, $request_headers);
- $the_one = choose($variants);
-
-=head1 DESCRIPTION
-
-This module provides a complete implementation of the HTTP content
-negotiation algorithm specified in F<draft-ietf-http-v11-spec-00.ps>
-chapter 12. Content negotiation allows for the selection of a
-preferred content representation based upon attributes of the
-negotiable variants and the value of the various Accept* header fields
-in the request.
-
-The variants are ordered by preference by calling the function
-choose().
-
-The first parameter is reference to an array of the variants to
-choose among.
-Each element in this array is an array with the values [$id, $qs,
-$content_type, $content_encoding, $charset, $content_language,
-$content_length] whose meanings are described
-below. The $content_encoding and $content_language can be either a
-single scalar value or an array reference if there are several values.
-
-The second optional parameter is either a HTTP::Headers or a HTTP::Request
-object which is searched for "Accept*" headers. If this
-parameter is missing, then the accept specification is initialized
-from the CGI environment variables HTTP_ACCEPT, HTTP_ACCEPT_CHARSET,
-HTTP_ACCEPT_ENCODING and HTTP_ACCEPT_LANGUAGE.
-
-In an array context, choose() returns a list of [variant
-identifier, calculated quality, size] tuples. The values are sorted by
-quality, highest quality first. If the calculated quality is the same
-for two variants, then they are sorted by size (smallest first). I<E.g.>:
-
- (['var1', 1, 2000], ['var2', 0.3, 512], ['var3', 0.3, 1024]);
-
-Note that also zero quality variants are included in the return list
-even if these should never be served to the client.
-
-In a scalar context, it returns the identifier of the variant with the
-highest score or C<undef> if none have non-zero quality.
-
-If the $HTTP::Negotiate::DEBUG variable is set to TRUE, then a lot of
-noise is generated on STDOUT during evaluation of choose().
-
-=head1 VARIANTS
-
-A variant is described by a list of the following values. If the
-attribute does not make sense or is unknown for a variant, then use
-C<undef> instead.
-
-=over 3
-
-=item identifier
-
-This is a string that you use as the name for the variant. This
-identifier for the preferred variants returned by choose().
-
-=item qs
-
-This is a number between 0.000 and 1.000 that describes the "source
-quality". This is what F<draft-ietf-http-v11-spec-00.ps> says about this
-value:
-
-Source quality is measured by the content provider as representing the
-amount of degradation from the original source. For example, a
-picture in JPEG form would have a lower qs when translated to the XBM
-format, and much lower qs when translated to an ASCII-art
-representation. Note, however, that this is a function of the source
-- an original piece of ASCII-art may degrade in quality if it is
-captured in JPEG form. The qs values should be assigned to each
-variant by the content provider; if no qs value has been assigned, the
-default is generally "qs=1".
-
-=item content-type
-
-This is the media type of the variant. The media type does not
-include a charset attribute, but might contain other parameters.
-Examples are:
-
- text/html
- text/html;version=2.0
- text/plain
- image/gif
- image/jpg
-
-=item content-encoding
-
-This is one or more content encodings that has been applied to the
-variant. The content encoding is generally used as a modifier to the
-content media type. The most common content encodings are:
-
- gzip
- compress
-
-=item content-charset
-
-This is the character set used when the variant contains text.
-The charset value should generally be C<undef> or one of these:
-
- us-ascii
- iso-8859-1 ... iso-8859-9
- iso-2022-jp
- iso-2022-jp-2
- iso-2022-kr
- unicode-1-1
- unicode-1-1-utf-7
- unicode-1-1-utf-8
-
-=item content-language
-
-This describes one or more languages that are used in the variant.
-Language is described like this in F<draft-ietf-http-v11-spec-00.ps>: A
-language is in this context a natural language spoken, written, or
-otherwise conveyed by human beings for communication of information to
-other human beings. Computer languages are explicitly excluded.
-
-The language tags are defined by RFC 3066. Examples
-are:
-
- no Norwegian
- en International English
- en-US US English
- en-cockney
-
-=item content-length
-
-This is the number of bytes used to represent the content.
-
-=back
-
-=head1 ACCEPT HEADERS
-
-The following Accept* headers can be used for describing content
-preferences in a request (This description is an edited extract from
-F<draft-ietf-http-v11-spec-00.ps>):
-
-=over 3
-
-=item Accept
-
-This header can be used to indicate a list of media ranges which are
-acceptable as a response to the request. The "*" character is used to
-group media types into ranges, with "*/*" indicating all media types
-and "type/*" indicating all subtypes of that type.
-
-The parameter q is used to indicate the quality factor, which
-represents the user's preference for that range of media types. The
-parameter mbx gives the maximum acceptable size of the response
-content. The default values are: q=1 and mbx=infinity. If no Accept
-header is present, then the client accepts all media types with q=1.
-
-For example:
-
- Accept: audio/*;q=0.2;mbx=200000, audio/basic
-
-would mean: "I prefer audio/basic (of any size), but send me any audio
-type if it is the best available after an 80% mark-down in quality and
-its size is less than 200000 bytes"
-
-
-=item Accept-Charset
-
-Used to indicate what character sets are acceptable for the response.
-The "us-ascii" character set is assumed to be acceptable for all user
-agents. If no Accept-Charset field is given, the default is that any
-charset is acceptable. Example:
-
- Accept-Charset: iso-8859-1, unicode-1-1
-
-
-=item Accept-Encoding
-
-Restricts the Content-Encoding values which are acceptable in the
-response. If no Accept-Encoding field is present, the server may
-assume that the client will accept any content encoding. An empty
-Accept-Encoding means that no content encoding is acceptable. Example:
-
- Accept-Encoding: compress, gzip
-
-
-=item Accept-Language
-
-This field is similar to Accept, but restricts the set of natural
-languages that are preferred in a response. Each language may be
-given an associated quality value which represents an estimate of the
-user's comprehension of that language. For example:
-
- Accept-Language: no, en-gb;q=0.8, de;q=0.55
-
-would mean: "I prefer Norwegian, but will accept British English (with
-80% comprehension) or German (with 55% comprehension).
-
-=back
-
-
-=head1 COPYRIGHT
-
-Copyright 1996,2001 Gisle Aas.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=head1 AUTHOR
-
-Gisle Aas <gisle@aas.no>
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Request.pm b/Master/tlpkg/tlperl/lib/HTTP/Request.pm
deleted file mode 100644
index 154ea2f926c..00000000000
--- a/Master/tlpkg/tlperl/lib/HTTP/Request.pm
+++ /dev/null
@@ -1,242 +0,0 @@
-package HTTP::Request;
-
-require HTTP::Message;
-@ISA = qw(HTTP::Message);
-$VERSION = "6.00";
-
-use strict;
-
-
-
-sub new
-{
- my($class, $method, $uri, $header, $content) = @_;
- my $self = $class->SUPER::new($header, $content);
- $self->method($method);
- $self->uri($uri);
- $self;
-}
-
-
-sub parse
-{
- my($class, $str) = @_;
- my $request_line;
- if ($str =~ s/^(.*)\n//) {
- $request_line = $1;
- }
- else {
- $request_line = $str;
- $str = "";
- }
-
- my $self = $class->SUPER::parse($str);
- my($method, $uri, $protocol) = split(' ', $request_line);
- $self->method($method) if defined($method);
- $self->uri($uri) if defined($uri);
- $self->protocol($protocol) if $protocol;
- $self;
-}
-
-
-sub clone
-{
- my $self = shift;
- my $clone = bless $self->SUPER::clone, ref($self);
- $clone->method($self->method);
- $clone->uri($self->uri);
- $clone;
-}
-
-
-sub method
-{
- shift->_elem('_method', @_);
-}
-
-
-sub uri
-{
- my $self = shift;
- my $old = $self->{'_uri'};
- if (@_) {
- my $uri = shift;
- if (!defined $uri) {
- # that's ok
- }
- elsif (ref $uri) {
- Carp::croak("A URI can't be a " . ref($uri) . " reference")
- if ref($uri) eq 'HASH' or ref($uri) eq 'ARRAY';
- Carp::croak("Can't use a " . ref($uri) . " object as a URI")
- unless $uri->can('scheme');
- $uri = $uri->clone;
- unless ($HTTP::URI_CLASS eq "URI") {
- # Argh!! Hate this... old LWP legacy!
- eval { local $SIG{__DIE__}; $uri = $uri->abs; };
- die $@ if $@ && $@ !~ /Missing base argument/;
- }
- }
- else {
- $uri = $HTTP::URI_CLASS->new($uri);
- }
- $self->{'_uri'} = $uri;
- delete $self->{'_uri_canonical'};
- }
- $old;
-}
-
-*url = \&uri; # legacy
-
-sub uri_canonical
-{
- my $self = shift;
- return $self->{'_uri_canonical'} ||= $self->{'_uri'}->canonical;
-}
-
-
-sub accept_decodable
-{
- my $self = shift;
- $self->header("Accept-Encoding", scalar($self->decodable));
-}
-
-sub as_string
-{
- my $self = shift;
- my($eol) = @_;
- $eol = "\n" unless defined $eol;
-
- my $req_line = $self->method || "-";
- my $uri = $self->uri;
- $uri = (defined $uri) ? $uri->as_string : "-";
- $req_line .= " $uri";
- my $proto = $self->protocol;
- $req_line .= " $proto" if $proto;
-
- return join($eol, $req_line, $self->SUPER::as_string(@_));
-}
-
-sub dump
-{
- my $self = shift;
- my @pre = ($self->method || "-", $self->uri || "-");
- if (my $prot = $self->protocol) {
- push(@pre, $prot);
- }
-
- return $self->SUPER::dump(
- preheader => join(" ", @pre),
- @_,
- );
-}
-
-
-1;
-
-__END__
-
-=head1 NAME
-
-HTTP::Request - HTTP style request message
-
-=head1 SYNOPSIS
-
- require HTTP::Request;
- $request = HTTP::Request->new(GET => 'http://www.example.com/');
-
-and usually used like this:
-
- $ua = LWP::UserAgent->new;
- $response = $ua->request($request);
-
-=head1 DESCRIPTION
-
-C<HTTP::Request> is a class encapsulating HTTP style requests,
-consisting of a request line, some headers, and a content body. Note
-that the LWP library uses HTTP style requests even for non-HTTP
-protocols. Instances of this class are usually passed to the
-request() method of an C<LWP::UserAgent> object.
-
-C<HTTP::Request> is a subclass of C<HTTP::Message> and therefore
-inherits its methods. The following additional methods are available:
-
-=over 4
-
-=item $r = HTTP::Request->new( $method, $uri )
-
-=item $r = HTTP::Request->new( $method, $uri, $header )
-
-=item $r = HTTP::Request->new( $method, $uri, $header, $content )
-
-Constructs a new C<HTTP::Request> object describing a request on the
-object $uri using method $method. The $method argument must be a
-string. The $uri argument can be either a string, or a reference to a
-C<URI> object. The optional $header argument should be a reference to
-an C<HTTP::Headers> object or a plain array reference of key/value
-pairs. The optional $content argument should be a string of bytes.
-
-=item $r = HTTP::Request->parse( $str )
-
-This constructs a new request object by parsing the given string.
-
-=item $r->method
-
-=item $r->method( $val )
-
-This is used to get/set the method attribute. The method should be a
-short string like "GET", "HEAD", "PUT" or "POST".
-
-=item $r->uri
-
-=item $r->uri( $val )
-
-This is used to get/set the uri attribute. The $val can be a
-reference to a URI object or a plain string. If a string is given,
-then it should be parseable as an absolute URI.
-
-=item $r->header( $field )
-
-=item $r->header( $field => $value )
-
-This is used to get/set header values and it is inherited from
-C<HTTP::Headers> via C<HTTP::Message>. See L<HTTP::Headers> for
-details and other similar methods that can be used to access the
-headers.
-
-=item $r->accept_decodable
-
-This will set the C<Accept-Encoding> header to the list of encodings
-that decoded_content() can decode.
-
-=item $r->content
-
-=item $r->content( $bytes )
-
-This is used to get/set the content and it is inherited from the
-C<HTTP::Message> base class. See L<HTTP::Message> for details and
-other methods that can be used to access the content.
-
-Note that the content should be a string of bytes. Strings in perl
-can contain characters outside the range of a byte. The C<Encode>
-module can be used to turn such strings into a string of bytes.
-
-=item $r->as_string
-
-=item $r->as_string( $eol )
-
-Method returning a textual representation of the request.
-
-=back
-
-=head1 SEE ALSO
-
-L<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Request::Common>,
-L<HTTP::Response>
-
-=head1 COPYRIGHT
-
-Copyright 1995-2004 Gisle Aas.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Request/Common.pm b/Master/tlpkg/tlperl/lib/HTTP/Request/Common.pm
deleted file mode 100644
index 79e9e5e7429..00000000000
--- a/Master/tlpkg/tlperl/lib/HTTP/Request/Common.pm
+++ /dev/null
@@ -1,514 +0,0 @@
-package HTTP::Request::Common;
-
-use strict;
-use vars qw(@EXPORT @EXPORT_OK $VERSION $DYNAMIC_FILE_UPLOAD);
-
-$DYNAMIC_FILE_UPLOAD ||= 0; # make it defined (don't know why)
-
-require Exporter;
-*import = \&Exporter::import;
-@EXPORT =qw(GET HEAD PUT POST);
-@EXPORT_OK = qw($DYNAMIC_FILE_UPLOAD DELETE);
-
-require HTTP::Request;
-use Carp();
-
-$VERSION = "6.04";
-
-my $CRLF = "\015\012"; # "\r\n" is not portable
-
-sub GET { _simple_req('GET', @_); }
-sub HEAD { _simple_req('HEAD', @_); }
-sub PUT { _simple_req('PUT' , @_); }
-sub DELETE { _simple_req('DELETE', @_); }
-
-sub POST
-{
- my $url = shift;
- my $req = HTTP::Request->new(POST => $url);
- my $content;
- $content = shift if @_ and ref $_[0];
- my($k, $v);
- while (($k,$v) = splice(@_, 0, 2)) {
- if (lc($k) eq 'content') {
- $content = $v;
- }
- else {
- $req->push_header($k, $v);
- }
- }
- my $ct = $req->header('Content-Type');
- unless ($ct) {
- $ct = 'application/x-www-form-urlencoded';
- }
- elsif ($ct eq 'form-data') {
- $ct = 'multipart/form-data';
- }
-
- if (ref $content) {
- if ($ct =~ m,^multipart/form-data\s*(;|$),i) {
- require HTTP::Headers::Util;
- my @v = HTTP::Headers::Util::split_header_words($ct);
- Carp::carp("Multiple Content-Type headers") if @v > 1;
- @v = @{$v[0]};
-
- my $boundary;
- my $boundary_index;
- for (my @tmp = @v; @tmp;) {
- my($k, $v) = splice(@tmp, 0, 2);
- if ($k eq "boundary") {
- $boundary = $v;
- $boundary_index = @v - @tmp - 1;
- last;
- }
- }
-
- ($content, $boundary) = form_data($content, $boundary, $req);
-
- if ($boundary_index) {
- $v[$boundary_index] = $boundary;
- }
- else {
- push(@v, boundary => $boundary);
- }
-
- $ct = HTTP::Headers::Util::join_header_words(@v);
- }
- else {
- # We use a temporary URI object to format
- # the application/x-www-form-urlencoded content.
- require URI;
- 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 if defined($content);
- }
- }
-
- $req->header('Content-Type' => $ct); # might be redundant
- if (defined($content)) {
- $req->header('Content-Length' =>
- length($content)) unless ref($content);
- $req->content($content);
- }
- else {
- $req->header('Content-Length' => 0);
- }
- $req;
-}
-
-
-sub _simple_req
-{
- my($method, $url) = splice(@_, 0, 2);
- my $req = HTTP::Request->new($method => $url);
- my($k, $v);
- my $content;
- while (($k,$v) = splice(@_, 0, 2)) {
- if (lc($k) eq 'content') {
- $req->add_content($v);
- $content++;
- }
- else {
- $req->push_header($k, $v);
- }
- }
- if ($content && !defined($req->header("Content-Length"))) {
- $req->header("Content-Length", length(${$req->content_ref}));
- }
- $req;
-}
-
-
-sub form_data # RFC1867
-{
- my($data, $boundary, $req) = @_;
- my @data = ref($data) eq "HASH" ? %$data : @$data; # copy
- my $fhparts;
- my @parts;
- my($k,$v);
- while (($k,$v) = splice(@data, 0, 2)) {
- if (!ref($v)) {
- $k =~ s/([\\\"])/\\$1/g; # escape quotes and backslashes
- push(@parts,
- qq(Content-Disposition: form-data; name="$k"$CRLF$CRLF$v));
- }
- else {
- my($file, $usename, @headers) = @$v;
- unless (defined $usename) {
- $usename = $file;
- $usename =~ s,.*/,, if defined($usename);
- }
- $k =~ s/([\\\"])/\\$1/g;
- my $disp = qq(form-data; name="$k");
- if (defined($usename) and length($usename)) {
- $usename =~ s/([\\\"])/\\$1/g;
- $disp .= qq(; filename="$usename");
- }
- my $content = "";
- my $h = HTTP::Headers->new(@headers);
- if ($file) {
- open(my $fh, "<", $file) or Carp::croak("Can't open file $file: $!");
- binmode($fh);
- if ($DYNAMIC_FILE_UPLOAD) {
- # will read file later, close it now in order to
- # not accumulate to many open file handles
- close($fh);
- $content = \$file;
- }
- else {
- local($/) = undef; # slurp files
- $content = <$fh>;
- close($fh);
- }
- unless ($h->header("Content-Type")) {
- require LWP::MediaTypes;
- LWP::MediaTypes::guess_media_type($file, $h);
- }
- }
- if ($h->header("Content-Disposition")) {
- # just to get it sorted first
- $disp = $h->header("Content-Disposition");
- $h->remove_header("Content-Disposition");
- }
- if ($h->header("Content")) {
- $content = $h->header("Content");
- $h->remove_header("Content");
- }
- my $head = join($CRLF, "Content-Disposition: $disp",
- $h->as_string($CRLF),
- "");
- if (ref $content) {
- push(@parts, [$head, $$content]);
- $fhparts++;
- }
- else {
- push(@parts, $head . $content);
- }
- }
- }
- return ("", "none") unless @parts;
-
- my $content;
- if ($fhparts) {
- $boundary = boundary(10) # hopefully enough randomness
- unless $boundary;
-
- # add the boundaries to the @parts array
- for (1..@parts-1) {
- splice(@parts, $_*2-1, 0, "$CRLF--$boundary$CRLF");
- }
- unshift(@parts, "--$boundary$CRLF");
- push(@parts, "$CRLF--$boundary--$CRLF");
-
- # See if we can generate Content-Length header
- my $length = 0;
- for (@parts) {
- if (ref $_) {
- my ($head, $f) = @$_;
- my $file_size;
- unless ( -f $f && ($file_size = -s _) ) {
- # The file is either a dynamic file like /dev/audio
- # or perhaps a file in the /proc file system where
- # stat may return a 0 size even though reading it
- # will produce data. So we cannot make
- # a Content-Length header.
- undef $length;
- last;
- }
- $length += $file_size + length $head;
- }
- else {
- $length += length;
- }
- }
- $length && $req->header('Content-Length' => $length);
-
- # set up a closure that will return content piecemeal
- $content = sub {
- for (;;) {
- unless (@parts) {
- defined $length && $length != 0 &&
- Carp::croak "length of data sent did not match calculated Content-Length header. Probably because uploaded file changed in size during transfer.";
- return;
- }
- my $p = shift @parts;
- unless (ref $p) {
- $p .= shift @parts while @parts && !ref($parts[0]);
- defined $length && ($length -= length $p);
- return $p;
- }
- my($buf, $fh) = @$p;
- unless (ref($fh)) {
- my $file = $fh;
- undef($fh);
- open($fh, "<", $file) || Carp::croak("Can't open file $file: $!");
- binmode($fh);
- }
- my $buflength = length $buf;
- my $n = read($fh, $buf, 2048, $buflength);
- if ($n) {
- $buflength += $n;
- unshift(@parts, ["", $fh]);
- }
- else {
- close($fh);
- }
- if ($buflength) {
- defined $length && ($length -= $buflength);
- return $buf
- }
- }
- };
-
- }
- else {
- $boundary = boundary() unless $boundary;
-
- my $bno = 0;
- CHECK_BOUNDARY:
- {
- for (@parts) {
- if (index($_, $boundary) >= 0) {
- # must have a better boundary
- $boundary = boundary(++$bno);
- redo CHECK_BOUNDARY;
- }
- }
- last;
- }
- $content = "--$boundary$CRLF" .
- join("$CRLF--$boundary$CRLF", @parts) .
- "$CRLF--$boundary--$CRLF";
- }
-
- wantarray ? ($content, $boundary) : $content;
-}
-
-
-sub boundary
-{
- my $size = shift || return "xYzZY";
- require MIME::Base64;
- my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), "");
- $b =~ s/[\W]/X/g; # ensure alnum only
- $b;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-HTTP::Request::Common - Construct common HTTP::Request objects
-
-=head1 SYNOPSIS
-
- use HTTP::Request::Common;
- $ua = LWP::UserAgent->new;
- $ua->request(GET 'http://www.sn.no/');
- $ua->request(POST 'http://somewhere/foo', [foo => bar, bar => foo]);
-
-=head1 DESCRIPTION
-
-This module provide functions that return newly created C<HTTP::Request>
-objects. These functions are usually more convenient to use than the
-standard C<HTTP::Request> constructor for the most common requests. The
-following functions are provided:
-
-=over 4
-
-=item GET $url
-
-=item GET $url, Header => Value,...
-
-The GET() function returns an C<HTTP::Request> object initialized with
-the "GET" method and the specified URL. It is roughly equivalent to the
-following call
-
- HTTP::Request->new(
- GET => $url,
- HTTP::Headers->new(Header => Value,...),
- )
-
-but is less cluttered. What is different is that a header named
-C<Content> will initialize the content part of the request instead of
-setting a header field. Note that GET requests should normally not
-have a content, so this hack makes more sense for the PUT() and POST()
-functions described below.
-
-The get(...) method of C<LWP::UserAgent> exists as a shortcut for
-$ua->request(GET ...).
-
-=item HEAD $url
-
-=item HEAD $url, Header => Value,...
-
-Like GET() but the method in the request is "HEAD".
-
-The head(...) method of "LWP::UserAgent" exists as a shortcut for
-$ua->request(HEAD ...).
-
-=item PUT $url
-
-=item PUT $url, Header => Value,...
-
-=item PUT $url, Header => Value,..., Content => $content
-
-Like GET() but the method in the request is "PUT".
-
-The content of the request can be specified using the "Content"
-pseudo-header. This steals a bit of the header field namespace as
-there is no way to directly specify a header that is actually called
-"Content". If you really need this you must update the request
-returned in a separate statement.
-
-=item DELETE $url
-
-=item DELETE $url, Header => Value,...
-
-Like GET() but the method in the request is "DELETE". This function
-is not exported by default.
-
-=item POST $url
-
-=item POST $url, Header => Value,...
-
-=item POST $url, $form_ref, Header => Value,...
-
-=item POST $url, Header => Value,..., Content => $form_ref
-
-=item POST $url, Header => Value,..., Content => $content
-
-This works mostly like PUT() with "POST" as the method, but this
-function also takes a second optional array or hash reference
-parameter $form_ref. As for PUT() the content can also be specified
-directly using the "Content" pseudo-header, and you may also provide
-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 an HTML E<lt>form> POSTing like this:
-
- POST 'http://www.perl.org/survey.cgi',
- [ name => 'Gisle Aas',
- email => 'gisle@aas.no',
- gender => 'M',
- born => '1964',
- perc => '3%',
- ];
-
-This will create an HTTP::Request object that looks like this:
-
- POST http://www.perl.org/survey.cgi
- Content-Length: 66
- Content-Type: application/x-www-form-urlencoded
-
- name=Gisle%20Aas&email=gisle%40aas.no&gender=M&born=1964&perc=3%25
-
-Multivalued form fields can be specified by either repeating the field
-name or by passing the value as an array reference.
-
-The POST method also supports the C<multipart/form-data> content used
-for I<Form-based File Upload> as specified in RFC 1867. You trigger
-this content format by specifying a content type of C<'form-data'> as
-one of the request headers. If one of the values in the $form_ref is
-an array reference, then it is treated as a file part specification
-with the following interpretation:
-
- [ $file, $filename, Header => Value... ]
- [ undef, $filename, Header => Value,..., Content => $content ]
-
-The first value in the array ($file) is the name of a file to open.
-This file will be read and its content placed in the request. The
-routine will croak if the file can't be opened. Use an C<undef> as
-$file value if you want to specify the content directly with a
-C<Content> header. The $filename is the filename to report in the
-request. If this value is undefined, then the basename of the $file
-will be used. You can specify an empty string as $filename if you
-want to suppress sending the filename when you provide a $file value.
-
-If a $file is provided by no C<Content-Type> header, then C<Content-Type>
-and C<Content-Encoding> will be filled in automatically with the values
-returned by LWP::MediaTypes::guess_media_type()
-
-Sending my F<~/.profile> to the survey used as example above can be
-achieved by this:
-
- POST 'http://www.perl.org/survey.cgi',
- Content_Type => 'form-data',
- Content => [ name => 'Gisle Aas',
- email => 'gisle@aas.no',
- gender => 'M',
- born => '1964',
- init => ["$ENV{HOME}/.profile"],
- ]
-
-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):
-
- POST http://www.perl.org/survey.cgi
- Content-Length: 388
- Content-Type: multipart/form-data; boundary="6G+f"
-
- --6G+f
- Content-Disposition: form-data; name="name"
-
- Gisle Aas
- --6G+f
- Content-Disposition: form-data; name="email"
-
- gisle@aas.no
- --6G+f
- Content-Disposition: form-data; name="gender"
-
- M
- --6G+f
- Content-Disposition: form-data; name="born"
-
- 1964
- --6G+f
- Content-Disposition: form-data; name="init"; filename=".profile"
- Content-Type: text/plain
-
- PATH=/local/perl/bin:$PATH
- export PATH
-
- --6G+f--
-
-If you set the $DYNAMIC_FILE_UPLOAD variable (exportable) to some TRUE
-value, then you get back a request object with a subroutine closure as
-the content attribute. This subroutine will read the content of any
-files on demand and return it in suitable chunks. This allow you to
-upload arbitrary big files without using lots of memory. You can even
-upload infinite files like F</dev/audio> if you wish; however, if
-the file is not a plain file, there will be no Content-Length header
-defined for the request. Not all servers (or server
-applications) like this. Also, if the file(s) change in size between
-the time the Content-Length is calculated and the time that the last
-chunk is delivered, the subroutine will C<Croak>.
-
-The post(...) method of "LWP::UserAgent" exists as a shortcut for
-$ua->request(POST ...).
-
-=back
-
-=head1 SEE ALSO
-
-L<HTTP::Request>, L<LWP::UserAgent>
-
-
-=head1 COPYRIGHT
-
-Copyright 1997-2004, Gisle Aas
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=cut
-
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Response.pm b/Master/tlpkg/tlperl/lib/HTTP/Response.pm
deleted file mode 100644
index c5250560528..00000000000
--- a/Master/tlpkg/tlperl/lib/HTTP/Response.pm
+++ /dev/null
@@ -1,637 +0,0 @@
-package HTTP::Response;
-
-require HTTP::Message;
-@ISA = qw(HTTP::Message);
-$VERSION = "6.04";
-
-use strict;
-use HTTP::Status ();
-
-
-
-sub new
-{
- my($class, $rc, $msg, $header, $content) = @_;
- my $self = $class->SUPER::new($header, $content);
- $self->code($rc);
- $self->message($msg);
- $self;
-}
-
-
-sub parse
-{
- my($class, $str) = @_;
- my $status_line;
- if ($str =~ s/^(.*)\n//) {
- $status_line = $1;
- }
- else {
- $status_line = $str;
- $str = "";
- }
-
- my $self = $class->SUPER::parse($str);
- my($protocol, $code, $message);
- if ($status_line =~ /^\d{3} /) {
- # Looks like a response created by HTTP::Response->new
- ($code, $message) = split(' ', $status_line, 2);
- } else {
- ($protocol, $code, $message) = split(' ', $status_line, 3);
- }
- $self->protocol($protocol) if $protocol;
- $self->code($code) if defined($code);
- $self->message($message) if defined($message);
- $self;
-}
-
-
-sub clone
-{
- my $self = shift;
- my $clone = bless $self->SUPER::clone, ref($self);
- $clone->code($self->code);
- $clone->message($self->message);
- $clone->request($self->request->clone) if $self->request;
- # we don't clone previous
- $clone;
-}
-
-
-sub code { shift->_elem('_rc', @_); }
-sub message { shift->_elem('_msg', @_); }
-sub previous { shift->_elem('_previous',@_); }
-sub request { shift->_elem('_request', @_); }
-
-
-sub status_line
-{
- my $self = shift;
- my $code = $self->{'_rc'} || "000";
- my $mess = $self->{'_msg'} || HTTP::Status::status_message($code) || "Unknown code";
- return "$code $mess";
-}
-
-
-sub base
-{
- my $self = shift;
- my $base = (
- $self->header('Content-Base'), # used to be HTTP/1.1
- $self->header('Content-Location'), # HTTP/1.1
- $self->header('Base'), # HTTP/1.0
- )[0];
- if ($base && $base =~ /^$URI::scheme_re:/o) {
- # already absolute
- return $HTTP::URI_CLASS->new($base);
- }
-
- my $req = $self->request;
- if ($req) {
- # if $base is undef here, the return value is effectively
- # just a copy of $self->request->uri.
- return $HTTP::URI_CLASS->new_abs($base, $req->uri);
- }
-
- # can't find an absolute base
- return undef;
-}
-
-
-sub redirects {
- my $self = shift;
- my @r;
- my $r = $self;
- while (my $p = $r->previous) {
- push(@r, $p);
- $r = $p;
- }
- return @r unless wantarray;
- return reverse @r;
-}
-
-
-sub filename
-{
- my $self = shift;
- my $file;
-
- my $cd = $self->header('Content-Disposition');
- if ($cd) {
- require HTTP::Headers::Util;
- if (my @cd = HTTP::Headers::Util::split_header_words($cd)) {
- my ($disposition, undef, %cd_param) = @{$cd[-1]};
- $file = $cd_param{filename};
-
- # RFC 2047 encoded?
- if ($file && $file =~ /^=\?(.+?)\?(.+?)\?(.+)\?=$/) {
- my $charset = $1;
- my $encoding = uc($2);
- my $encfile = $3;
-
- if ($encoding eq 'Q' || $encoding eq 'B') {
- local($SIG{__DIE__});
- eval {
- if ($encoding eq 'Q') {
- $encfile =~ s/_/ /g;
- require MIME::QuotedPrint;
- $encfile = MIME::QuotedPrint::decode($encfile);
- }
- else { # $encoding eq 'B'
- require MIME::Base64;
- $encfile = MIME::Base64::decode($encfile);
- }
-
- require Encode;
- require Encode::Locale;
- Encode::from_to($encfile, $charset, "locale_fs");
- };
-
- $file = $encfile unless $@;
- }
- }
- }
- }
-
- unless (defined($file) && length($file)) {
- my $uri;
- if (my $cl = $self->header('Content-Location')) {
- $uri = URI->new($cl);
- }
- elsif (my $request = $self->request) {
- $uri = $request->uri;
- }
-
- if ($uri) {
- $file = ($uri->path_segments)[-1];
- }
- }
-
- if ($file) {
- $file =~ s,.*[\\/],,; # basename
- }
-
- if ($file && !length($file)) {
- $file = undef;
- }
-
- $file;
-}
-
-
-sub as_string
-{
- my $self = shift;
- my($eol) = @_;
- $eol = "\n" unless defined $eol;
-
- my $status_line = $self->status_line;
- my $proto = $self->protocol;
- $status_line = "$proto $status_line" if $proto;
-
- return join($eol, $status_line, $self->SUPER::as_string(@_));
-}
-
-
-sub dump
-{
- my $self = shift;
-
- my $status_line = $self->status_line;
- my $proto = $self->protocol;
- $status_line = "$proto $status_line" if $proto;
-
- return $self->SUPER::dump(
- preheader => $status_line,
- @_,
- );
-}
-
-
-sub is_info { HTTP::Status::is_info (shift->{'_rc'}); }
-sub is_success { HTTP::Status::is_success (shift->{'_rc'}); }
-sub is_redirect { HTTP::Status::is_redirect (shift->{'_rc'}); }
-sub is_error { HTTP::Status::is_error (shift->{'_rc'}); }
-
-
-sub error_as_HTML
-{
- my $self = shift;
- my $title = 'An Error Occurred';
- my $body = $self->status_line;
- $body =~ s/&/&amp;/g;
- $body =~ s/</&lt;/g;
- return <<EOM;
-<html>
-<head><title>$title</title></head>
-<body>
-<h1>$title</h1>
-<p>$body</p>
-</body>
-</html>
-EOM
-}
-
-
-sub current_age
-{
- my $self = shift;
- my $time = shift;
-
- # Implementation of RFC 2616 section 13.2.3
- # (age calculations)
- my $response_time = $self->client_date;
- my $date = $self->date;
-
- my $age = 0;
- if ($response_time && $date) {
- $age = $response_time - $date; # apparent_age
- $age = 0 if $age < 0;
- }
-
- my $age_v = $self->header('Age');
- if ($age_v && $age_v > $age) {
- $age = $age_v; # corrected_received_age
- }
-
- if ($response_time) {
- my $request = $self->request;
- if ($request) {
- my $request_time = $request->date;
- if ($request_time && $request_time < $response_time) {
- # Add response_delay to age to get 'corrected_initial_age'
- $age += $response_time - $request_time;
- }
- }
- $age += ($time || time) - $response_time;
- }
- return $age;
-}
-
-
-sub freshness_lifetime
-{
- my($self, %opt) = @_;
-
- # First look for the Cache-Control: max-age=n header
- for my $cc ($self->header('Cache-Control')) {
- for my $cc_dir (split(/\s*,\s*/, $cc)) {
- return $1 if $cc_dir =~ /^max-age\s*=\s*(\d+)/i;
- }
- }
-
- # Next possibility is to look at the "Expires" header
- my $date = $self->date || $self->client_date || $opt{time} || time;
- if (my $expires = $self->expires) {
- return $expires - $date;
- }
-
- # Must apply heuristic expiration
- return undef if exists $opt{heuristic_expiry} && !$opt{heuristic_expiry};
-
- # Default heuristic expiration parameters
- $opt{h_min} ||= 60;
- $opt{h_max} ||= 24 * 3600;
- $opt{h_lastmod_fraction} ||= 0.10; # 10% since last-mod suggested by RFC2616
- $opt{h_default} ||= 3600;
-
- # Should give a warning if more than 24 hours according to
- # RFC 2616 section 13.2.4. Here we just make this the default
- # maximum value.
-
- if (my $last_modified = $self->last_modified) {
- my $h_exp = ($date - $last_modified) * $opt{h_lastmod_fraction};
- return $opt{h_min} if $h_exp < $opt{h_min};
- return $opt{h_max} if $h_exp > $opt{h_max};
- return $h_exp;
- }
-
- # default when all else fails
- return $opt{h_min} if $opt{h_min} > $opt{h_default};
- return $opt{h_default};
-}
-
-
-sub is_fresh
-{
- my($self, %opt) = @_;
- $opt{time} ||= time;
- my $f = $self->freshness_lifetime(%opt);
- return undef unless defined($f);
- return $f > $self->current_age($opt{time});
-}
-
-
-sub fresh_until
-{
- my($self, %opt) = @_;
- $opt{time} ||= time;
- my $f = $self->freshness_lifetime(%opt);
- return undef unless defined($f);
- return $f - $self->current_age($opt{time}) + $opt{time};
-}
-
-1;
-
-
-__END__
-
-=head1 NAME
-
-HTTP::Response - HTTP style response message
-
-=head1 SYNOPSIS
-
-Response objects are returned by the request() method of the C<LWP::UserAgent>:
-
- # ...
- $response = $ua->request($request)
- if ($response->is_success) {
- print $response->decoded_content;
- }
- else {
- print STDERR $response->status_line, "\n";
- }
-
-=head1 DESCRIPTION
-
-The C<HTTP::Response> class encapsulates HTTP style responses. A
-response consists of a response line, some headers, and a content
-body. Note that the LWP library uses HTTP style responses even for
-non-HTTP protocol schemes. Instances of this class are usually
-created and returned by the request() method of an C<LWP::UserAgent>
-object.
-
-C<HTTP::Response> is a subclass of C<HTTP::Message> and therefore
-inherits its methods. The following additional methods are available:
-
-=over 4
-
-=item $r = HTTP::Response->new( $code )
-
-=item $r = HTTP::Response->new( $code, $msg )
-
-=item $r = HTTP::Response->new( $code, $msg, $header )
-
-=item $r = HTTP::Response->new( $code, $msg, $header, $content )
-
-Constructs a new C<HTTP::Response> object describing a response with
-response code $code and optional message $msg. The optional $header
-argument should be a reference to an C<HTTP::Headers> object or a
-plain array reference of key/value pairs. The optional $content
-argument should be a string of bytes. The meanings of these arguments are
-described below.
-
-=item $r = HTTP::Response->parse( $str )
-
-This constructs a new response object by parsing the given string.
-
-=item $r->code
-
-=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 an HTTP response. The
-C<HTTP::Status> module provide constants that provide mnemonic names
-for the code attribute.
-
-=item $r->message
-
-=item $r->message( $message )
-
-This is used to get/set the message attribute. The message is a short
-human readable single line string that explains the response code.
-
-=item $r->header( $field )
-
-=item $r->header( $field => $value )
-
-This is used to get/set header values and it is inherited from
-C<HTTP::Headers> via C<HTTP::Message>. See L<HTTP::Headers> for
-details and other similar methods that can be used to access the
-headers.
-
-=item $r->content
-
-=item $r->content( $bytes )
-
-This is used to get/set the raw content and it is inherited from the
-C<HTTP::Message> base class. See L<HTTP::Message> for details and
-other methods that can be used to access the content.
-
-=item $r->decoded_content( %options )
-
-This will return the content after any C<Content-Encoding> and
-charsets have been decoded. See L<HTTP::Message> for details.
-
-=item $r->request
-
-=item $r->request( $request )
-
-This is used to get/set the request attribute. The request attribute
-is a reference to the the request that caused this response. It does
-not have to be the same request passed to the $ua->request() method,
-because there might have been redirects and authorization retries in
-between.
-
-=item $r->previous
-
-=item $r->previous( $response )
-
-This is used to get/set the previous attribute. The previous
-attribute is used to link together chains of responses. You get
-chains of responses if the first response is redirect or unauthorized.
-The value is C<undef> if this is the first response in a chain.
-
-Note that the method $r->redirects is provided as a more convenient
-way to access the response chain.
-
-=item $r->status_line
-
-Returns the string "E<lt>code> E<lt>message>". If the message attribute
-is not set then the official name of E<lt>code> (see L<HTTP::Status>)
-is substituted.
-
-=item $r->base
-
-Returns the base URI for this response. The return value will be a
-reference to a URI object.
-
-The base URI is obtained from one the following sources (in priority
-order):
-
-=over 4
-
-=item 1.
-
-Embedded in the document content, for instance <BASE HREF="...">
-in HTML documents.
-
-=item 2.
-
-A "Content-Base:" or a "Content-Location:" header in the response.
-
-For backwards compatibility with older HTTP implementations we will
-also look for the "Base:" header.
-
-=item 3.
-
-The URI used to request this response. This might not be the original
-URI that was passed to $ua->request() method, because we might have
-received some redirect responses first.
-
-=back
-
-If none of these sources provide an absolute URI, undef is returned.
-
-When the LWP protocol modules produce the HTTP::Response object, then
-any base URI embedded in the document (step 1) will already have
-initialized the "Content-Base:" header. This means that this method
-only performs the last 2 steps (the content is not always available
-either).
-
-=item $r->filename
-
-Returns a filename for this response. Note that doing sanity checks
-on the returned filename (eg. removing characters that cannot be used
-on the target filesystem where the filename would be used, and
-laundering it for security purposes) are the caller's responsibility;
-the only related thing done by this method is that it makes a simple
-attempt to return a plain filename with no preceding path segments.
-
-The filename is obtained from one the following sources (in priority
-order):
-
-=over 4
-
-=item 1.
-
-A "Content-Disposition:" header in the response. Proper decoding of
-RFC 2047 encoded filenames requires the C<MIME::QuotedPrint> (for "Q"
-encoding), C<MIME::Base64> (for "B" encoding), and C<Encode> modules.
-
-=item 2.
-
-A "Content-Location:" header in the response.
-
-=item 3.
-
-The URI used to request this response. This might not be the original
-URI that was passed to $ua->request() method, because we might have
-received some redirect responses first.
-
-=back
-
-If a filename cannot be derived from any of these sources, undef is
-returned.
-
-=item $r->as_string
-
-=item $r->as_string( $eol )
-
-Returns a textual representation of the response.
-
-=item $r->is_info
-
-=item $r->is_success
-
-=item $r->is_redirect
-
-=item $r->is_error
-
-These methods indicate if the response was informational, successful, a
-redirection, or an error. See L<HTTP::Status> for the meaning of these.
-
-=item $r->error_as_HTML
-
-Returns a string containing a complete HTML document indicating what
-error occurred. This method should only be called when $r->is_error
-is TRUE.
-
-=item $r->redirects
-
-Returns the list of redirect responses that lead up to this response
-by following the $r->previous chain. The list order is oldest first.
-
-In scalar context return the number of redirect responses leading up
-to this one.
-
-=item $r->current_age
-
-Calculates the "current age" of the response as specified by RFC 2616
-section 13.2.3. The age of a response is the time since it was sent
-by the origin server. The returned value is a number representing the
-age in seconds.
-
-=item $r->freshness_lifetime( %opt )
-
-Calculates the "freshness lifetime" of the response as specified by
-RFC 2616 section 13.2.4. The "freshness lifetime" is the length of
-time between the generation of a response and its expiration time.
-The returned value is the number of seconds until expiry.
-
-If the response does not contain an "Expires" or a "Cache-Control"
-header, then this function will apply some simple heuristic based on
-the "Last-Modified" header to determine a suitable lifetime. The
-following options might be passed to control the heuristics:
-
-=over
-
-=item heuristic_expiry => $bool
-
-If passed as a FALSE value, don't apply heuristics and just return
-C<undef> when "Expires" or "Cache-Control" is lacking.
-
-=item h_lastmod_fraction => $num
-
-This number represent the fraction of the difference since the
-"Last-Modified" timestamp to make the expiry time. The default is
-C<0.10>, the suggested typical setting of 10% in RFC 2616.
-
-=item h_min => $sec
-
-This is the lower limit of the heuristic expiry age to use. The
-default is C<60> (1 minute).
-
-=item h_max => $sec
-
-This is the upper limit of the heuristic expiry age to use. The
-default is C<86400> (24 hours).
-
-=item h_default => $sec
-
-This is the expiry age to use when nothing else applies. The default
-is C<3600> (1 hour) or "h_min" if greater.
-
-=back
-
-=item $r->is_fresh( %opt )
-
-Returns TRUE if the response is fresh, based on the values of
-freshness_lifetime() and current_age(). If the response is no longer
-fresh, then it has to be re-fetched or re-validated by the origin
-server.
-
-Options might be passed to control expiry heuristics, see the
-description of freshness_lifetime().
-
-=item $r->fresh_until( %opt )
-
-Returns the time (seconds since epoch) when this entity is no longer fresh.
-
-Options might be passed to control expiry heuristics, see the
-description of freshness_lifetime().
-
-=back
-
-=head1 SEE ALSO
-
-L<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Status>, L<HTTP::Request>
-
-=head1 COPYRIGHT
-
-Copyright 1995-2004 Gisle Aas.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
diff --git a/Master/tlpkg/tlperl/lib/HTTP/Status.pm b/Master/tlpkg/tlperl/lib/HTTP/Status.pm
deleted file mode 100644
index f229af6c226..00000000000
--- a/Master/tlpkg/tlperl/lib/HTTP/Status.pm
+++ /dev/null
@@ -1,267 +0,0 @@
-package HTTP::Status;
-
-use strict;
-require 5.002; # because we use prototypes
-
-use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
-
-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 = "6.03";
-
-# Note also addition of mnemonics to @EXPORT below
-
-# Unmarked codes are from RFC 2616
-# See also: http://en.wikipedia.org/wiki/List_of_HTTP_status_codes
-
-my %StatusCode = (
- 100 => 'Continue',
- 101 => 'Switching Protocols',
- 102 => 'Processing', # RFC 2518 (WebDAV)
- 200 => 'OK',
- 201 => 'Created',
- 202 => 'Accepted',
- 203 => 'Non-Authoritative Information',
- 204 => 'No Content',
- 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',
- 303 => 'See Other',
- 304 => 'Not Modified',
- 305 => 'Use Proxy',
- 307 => 'Temporary Redirect',
- 400 => 'Bad Request',
- 401 => 'Unauthorized',
- 402 => 'Payment Required',
- 403 => 'Forbidden',
- 404 => 'Not Found',
- 405 => 'Method Not Allowed',
- 406 => 'Not Acceptable',
- 407 => 'Proxy Authentication Required',
- 408 => 'Request Timeout',
- 409 => 'Conflict',
- 410 => 'Gone',
- 411 => 'Length Required',
- 412 => 'Precondition Failed',
- 413 => 'Request Entity Too Large',
- 414 => 'Request-URI Too Large',
- 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',
- 502 => 'Bad Gateway',
- 503 => 'Service Unavailable',
- 504 => 'Gateway Timeout',
- 505 => 'HTTP Version Not Supported',
- 506 => 'Variant Also Negotiates', # RFC 2295
- 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
- $mnemonicCode .= "push(\@EXPORT_OK, 'HTTP_$message');\n";
- $mnemonicCode .= "push(\@EXPORT, 'RC_$message');\n";
-}
-eval $mnemonicCode; # only one eval for speed
-die if $@;
-
-# backwards compatibility
-*RC_MOVED_TEMPORARILY = \&RC_FOUND; # 302 was renamed in the standard
-push(@EXPORT, "RC_MOVED_TEMPORARILY");
-
-%EXPORT_TAGS = (
- constants => [grep /^HTTP_/, @EXPORT_OK],
- is => [grep /^is_/, @EXPORT, @EXPORT_OK],
-);
-
-
-sub status_message ($) { $StatusCode{$_[0]}; }
-
-sub is_info ($) { $_[0] >= 100 && $_[0] < 200; }
-sub is_success ($) { $_[0] >= 200 && $_[0] < 300; }
-sub is_redirect ($) { $_[0] >= 300 && $_[0] < 400; }
-sub is_error ($) { $_[0] >= 400 && $_[0] < 600; }
-sub is_client_error ($) { $_[0] >= 400 && $_[0] < 500; }
-sub is_server_error ($) { $_[0] >= 500 && $_[0] < 600; }
-
-1;
-
-
-__END__
-
-=head1 NAME
-
-HTTP::Status - HTTP Status code processing
-
-=head1 SYNOPSIS
-
- use HTTP::Status qw(:constants :is status_message);
-
- if ($rc != HTTP_OK) {
- print status_message($rc), "\n";
- }
-
- if (is_success($rc)) { ... }
- if (is_error($rc)) { ... }
- if (is_redirect($rc)) { ... }
-
-=head1 DESCRIPTION
-
-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 an HTTP response message. Codes
-correspond to those defined in RFC 2616 and RFC 2518.
-
-=head1 CONSTANTS
-
-The following constant functions can be used as mnemonic status code
-names. None of these are exported by default. Use the C<:constants>
-tag to import them all.
-
- HTTP_CONTINUE (100)
- HTTP_SWITCHING_PROTOCOLS (101)
- HTTP_PROCESSING (102)
-
- HTTP_OK (200)
- HTTP_CREATED (201)
- HTTP_ACCEPTED (202)
- HTTP_NON_AUTHORITATIVE_INFORMATION (203)
- HTTP_NO_CONTENT (204)
- HTTP_RESET_CONTENT (205)
- HTTP_PARTIAL_CONTENT (206)
- HTTP_MULTI_STATUS (207)
- HTTP_ALREADY_REPORTED (208)
-
- HTTP_MULTIPLE_CHOICES (300)
- HTTP_MOVED_PERMANENTLY (301)
- HTTP_FOUND (302)
- HTTP_SEE_OTHER (303)
- HTTP_NOT_MODIFIED (304)
- HTTP_USE_PROXY (305)
- HTTP_TEMPORARY_REDIRECT (307)
-
- HTTP_BAD_REQUEST (400)
- HTTP_UNAUTHORIZED (401)
- HTTP_PAYMENT_REQUIRED (402)
- HTTP_FORBIDDEN (403)
- HTTP_NOT_FOUND (404)
- HTTP_METHOD_NOT_ALLOWED (405)
- HTTP_NOT_ACCEPTABLE (406)
- HTTP_PROXY_AUTHENTICATION_REQUIRED (407)
- HTTP_REQUEST_TIMEOUT (408)
- HTTP_CONFLICT (409)
- HTTP_GONE (410)
- HTTP_LENGTH_REQUIRED (411)
- HTTP_PRECONDITION_FAILED (412)
- HTTP_REQUEST_ENTITY_TOO_LARGE (413)
- HTTP_REQUEST_URI_TOO_LARGE (414)
- 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)
- HTTP_NOT_IMPLEMENTED (501)
- HTTP_BAD_GATEWAY (502)
- HTTP_SERVICE_UNAVAILABLE (503)
- HTTP_GATEWAY_TIMEOUT (504)
- HTTP_HTTP_VERSION_NOT_SUPPORTED (505)
- HTTP_VARIANT_ALSO_NEGOTIATES (506)
- HTTP_INSUFFICIENT_STORAGE (507)
- HTTP_BANDWIDTH_LIMIT_EXCEEDED (509)
- HTTP_NOT_EXTENDED (510)
- HTTP_NETWORK_AUTHENTICATION_REQUIRED (511)
-
-=head1 FUNCTIONS
-
-The following additional functions are provided. Most of them are
-exported by default. The C<:is> import tag can be used to import all
-the classification functions.
-
-=over 4
-
-=item status_message( $code )
-
-The status_message() function will translate status codes to human
-readable strings. The string is the same as found in the constant
-names above. If the $code is unknown, then C<undef> is returned.
-
-=item is_info( $code )
-
-Return TRUE if C<$code> is an I<Informational> status code (1xx). This
-class of status code indicates a provisional response which can't have
-any content.
-
-=item is_success( $code )
-
-Return TRUE if C<$code> is a I<Successful> status code (2xx).
-
-=item is_redirect( $code )
-
-Return TRUE if C<$code> is a I<Redirection> status code (3xx). This class of
-status code indicates that further action needs to be taken by the
-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
-returns TRUE for both client and server error status codes.
-
-=item is_client_error( $code )
-
-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.
-
-This function is B<not> exported by default.
-
-=item is_server_error( $code )
-
-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.
-
-This function is B<not> exported by default.
-
-=back
-
-=head1 BUGS
-
-For legacy reasons all the C<HTTP_> constants are exported by default
-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
index e348753b933..878cce89d8f 100644
--- a/Master/tlpkg/tlperl/lib/HTTP/Tiny.pm
+++ b/Master/tlpkg/tlperl/lib/HTTP/Tiny.pm
@@ -3,60 +3,64 @@ package HTTP::Tiny;
use strict;
use warnings;
# ABSTRACT: A small, simple, correct HTTP/1.1 client
-our $VERSION = '0.043'; # VERSION
+
+our $VERSION = '0.054';
use Carp ();
-# =method new
-#
-# $http = HTTP::Tiny->new( %attributes );
-#
-# This constructor returns a new HTTP::Tiny object. Valid attributes include:
-#
-# =for :list
-# * C<agent>
-# A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If C<agent> ends in a space character, the default user-agent string is appended.
-# * C<cookie_jar>
-# An instance of L<HTTP::CookieJar> or equivalent class that supports the C<add> and C<cookie_header> methods
-# * C<default_headers>
-# A hashref of default headers to apply to requests
-# * C<local_address>
-# The local IP address to bind to
-# * C<keep_alive>
-# Whether to reuse the last connection (if for the same scheme, host and port) (defaults to 1)
-# * C<max_redirect>
-# Maximum number of redirects allowed (defaults to 5)
-# * C<max_size>
-# Maximum response size (only when not using a data callback). If defined, responses larger than this will return an exception.
-# * C<http_proxy>
-# URL of a proxy server to use for HTTP connections (default is C<$ENV{http_proxy}> if set)
-# * C<https_proxy>
-# URL of a proxy server to use for HTTPS connections (default is C<$ENV{https_proxy}> if set)
-# * C<proxy>
-# URL of a generic proxy server for both HTTP and HTTPS connections (default is C<$ENV{all_proxy}> if set)
-# * C<no_proxy>
-# List of domain suffixes that should not be proxied. Must be a comma-separated string or an array reference. (default is C<$ENV{no_proxy}>)
-# * C<timeout>
-# Request timeout in seconds (default is 60)
-# * C<verify_SSL>
-# A boolean that indicates whether to validate the SSL certificate of an C<https>
-# connection (default is false)
-# * C<SSL_options>
-# A hashref of C<SSL_*> options to pass through to L<IO::Socket::SSL>
-#
-# Exceptions from C<max_size>, C<timeout> or other errors will result in a
-# pseudo-HTTP status code of 599 and a reason of "Internal Exception". The
-# content field in the response will contain the text of the exception.
-#
-# The C<keep_alive> parameter enables a persistent connection, but only to a
-# single destination scheme, host and port. Also, if any connection-relevant
-# attributes are modified, a persistent connection will be dropped. If you want
-# persistent connections across multiple destinations, use multiple HTTP::Tiny
-# objects.
-#
-# See L</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes.
-#
-# =cut
+#pod =method new
+#pod
+#pod $http = HTTP::Tiny->new( %attributes );
+#pod
+#pod This constructor returns a new HTTP::Tiny object. Valid attributes include:
+#pod
+#pod =for :list
+#pod * C<agent> —
+#pod A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If C<agent> — ends in a space character, the default user-agent string is appended.
+#pod * C<cookie_jar> —
+#pod An instance of L<HTTP::CookieJar> — or equivalent class that supports the C<add> and C<cookie_header> methods
+#pod * C<default_headers> —
+#pod A hashref of default headers to apply to requests
+#pod * C<local_address> —
+#pod The local IP address to bind to
+#pod * C<keep_alive> —
+#pod Whether to reuse the last connection (if for the same scheme, host and port) (defaults to 1)
+#pod * C<max_redirect> —
+#pod Maximum number of redirects allowed (defaults to 5)
+#pod * C<max_size> —
+#pod Maximum response size (only when not using a data callback). If defined, responses larger than this will return an exception.
+#pod * C<http_proxy> —
+#pod URL of a proxy server to use for HTTP connections (default is C<$ENV{http_proxy}> — if set)
+#pod * C<https_proxy> —
+#pod URL of a proxy server to use for HTTPS connections (default is C<$ENV{https_proxy}> — if set)
+#pod * C<proxy> —
+#pod URL of a generic proxy server for both HTTP and HTTPS connections (default is C<$ENV{all_proxy}> — if set)
+#pod * C<no_proxy> —
+#pod List of domain suffixes that should not be proxied. Must be a comma-separated string or an array reference. (default is C<$ENV{no_proxy}> —)
+#pod * C<timeout> —
+#pod Request timeout in seconds (default is 60)
+#pod * C<verify_SSL> —
+#pod A boolean that indicates whether to validate the SSL certificate of an C<https> —
+#pod connection (default is false)
+#pod * C<SSL_options> —
+#pod A hashref of C<SSL_*> — options to pass through to L<IO::Socket::SSL>
+#pod
+#pod Passing an explicit C<undef> for C<proxy>, C<http_proxy> or C<https_proxy> will
+#pod prevent getting the corresponding proxies from the environment.
+#pod
+#pod Exceptions from C<max_size>, C<timeout> or other errors will result in a
+#pod pseudo-HTTP status code of 599 and a reason of "Internal Exception". The
+#pod content field in the response will contain the text of the exception.
+#pod
+#pod The C<keep_alive> parameter enables a persistent connection, but only to a
+#pod single destination scheme, host and port. Also, if any connection-relevant
+#pod attributes are modified, or if the process ID or thread ID change, the
+#pod persistent connection will be dropped. If you want persistent connections
+#pod across multiple destinations, use multiple HTTP::Tiny objects.
+#pod
+#pod See L</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes.
+#pod
+#pod =cut
my @attributes;
BEGIN {
@@ -120,36 +124,47 @@ sub new {
sub _set_proxies {
my ($self) = @_;
- if (! $self->{proxy} ) {
+ # get proxies from %ENV only if not provided; explicit undef will disable
+ # getting proxies from the environment
+
+ # generic proxy
+ if (! exists $self->{proxy} ) {
$self->{proxy} = $ENV{all_proxy} || $ENV{ALL_PROXY};
- if ( defined $self->{proxy} ) {
- $self->_split_proxy( 'generic proxy' => $self->{proxy} ); # validate
- }
- else {
- delete $self->{proxy};
- }
}
- if (! $self->{http_proxy} ) {
- $self->{http_proxy} = $ENV{http_proxy} || $self->{proxy};
- if ( defined $self->{http_proxy} ) {
- $self->_split_proxy( http_proxy => $self->{http_proxy} ); # validate
- $self->{_has_proxy}{http} = 1;
- }
- else {
- delete $self->{http_proxy};
- }
+ if ( defined $self->{proxy} ) {
+ $self->_split_proxy( 'generic proxy' => $self->{proxy} ); # validate
+ }
+ else {
+ delete $self->{proxy};
}
- if (! $self->{https_proxy} ) {
+ # http proxy
+ if (! exists $self->{http_proxy} ) {
+ # under CGI, bypass HTTP_PROXY as request sets it from Proxy header
+ local $ENV{HTTP_PROXY} if $ENV{REQUEST_METHOD};
+ $self->{http_proxy} = $ENV{http_proxy} || $ENV{HTTP_PROXY} || $self->{proxy};
+ }
+
+ if ( defined $self->{http_proxy} ) {
+ $self->_split_proxy( http_proxy => $self->{http_proxy} ); # validate
+ $self->{_has_proxy}{http} = 1;
+ }
+ else {
+ delete $self->{http_proxy};
+ }
+
+ # https proxy
+ if (! exists $self->{https_proxy} ) {
$self->{https_proxy} = $ENV{https_proxy} || $ENV{HTTPS_PROXY} || $self->{proxy};
- if ( $self->{https_proxy} ) {
- $self->_split_proxy( https_proxy => $self->{https_proxy} ); # validate
- $self->{_has_proxy}{https} = 1;
- }
- else {
- delete $self->{https_proxy};
- }
+ }
+
+ if ( $self->{https_proxy} ) {
+ $self->_split_proxy( https_proxy => $self->{https_proxy} ); # validate
+ $self->{_has_proxy}{https} = 1;
+ }
+ else {
+ delete $self->{https_proxy};
}
# Split no_proxy to array reference if not provided as such
@@ -161,19 +176,19 @@ sub _set_proxies {
return;
}
-# =method get|head|put|post|delete
-#
-# $response = $http->get($url);
-# $response = $http->get($url, \%options);
-# $response = $http->head($url);
-#
-# These methods are shorthand for calling C<request()> for the given method. The
-# URL must have unsafe characters escaped and international domain names encoded.
-# See C<request()> for valid options and a description of the response.
-#
-# The C<success> field of the response will be true if the status code is 2XX.
-#
-# =cut
+#pod =method get|head|put|post|delete
+#pod
+#pod $response = $http->get($url);
+#pod $response = $http->get($url, \%options);
+#pod $response = $http->head($url);
+#pod
+#pod These methods are shorthand for calling C<request()> for the given method. The
+#pod URL must have unsafe characters escaped and international domain names encoded.
+#pod See C<request()> for valid options and a description of the response.
+#pod
+#pod The C<success> field of the response will be true if the status code is 2XX.
+#pod
+#pod =cut
for my $sub_name ( qw/get head put post delete/ ) {
my $req_method = uc $sub_name;
@@ -188,25 +203,25 @@ for my $sub_name ( qw/get head put post delete/ ) {
HERE
}
-# =method post_form
-#
-# $response = $http->post_form($url, $form_data);
-# $response = $http->post_form($url, $form_data, \%options);
-#
-# This method executes a C<POST> request and sends the key/value pairs from a
-# form data hash or array reference to the given URL with a C<content-type> of
-# C<application/x-www-form-urlencoded>. If data is provided as an array
-# reference, the order is preserved; if provided as a hash reference, the terms
-# are sorted on key and value for consistency. See documentation for the
-# C<www_form_urlencode> method for details on the encoding.
-#
-# The URL must have unsafe characters escaped and international domain names
-# encoded. See C<request()> for valid options and a description of the response.
-# Any C<content-type> header or content in the options hashref will be ignored.
-#
-# The C<success> field of the response will be true if the status code is 2XX.
-#
-# =cut
+#pod =method post_form
+#pod
+#pod $response = $http->post_form($url, $form_data);
+#pod $response = $http->post_form($url, $form_data, \%options);
+#pod
+#pod This method executes a C<POST> request and sends the key/value pairs from a
+#pod form data hash or array reference to the given URL with a C<content-type> of
+#pod C<application/x-www-form-urlencoded>. If data is provided as an array
+#pod reference, the order is preserved; if provided as a hash reference, the terms
+#pod are sorted on key and value for consistency. See documentation for the
+#pod C<www_form_urlencode> method for details on the encoding.
+#pod
+#pod The URL must have unsafe characters escaped and international domain names
+#pod encoded. See C<request()> for valid options and a description of the response.
+#pod Any C<content-type> header or content in the options hashref will be ignored.
+#pod
+#pod The C<success> field of the response will be true if the status code is 2XX.
+#pod
+#pod =cut
sub post_form {
my ($self, $url, $data, $args) = @_;
@@ -230,28 +245,28 @@ sub post_form {
);
}
-# =method 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 include an
-# C<If-Modified-Since> header with the modification timestamp of the file. You
-# may specify a different C<If-Modified-Since> header yourself in the C<<
-# $options->{headers} >> hash.
-#
-# The C<success> field of the response will be true if the status code is 2XX
-# or if the status code is 304 (unmodified).
-#
-# If the file was modified and the server response includes a properly
-# formatted C<Last-Modified> header, the file modification time will
-# be updated accordingly.
-#
-# =cut
+#pod =method mirror
+#pod
+#pod $response = $http->mirror($url, $file, \%options)
+#pod if ( $response->{success} ) {
+#pod print "$file is up to date\n";
+#pod }
+#pod
+#pod Executes a C<GET> request for the URL and saves the response body to the file
+#pod name provided. The URL must have unsafe characters escaped and international
+#pod domain names encoded. If the file already exists, the request will include an
+#pod C<If-Modified-Since> header with the modification timestamp of the file. You
+#pod may specify a different C<If-Modified-Since> header yourself in the C<<
+#pod $options->{headers} >> hash.
+#pod
+#pod The C<success> field of the response will be true if the status code is 2XX
+#pod or if the status code is 304 (unmodified).
+#pod
+#pod If the file was modified and the server response includes a properly
+#pod formatted C<Last-Modified> header, the file modification time will
+#pod be updated accordingly.
+#pod
+#pod =cut
sub mirror {
my ($self, $url, $file, $args) = @_;
@@ -284,86 +299,90 @@ sub mirror {
return $response;
}
-# =method 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.
-#
-# If the URL includes a "user:password" stanza, they will be used for Basic-style
-# authorization headers. (Authorization headers will not be included in a
-# redirected request.) For example:
-#
-# $http->request('GET', 'http://Aladdin:open sesame@example.com/');
-#
-# If the "user:password" stanza contains reserved characters, they must
-# be percent-escaped:
-#
-# $http->request('GET', 'http://john%40example.com:password@example.com/');
-#
-# A hashref of options may be appended to modify the request.
-#
-# Valid options are:
-#
-# =for :list
-# * C<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.
-# * C<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 request
-# * C<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)
-# * C<data_callback>
-# A code reference that will be called for each chunks of the response
-# body received.
-#
-# 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<content> option is the empty string, no C<content-type> or
-# C<content-length> headers will be generated.
-#
-# 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:
-#
-# =for :list
-# * C<success>
-# Boolean indicating whether the operation returned a 2XX status code
-# * C<url>
-# URL that provided the response. This is the URL of the request unless
-# there were redirections, in which case it is the last URL queried
-# in a redirection chain
-# * C<status>
-# The HTTP status code of the response
-# * C<reason>
-# The response phrase returned by the server
-# * C<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
-# * C<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
-#
-# 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.
-#
-# =cut
+#pod =method request
+#pod
+#pod $response = $http->request($method, $url);
+#pod $response = $http->request($method, $url, \%options);
+#pod
+#pod Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST',
+#pod 'PUT', etc.) on the given URL. The URL must have unsafe characters escaped and
+#pod international domain names encoded.
+#pod
+#pod If the URL includes a "user:password" stanza, they will be used for Basic-style
+#pod authorization headers. (Authorization headers will not be included in a
+#pod redirected request.) For example:
+#pod
+#pod $http->request('GET', 'http://Aladdin:open sesame@example.com/');
+#pod
+#pod If the "user:password" stanza contains reserved characters, they must
+#pod be percent-escaped:
+#pod
+#pod $http->request('GET', 'http://john%40example.com:password@example.com/');
+#pod
+#pod A hashref of options may be appended to modify the request.
+#pod
+#pod Valid options are:
+#pod
+#pod =for :list
+#pod * C<headers> —
+#pod A hashref containing headers to include with the request. If the value for
+#pod a header is an array reference, the header will be output multiple times with
+#pod each value in the array. These headers over-write any default headers.
+#pod * C<content> —
+#pod A scalar to include as the body of the request OR a code reference
+#pod that will be called iteratively to produce the body of the request
+#pod * C<trailer_callback> —
+#pod A code reference that will be called if it exists to provide a hashref
+#pod of trailing headers (only used with chunked transfer-encoding)
+#pod * C<data_callback> —
+#pod A code reference that will be called for each chunks of the response
+#pod body received.
+#pod
+#pod The C<Host> header is generated from the URL in accordance with RFC 2616. It
+#pod is a fatal error to specify C<Host> in the C<headers> option. Other headers
+#pod may be ignored or overwritten if necessary for transport compliance.
+#pod
+#pod If the C<content> option is a code reference, it will be called iteratively
+#pod to provide the content body of the request. It should return the empty
+#pod string or undef when the iterator is exhausted.
+#pod
+#pod If the C<content> option is the empty string, no C<content-type> or
+#pod C<content-length> headers will be generated.
+#pod
+#pod If the C<data_callback> option is provided, it will be called iteratively until
+#pod the entire response body is received. The first argument will be a string
+#pod containing a chunk of the response body, the second argument will be the
+#pod in-progress response hash reference, as described below. (This allows
+#pod customizing the action of the callback based on the C<status> or C<headers>
+#pod received prior to the content body.)
+#pod
+#pod The C<request> method returns a hashref containing the response. The hashref
+#pod will have the following keys:
+#pod
+#pod =for :list
+#pod * C<success> —
+#pod Boolean indicating whether the operation returned a 2XX status code
+#pod * C<url> —
+#pod URL that provided the response. This is the URL of the request unless
+#pod there were redirections, in which case it is the last URL queried
+#pod in a redirection chain
+#pod * C<status> —
+#pod The HTTP status code of the response
+#pod * C<reason> —
+#pod The response phrase returned by the server
+#pod * C<content> —
+#pod The body of the response. If the response does not have any content
+#pod or if a data callback is provided to consume the response body,
+#pod this will be the empty string
+#pod * C<headers> —
+#pod A hashref of header fields. All header field names will be normalized
+#pod to be lower case. If a header is repeated, the value will be an arrayref;
+#pod it will otherwise be a scalar string containing the value
+#pod
+#pod On an exception during the execution of the request, the C<status> field will
+#pod contain 599, and the C<content> field will contain the text of the exception.
+#pod
+#pod =cut
my %idempotent = map { $_ => 1 } qw/GET HEAD PUT DELETE OPTIONS TRACE/;
@@ -404,19 +423,19 @@ sub request {
return $response;
}
-# =method www_form_urlencode
-#
-# $params = $http->www_form_urlencode( $data );
-# $response = $http->get("http://example.com/query?$params");
-#
-# This method converts the key/value pairs from a data hash or array reference
-# into a C<x-www-form-urlencoded> string. The keys and values from the data
-# reference will be UTF-8 encoded and escaped per RFC 3986. If a value is an
-# array reference, the key will be repeated with each of the values of the array
-# reference. If data is provided as a hash reference, the key/value pairs in the
-# resulting string will be sorted by key and value for consistent ordering.
-#
-# =cut
+#pod =method www_form_urlencode
+#pod
+#pod $params = $http->www_form_urlencode( $data );
+#pod $response = $http->get("http://example.com/query?$params");
+#pod
+#pod This method converts the key/value pairs from a data hash or array reference
+#pod into a C<x-www-form-urlencoded> string. The keys and values from the data
+#pod reference will be UTF-8 encoded and escaped per RFC 3986. If a value is an
+#pod array reference, the key will be repeated with each of the values of the array
+#pod reference. If data is provided as a hash reference, the key/value pairs in the
+#pod resulting string will be sorted by key and value for consistent ordering.
+#pod
+#pod =cut
sub www_form_urlencode {
my ($self, $data) = @_;
@@ -455,7 +474,7 @@ my %DefaultPort = (
sub _agent {
my $class = ref($_[0]) || $_[0];
(my $default_agent = $class) =~ s{::}{-}g;
- return $default_agent . "/" . ($class->VERSION || 0);
+ return $default_agent . "/" . $class->VERSION;
}
sub _request {
@@ -467,6 +486,7 @@ sub _request {
method => $method,
scheme => $scheme,
host => $host,
+ port => $port,
host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
uri => $path_query,
headers => {},
@@ -603,9 +623,9 @@ sub _create_proxy_tunnel {
my $connect_request = {
method => 'CONNECT',
- uri => $request->{host_port},
+ uri => "$request->{host}:$request->{port}",
headers => {
- host => $request->{host_port},
+ host => "$request->{host}:$request->{port}",
'user-agent' => $agent,
}
};
@@ -641,6 +661,11 @@ sub _prepare_headers_and_cb {
$request->{headers}{lc $k} = $v;
}
}
+
+ if (exists $request->{headers}{'host'}) {
+ die(qq/The 'Host' header must not be provided as header option\n/);
+ }
+
$request->{headers}{'host'} = $request->{host_port};
$request->{headers}{'user-agent'} ||= $self->{agent};
$request->{headers}{'connection'} = "close"
@@ -757,31 +782,27 @@ sub _split_url {
my $url = pop;
# URI regex adapted from the URI module
- my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
+ my ($scheme, $host, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
or die(qq/Cannot parse URL: '$url'\n/);
$scheme = lc $scheme;
$path_query = "/$path_query" unless $path_query =~ m<\A/>;
- my ($auth,$host);
- $authority = (length($authority)) ? $authority : 'localhost';
- if ( $authority =~ /@/ ) {
- ($auth,$host) = $authority =~ m/\A([^@]*)@(.*)\z/; # user:pass@host
+ my $auth = '';
+ if ( (my $i = index $host, '@') != -1 ) {
+ # user:pass@host
+ $auth = substr $host, 0, $i, ''; # take up to the @ for auth
+ substr $host, 0, 1, ''; # knock the @ off the host
+
# userinfo might be percent escaped, so recover real auth info
$auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
}
- else {
- $host = $authority;
- $auth = '';
- }
- $host = lc $host;
- my $port = do {
- $host =~ s/:([0-9]*)\z// && length $1
- ? $1
- : ($scheme eq 'http' ? 80 : $scheme eq 'https' ? 443 : undef);
- };
+ my $port = $host =~ s/:(\d*)\z// && length $1 ? $1
+ : $scheme eq 'http' ? 80
+ : $scheme eq 'https' ? 443
+ : undef;
- return ($scheme, $host, $port, $path_query, $auth);
+ return ($scheme, (length $host ? lc $host : "localhost") , $port, $path_query, $auth);
}
# Date conversions adapted from HTTP::Date
@@ -907,6 +928,8 @@ sub connect {
$self->{scheme} = $scheme;
$self->{host} = $host;
$self->{port} = $port;
+ $self->{pid} = $$;
+ $self->{tid} = _get_tid();
return $self;
}
@@ -1132,8 +1155,7 @@ sub write_header_lines {
$HeaderCase{lc $field_name} = $field_name;
}
for (ref $v eq 'ARRAY' ? @$v : $v) {
- /[^\x0D\x0A]/
- or die(qq/Invalid HTTP header field value ($field_name): / . $Printable->($_). "\n");
+ $_ = '' unless defined $_;
$buf .= "$field_name: $_\x0D\x0A";
}
}
@@ -1206,7 +1228,7 @@ sub write_content_body {
}
$len == $content_length
- or die(qq/Content-Length missmatch (got: $len expected: $content_length)\n/);
+ or die(qq/Content-Length mismatch (got: $len expected: $content_length)\n/);
return $len;
}
@@ -1351,7 +1373,9 @@ sub _assert_ssl {
sub can_reuse {
my ($self,$scheme,$host,$port) = @_;
return 0 if
- length($self->{rbuf})
+ $self->{pid} != $$
+ || $self->{tid} != _get_tid()
+ || length($self->{rbuf})
|| $scheme ne $self->{scheme}
|| $host ne $self->{host}
|| $port ne $self->{port}
@@ -1371,11 +1395,16 @@ sub _find_CA_file {
return Mozilla::CA::SSL_ca_file()
if eval { require Mozilla::CA };
- foreach my $ca_bundle (qw{
- /etc/ssl/certs/ca-certificates.crt
- /etc/pki/tls/certs/ca-bundle.crt
- /etc/ssl/ca-bundle.pem
- }
+ # cert list copied from golang src/crypto/x509/root_unix.go
+ foreach my $ca_bundle (
+ "/etc/ssl/certs/ca-certificates.crt", # Debian/Ubuntu/Gentoo etc.
+ "/etc/pki/tls/certs/ca-bundle.crt", # Fedora/RHEL
+ "/etc/ssl/ca-bundle.pem", # OpenSUSE
+ "/etc/openssl/certs/ca-certificates.crt", # NetBSD
+ "/etc/ssl/cert.pem", # OpenBSD
+ "/usr/local/share/certs/ca-root-nss.crt", # FreeBSD/DragonFly
+ "/etc/pki/tls/cacert.pem", # OpenELEC
+ "/etc/certs/ca-certificates.crt", # Solaris 11.2+
) {
return $ca_bundle if -e $ca_bundle;
}
@@ -1384,6 +1413,12 @@ sub _find_CA_file {
. qq/Try installing Mozilla::CA from CPAN\n/;
}
+# for thread safety, we need to know thread id if threads are loaded
+sub _get_tid {
+ no warnings 'reserved'; # for 'threads'
+ return threads->can("tid") ? threads->tid : 0;
+}
+
sub _ssl_args {
my ($self, $host) = @_;
@@ -1428,7 +1463,7 @@ HTTP::Tiny - A small, simple, correct HTTP/1.1 client
=head1 VERSION
-version 0.043
+version 0.054
=head1 SYNOPSIS
@@ -1473,100 +1508,74 @@ This constructor returns a new HTTP::Tiny object. Valid attributes include:
=item *
-C<agent>
-
-A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If C<agent> ends in a space character, the default user-agent string is appended.
+C<agent> — A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If C<agent> — ends in a space character, the default user-agent string is appended.
=item *
-C<cookie_jar>
-
-An instance of L<HTTP::CookieJar> or equivalent class that supports the C<add> and C<cookie_header> methods
+C<cookie_jar> — An instance of L<HTTP::CookieJar> — or equivalent class that supports the C<add> and C<cookie_header> methods
=item *
-C<default_headers>
-
-A hashref of default headers to apply to requests
+C<default_headers> — A hashref of default headers to apply to requests
=item *
-C<local_address>
-
-The local IP address to bind to
+C<local_address> — The local IP address to bind to
=item *
-C<keep_alive>
-
-Whether to reuse the last connection (if for the same scheme, host and port) (defaults to 1)
+C<keep_alive> — Whether to reuse the last connection (if for the same scheme, host and port) (defaults to 1)
=item *
-C<max_redirect>
-
-Maximum number of redirects allowed (defaults to 5)
+C<max_redirect> — Maximum number of redirects allowed (defaults to 5)
=item *
-C<max_size>
-
-Maximum response size (only when not using a data callback). If defined, responses larger than this will return an exception.
+C<max_size> — Maximum response size (only when not using a data callback). If defined, responses larger than this will return an exception.
=item *
-C<http_proxy>
-
-URL of a proxy server to use for HTTP connections (default is C<$ENV{http_proxy}> if set)
+C<http_proxy> — URL of a proxy server to use for HTTP connections (default is C<$ENV{http_proxy}> — if set)
=item *
-C<https_proxy>
-
-URL of a proxy server to use for HTTPS connections (default is C<$ENV{https_proxy}> if set)
+C<https_proxy> — URL of a proxy server to use for HTTPS connections (default is C<$ENV{https_proxy}> — if set)
=item *
-C<proxy>
-
-URL of a generic proxy server for both HTTP and HTTPS connections (default is C<$ENV{all_proxy}> if set)
+C<proxy> — URL of a generic proxy server for both HTTP and HTTPS connections (default is C<$ENV{all_proxy}> — if set)
=item *
-C<no_proxy>
-
-List of domain suffixes that should not be proxied. Must be a comma-separated string or an array reference. (default is C<$ENV{no_proxy}>)
+C<no_proxy> — List of domain suffixes that should not be proxied. Must be a comma-separated string or an array reference. (default is C<$ENV{no_proxy}> —)
=item *
-C<timeout>
-
-Request timeout in seconds (default is 60)
+C<timeout> — Request timeout in seconds (default is 60)
=item *
-C<verify_SSL>
-
-A boolean that indicates whether to validate the SSL certificate of an C<https>
-connection (default is false)
+C<verify_SSL> — A boolean that indicates whether to validate the SSL certificate of an C<https> — connection (default is false)
=item *
-C<SSL_options>
-
-A hashref of C<SSL_*> options to pass through to L<IO::Socket::SSL>
+C<SSL_options> — A hashref of C<SSL_*> — options to pass through to L<IO::Socket::SSL>
=back
+Passing an explicit C<undef> for C<proxy>, C<http_proxy> or C<https_proxy> will
+prevent getting the corresponding proxies from the environment.
+
Exceptions from C<max_size>, C<timeout> or other errors will result in a
pseudo-HTTP status code of 599 and a reason of "Internal Exception". The
content field in the response will contain the text of the exception.
The C<keep_alive> parameter enables a persistent connection, but only to a
single destination scheme, host and port. Also, if any connection-relevant
-attributes are modified, a persistent connection will be dropped. If you want
-persistent connections across multiple destinations, use multiple HTTP::Tiny
-objects.
+attributes are modified, or if the process ID or thread ID change, the
+persistent connection will be dropped. If you want persistent connections
+across multiple destinations, use multiple HTTP::Tiny objects.
See L</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes.
@@ -1649,35 +1658,26 @@ Valid options are:
=item *
-C<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.
+C<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 *
-C<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 request
+C<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 request
=item *
-C<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)
+C<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 *
-C<data_callback>
-
-A code reference that will be called for each chunks of the response
-body received.
+C<data_callback> — A code reference that will be called for each chunks of the response body received.
=back
+The C<Host> header is generated from the URL in accordance with RFC 2616. It
+is a fatal error to specify C<Host> in the C<headers> option. Other headers
+may be ignored or overwritten if necessary for transport compliance.
+
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.
@@ -1699,45 +1699,27 @@ will have the following keys:
=item *
-C<success>
-
-Boolean indicating whether the operation returned a 2XX status code
+C<success> — Boolean indicating whether the operation returned a 2XX status code
=item *
-C<url>
-
-URL that provided the response. This is the URL of the request unless
-there were redirections, in which case it is the last URL queried
-in a redirection chain
+C<url> — URL that provided the response. This is the URL of the request unless there were redirections, in which case it is the last URL queried in a redirection chain
=item *
-C<status>
-
-The HTTP status code of the response
+C<status> — The HTTP status code of the response
=item *
-C<reason>
-
-The response phrase returned by the server
+C<reason> — The response phrase returned by the server
=item *
-C<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
+C<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 *
-C<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
+C<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
@@ -1775,7 +1757,7 @@ verify_SSL
Direct C<https> connections are supported only if L<IO::Socket::SSL> 1.56 or
greater and L<Net::SSLeay> 1.49 or greater are installed. An exception will be
-thrown if a new enough versions of these modules not installed or if the SSL
+thrown if new enough versions of these modules are not installed or if the SSL
encryption fails. An C<https> connection may be made via an C<http> proxy that
supports the CONNECT command (i.e. RFC 2817). You may not proxy C<https> via
a proxy that itself requires C<https> to communicate.
@@ -1867,7 +1849,7 @@ HTTP::Tiny supports the following proxy environment variables:
=item *
-http_proxy
+http_proxy or HTTP_PROXY
=item *
@@ -1879,6 +1861,11 @@ all_proxy or ALL_PROXY
=back
+If the C<REQUEST_METHOD> environment variable is set, then this might be a CGI
+process and C<HTTP_PROXY> would be set from the C<Proxy:> header, which is a
+security risk. If C<REQUEST_METHOD> is set, C<HTTP_PROXY> (the upper case
+variant only) is ignored.
+
Tunnelling C<https> over an C<http> proxy using the CONNECT method is
supported. If your proxy uses C<https> itself, you can not tunnel C<https>
over it.
@@ -1895,9 +1882,40 @@ environment variables.
=head1 LIMITATIONS
HTTP::Tiny is I<conditionally compliant> with the
-L<HTTP/1.1 specification|http://www.w3.org/Protocols/rfc2616/rfc2616.html>.
+L<HTTP/1.1 specifications|http://www.w3.org/Protocols/>:
+
+=over 4
+
+=item *
+
+"Message Syntax and Routing" [RFC7230]
+
+=item *
+
+"Semantics and Content" [RFC7231]
+
+=item *
+
+"Conditional Requests" [RFC7232]
+
+=item *
+
+"Range Requests" [RFC7233]
+
+=item *
+
+"Caching" [RFC7234]
+
+=item *
+
+"Authentication" [RFC7235]
+
+=back
+
It attempts to meet all "MUST" requirements of the specification, but does not
-implement all "SHOULD" requirements.
+implement all "SHOULD" requirements. (Note: it was developed against the
+earlier RFC 2616 specification and may not yet meet the revised RFC 7230-7235
+spec.)
Some particular limitations of note include:
@@ -2015,6 +2033,8 @@ David Golden <dagolden@cpan.org>
=head1 CONTRIBUTORS
+=for stopwords Alan Gardner Alessandro Ghedini Brad Gilbert Chris Nehren Weyl Claes Jakobsson Clinton Gormley Craig Berry David Mitchell Dean Pearce Edward Zborowski James Raspass Jess Robinson Lukas Eklund Martin J. Evans Martin-Louis Bright Mike Doherty Olaf Alders Petr Písař Serguei Trouchelle Sören Kornetzki Syohei YOSHIDA Tom Hukins Tony Cook
+
=over 4
=item *
@@ -2055,10 +2075,18 @@ David Mitchell <davem@iabyn.com>
=item *
+Dean Pearce <pearce@pythian.com>
+
+=item *
+
Edward Zborowski <ed@rubensteintech.com>
=item *
+James Raspass <jraspass@gmail.com>
+
+=item *
+
Jess Robinson <castaway@desert-island.me.uk>
=item *
@@ -2079,6 +2107,10 @@ Mike Doherty <doherty@cpan.org>
=item *
+Olaf Alders <olaf@wundersolutions.com>
+
+=item *
+
Petr Písař <ppisar@redhat.com>
=item *
@@ -2087,17 +2119,25 @@ Serguei Trouchelle <stro@cpan.org>
=item *
+Sören Kornetzki <soeren.kornetzki@delti.com>
+
+=item *
+
Syohei YOSHIDA <syohex@gmail.com>
=item *
+Tom Hukins <tom@eborcom.com>
+
+=item *
+
Tony Cook <tony@develop-help.com>
=back
=head1 COPYRIGHT AND LICENSE
-This software is copyright (c) 2014 by Christian Hansen.
+This software is copyright (c) 2015 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.