summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol
diff options
context:
space:
mode:
authorNorbert Preining <norbert@preining.info>2024-03-15 03:06:35 +0000
committerNorbert Preining <norbert@preining.info>2024-03-15 03:06:35 +0000
commit12679ab7d3c2a210f4123163671b532b8b55d5f9 (patch)
tree0060d13467186ad977f4e73488ee20dd6c0017ab /systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol
parent62170822e034fdd3f81de7274835d0d3b0467100 (diff)
CTAN sync 202403150306
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol')
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/cpan.pm72
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/data.pm52
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/file.pm147
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/ftp.pm555
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/gopher.pm213
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/http.pm523
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/loopback.pm27
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/mailto.pm184
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/nntp.pm150
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/nogo.pm25
10 files changed, 0 insertions, 1948 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/cpan.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/cpan.pm
deleted file mode 100644
index 90ced43d06..0000000000
--- a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/cpan.pm
+++ /dev/null
@@ -1,72 +0,0 @@
-package LWP::Protocol::cpan;
-
-use strict;
-
-use parent qw(LWP::Protocol);
-
-our $VERSION = '6.61';
-
-require URI;
-require HTTP::Status;
-require HTTP::Response;
-
-our $CPAN;
-
-unless ($CPAN) {
- # Try to find local CPAN mirror via $CPAN::Config
- eval {
- require CPAN::Config;
- if($CPAN::Config) {
- my $urls = $CPAN::Config->{urllist};
- if (ref($urls) eq "ARRAY") {
- my $file;
- for (@$urls) {
- if (/^file:/) {
- $file = $_;
- last;
- }
- }
-
- if ($file) {
- $CPAN = $file;
- }
- else {
- $CPAN = $urls->[0];
- }
- }
- }
- };
-
- $CPAN ||= "http://cpan.org/"; # last resort
-}
-
-# ensure that we don't chop of last part
-$CPAN .= "/" unless $CPAN =~ m,/$,;
-
-
-sub request {
- my($self, $request, $proxy, $arg, $size) = @_;
- # check proxy
- if (defined $proxy)
- {
- return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
- 'You can not proxy with cpan');
- }
-
- # check method
- my $method = $request->method;
- unless ($method eq 'GET' || $method eq 'HEAD') {
- return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
- 'Library does not allow method ' .
- "$method for 'cpan:' URLs");
- }
-
- my $path = $request->uri->path;
- $path =~ s,^/,,;
-
- my $response = HTTP::Response->new(HTTP::Status::RC_FOUND);
- $response->header("Location" => URI->new_abs($path, $CPAN));
- $response;
-}
-
-1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/data.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/data.pm
deleted file mode 100644
index a0461b5e41..0000000000
--- a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/data.pm
+++ /dev/null
@@ -1,52 +0,0 @@
-package LWP::Protocol::data;
-
-# Implements access to data:-URLs as specified in RFC 2397
-
-use strict;
-
-our $VERSION = '6.61';
-
-require HTTP::Response;
-require HTTP::Status;
-
-use parent qw(LWP::Protocol);
-
-use HTTP::Date qw(time2str);
-require LWP; # needs version number
-
-sub request
-{
- my($self, $request, $proxy, $arg, $size) = @_;
-
- # check proxy
- if (defined $proxy)
- {
- return HTTP::Response->new( HTTP::Status::RC_BAD_REQUEST,
- 'You can not proxy with data');
- }
-
- # check method
- my $method = $request->method;
- unless ($method eq 'GET' || $method eq 'HEAD') {
- return HTTP::Response->new( HTTP::Status::RC_BAD_REQUEST,
- 'Library does not allow method ' .
- "$method for 'data:' URLs");
- }
-
- my $url = $request->uri;
- my $response = HTTP::Response->new( HTTP::Status::RC_OK, "Document follows");
-
- my $media_type = $url->media_type;
-
- my $data = $url->data;
- $response->header('Content-Type' => $media_type,
- 'Content-Length' => length($data),
- 'Date' => time2str(time),
- 'Server' => "libwww-perl-internal/$LWP::VERSION"
- );
-
- $data = "" if $method eq "HEAD";
- return $self->collect_once($arg, $response, $data);
-}
-
-1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/file.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/file.pm
deleted file mode 100644
index 37be55d76f..0000000000
--- a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/file.pm
+++ /dev/null
@@ -1,147 +0,0 @@
-package LWP::Protocol::file;
-
-use parent qw(LWP::Protocol);
-
-use strict;
-
-our $VERSION = '6.61';
-
-require LWP::MediaTypes;
-require HTTP::Request;
-require HTTP::Response;
-require HTTP::Status;
-require HTTP::Date;
-
-
-sub request
-{
- my($self, $request, $proxy, $arg, $size) = @_;
-
- $size = 4096 unless defined $size and $size > 0;
-
- # check proxy
- if (defined $proxy)
- {
- return HTTP::Response->new( HTTP::Status::RC_BAD_REQUEST,
- 'You can not proxy through the filesystem');
- }
-
- # check method
- my $method = $request->method;
- unless ($method eq 'GET' || $method eq 'HEAD') {
- return HTTP::Response->new( HTTP::Status::RC_BAD_REQUEST,
- 'Library does not allow method ' .
- "$method for 'file:' URLs");
- }
-
- # check url
- my $url = $request->uri;
-
- my $scheme = $url->scheme;
- if ($scheme ne 'file') {
- return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR,
- "LWP::Protocol::file::request called for '$scheme'");
- }
-
- # URL OK, look at file
- my $path = $url->file;
-
- # test file exists and is readable
- unless (-e $path) {
- return HTTP::Response->new( HTTP::Status::RC_NOT_FOUND,
- "File `$path' does not exist");
- }
- unless (-r _) {
- return HTTP::Response->new( HTTP::Status::RC_FORBIDDEN,
- 'User does not have read permission');
- }
-
- # looks like file exists
- my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$filesize,
- $atime,$mtime,$ctime,$blksize,$blocks)
- = stat(_);
-
- # XXX should check Accept headers?
-
- # check if-modified-since
- my $ims = $request->header('If-Modified-Since');
- if (defined $ims) {
- my $time = HTTP::Date::str2time($ims);
- if (defined $time and $time >= $mtime) {
- return HTTP::Response->new( HTTP::Status::RC_NOT_MODIFIED,
- "$method $path");
- }
- }
-
- # Ok, should be an OK response by now...
- my $response = HTTP::Response->new( HTTP::Status::RC_OK );
-
- # fill in response headers
- $response->header('Last-Modified', HTTP::Date::time2str($mtime));
-
- if (-d _) { # If the path is a directory, process it
- # generate the HTML for directory
- opendir(D, $path) or
- return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR,
- "Cannot read directory '$path': $!");
- my(@files) = sort readdir(D);
- closedir(D);
-
- # Make directory listing
- require URI::Escape;
- require HTML::Entities;
- my $pathe = $path . ( $^O eq 'MacOS' ? ':' : '/');
- for (@files) {
- my $furl = URI::Escape::uri_escape($_);
- if ( -d "$pathe$_" ) {
- $furl .= '/';
- $_ .= '/';
- }
- my $desc = HTML::Entities::encode($_);
- $_ = qq{<LI><A HREF="$furl">$desc</A>};
- }
- # Ensure that the base URL is "/" terminated
- my $base = $url->clone;
- unless ($base->path =~ m|/$|) {
- $base->path($base->path . "/");
- }
- my $html = join("\n",
- "<HTML>\n<HEAD>",
- "<TITLE>Directory $path</TITLE>",
- "<BASE HREF=\"$base\">",
- "</HEAD>\n<BODY>",
- "<H1>Directory listing of $path</H1>",
- "<UL>", @files, "</UL>",
- "</BODY>\n</HTML>\n");
-
- $response->header('Content-Type', 'text/html');
- $response->header('Content-Length', length $html);
- $html = "" if $method eq "HEAD";
-
- return $self->collect_once($arg, $response, $html);
-
- }
-
- # path is a regular file
- $response->header('Content-Length', $filesize);
- LWP::MediaTypes::guess_media_type($path, $response);
-
- # read the file
- if ($method ne "HEAD") {
- open(my $fh, '<', $path) or return new
- HTTP::Response(HTTP::Status::RC_INTERNAL_SERVER_ERROR,
- "Cannot read file '$path': $!");
- binmode($fh);
- $response = $self->collect($arg, $response, sub {
- my $content = "";
- my $bytes = sysread($fh, $content, $size);
- return \$content if $bytes > 0;
- return \ "";
- });
- close($fh);
- }
-
- $response;
-}
-
-1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/ftp.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/ftp.pm
deleted file mode 100644
index a82d527345..0000000000
--- a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/ftp.pm
+++ /dev/null
@@ -1,555 +0,0 @@
-package LWP::Protocol::ftp;
-
-# Implementation of the ftp protocol (RFC 959). We let the Net::FTP
-# package do all the dirty work.
-use parent qw(LWP::Protocol);
-use strict;
-
-our $VERSION = '6.61';
-
-use Carp ();
-use HTTP::Status ();
-use HTTP::Negotiate ();
-use HTTP::Response ();
-use LWP::MediaTypes ();
-use File::Listing ();
-
-
-{
-
- package # hide from PAUSE
- LWP::Protocol::MyFTP;
-
- use strict;
- use parent qw(Net::FTP);
-
- sub new {
- my $class = shift;
-
- my $self = $class->SUPER::new(@_) || return undef;
-
- my $mess = $self->message; # welcome message
- $mess =~ s|\n.*||s; # only first line left
- $mess =~ s|\s*ready\.?$||;
-
- # Make the version number more HTTP like
- $mess =~ s|\s*\(Version\s*|/| and $mess =~ s|\)$||;
- ${*$self}{myftp_server} = $mess;
-
- #$response->header("Server", $mess);
-
- $self;
- }
-
- sub http_server {
- my $self = shift;
- ${*$self}{myftp_server};
- }
-
- sub home {
- my $self = shift;
- my $old = ${*$self}{myftp_home};
- if (@_) {
- ${*$self}{myftp_home} = shift;
- }
- $old;
- }
-
- sub go_home {
- my $self = shift;
- $self->cwd(${*$self}{myftp_home});
- }
-
- sub request_count {
- my $self = shift;
- ++${*$self}{myftp_reqcount};
- }
-
- sub ping {
- my $self = shift;
- return $self->go_home;
- }
-}
-
-sub _connect {
- my ($self, $host, $port, $user, $account, $password, $timeout) = @_;
-
- my $key;
- my $conn_cache = $self->{ua}{conn_cache};
- if ($conn_cache) {
- $key = "$host:$port:$user";
- $key .= ":$account" if defined($account);
- if (my $ftp = $conn_cache->withdraw("ftp", $key)) {
- if ($ftp->ping) {
-
- # save it again
- $conn_cache->deposit("ftp", $key, $ftp);
- return $ftp;
- }
- }
- }
-
- # try to make a connection
- my $ftp = LWP::Protocol::MyFTP->new(
- $host,
- Port => $port,
- Timeout => $timeout,
- LocalAddr => $self->{ua}{local_address},
- );
-
- # XXX Should be some what to pass on 'Passive' (header??)
- unless ($ftp) {
- $@ =~ s/^Net::FTP: //;
- return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR, $@);
- }
-
- unless ($ftp->login($user, $password, $account)) {
-
- # Unauthorized. Let's fake a RC_UNAUTHORIZED response
- my $mess = scalar($ftp->message);
- $mess =~ s/\n$//;
- my $res = HTTP::Response->new(HTTP::Status::RC_UNAUTHORIZED, $mess);
- $res->header("Server", $ftp->http_server);
- $res->header("WWW-Authenticate", qq(Basic Realm="FTP login"));
- return $res;
- }
-
- my $home = $ftp->pwd;
- $ftp->home($home);
-
- $conn_cache->deposit("ftp", $key, $ftp) if $conn_cache;
-
- return $ftp;
-}
-
-
-sub request {
- my ($self, $request, $proxy, $arg, $size, $timeout) = @_;
-
- $size = 4096 unless $size;
-
- # check proxy
- if (defined $proxy) {
- return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
- 'You can not proxy through the ftp');
- }
-
- my $url = $request->uri;
- if ($url->scheme ne 'ftp') {
- my $scheme = $url->scheme;
- return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR,
- "LWP::Protocol::ftp::request called for '$scheme'");
- }
-
- # check method
- my $method = $request->method;
-
- unless ($method eq 'GET' || $method eq 'HEAD' || $method eq 'PUT') {
- return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
- 'Library does not allow method ' . "$method for 'ftp:' URLs");
- }
-
- my $host = $url->host;
- my $port = $url->port;
- my $user = $url->user;
- my $password = $url->password;
-
- # If a basic authorization header is present than we prefer these over
- # the username/password specified in the URL.
- {
- my ($u, $p) = $request->authorization_basic;
- if (defined $u) {
- $user = $u;
- $password = $p;
- }
- }
-
- # We allow the account to be specified in the "Account" header
- my $account = $request->header('Account');
-
- my $ftp
- = $self->_connect($host, $port, $user, $account, $password, $timeout);
- return $ftp if ref($ftp) eq "HTTP::Response"; # ugh!
-
- # Create an initial response object
- my $response = HTTP::Response->new(HTTP::Status::RC_OK, "OK");
- $response->header(Server => $ftp->http_server);
- $response->header('Client-Request-Num' => $ftp->request_count);
- $response->request($request);
-
- # Get & fix the path
- my @path = grep {length} $url->path_segments;
- my $remote_file = pop(@path);
- $remote_file = '' unless defined $remote_file;
-
- my $type;
- if (ref $remote_file) {
- my @params;
- ($remote_file, @params) = @$remote_file;
- for (@params) {
- $type = $_ if s/^type=//;
- }
- }
-
- if ($type && $type eq 'a') {
- $ftp->ascii;
- }
- else {
- $ftp->binary;
- }
-
- for (@path) {
- unless ($ftp->cwd($_)) {
- return HTTP::Response->new(HTTP::Status::RC_NOT_FOUND,
- "Can't chdir to $_");
- }
- }
-
- if ($method eq 'GET' || $method eq 'HEAD') {
- if (my $mod_time = $ftp->mdtm($remote_file)) {
- $response->last_modified($mod_time);
- if (my $ims = $request->if_modified_since) {
- if ($mod_time <= $ims) {
- $response->code(HTTP::Status::RC_NOT_MODIFIED);
- $response->message("Not modified");
- return $response;
- }
- }
- }
-
- # We'll use this later to abort the transfer if necessary.
- # if $max_size is defined, we need to abort early. Otherwise, it's
- # a normal transfer
- my $max_size = undef;
-
- # Set resume location, if the client requested it
- if ($request->header('Range') && $ftp->supported('REST')) {
- my $range_info = $request->header('Range');
-
- # Change bytes=2772992-6781209 to just 2772992
- my ($start_byte, $end_byte) = $range_info =~ /.*=\s*(\d+)-(\d+)?/;
- if (defined $start_byte && !defined $end_byte) {
-
- # open range -- only the start is specified
-
- $ftp->restart($start_byte);
-
- # don't define $max_size, we don't want to abort early
- }
- elsif (defined $start_byte
- && defined $end_byte
- && $start_byte >= 0
- && $end_byte >= $start_byte)
- {
-
- $ftp->restart($start_byte);
- $max_size = $end_byte - $start_byte;
- }
- else {
-
- return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
- 'Incorrect syntax for Range request');
- }
- }
- elsif ($request->header('Range') && !$ftp->supported('REST')) {
- return HTTP::Response->new(HTTP::Status::RC_NOT_IMPLEMENTED,
- "Server does not support resume."
- );
- }
-
- my $data; # the data handle
- if (length($remote_file) and $data = $ftp->retr($remote_file)) {
- my ($type, @enc) = LWP::MediaTypes::guess_media_type($remote_file);
- $response->header('Content-Type', $type) if $type;
- for (@enc) {
- $response->push_header('Content-Encoding', $_);
- }
- my $mess = $ftp->message;
- if ($mess =~ /\((\d+)\s+bytes\)/) {
- $response->header('Content-Length', "$1");
- }
-
- if ($method ne 'HEAD') {
-
- # Read data from server
- $response = $self->collect(
- $arg,
- $response,
- sub {
- my $content = '';
- my $result = $data->read($content, $size);
-
- # Stop early if we need to.
- if (defined $max_size) {
-
- # We need an interface to Net::FTP::dataconn for getting
- # the number of bytes already read
- my $bytes_received = $data->bytes_read();
-
- # We were already over the limit. (Should only happen
- # once at the end.)
- if ($bytes_received - length($content) > $max_size)
- {
- $content = '';
- }
-
- # We just went over the limit
- elsif ($bytes_received > $max_size) {
-
- # Trim content
- $content = substr($content, 0,
- $max_size
- - ($bytes_received - length($content)));
- }
-
- # We're under the limit
- else {
- }
- }
-
- return \$content;
- }
- );
- }
-
- # abort is needed for HEAD, it's == close if the transfer has
- # already completed.
- unless ($data->abort) {
-
- # Something did not work too well. Note that we treat
- # responses to abort() with code 0 in case of HEAD as ok
- # (at least wu-ftpd 2.6.1(1) does that).
- if ($method ne 'HEAD' || $ftp->code != 0) {
- $response->code(HTTP::Status::RC_INTERNAL_SERVER_ERROR);
- $response->message("FTP close response: "
- . $ftp->code . " "
- . $ftp->message);
- }
- }
- }
- elsif (!length($remote_file) || ($ftp->code >= 400 && $ftp->code < 600))
- {
- # not a plain file, try to list instead
- if (length($remote_file) && !$ftp->cwd($remote_file)) {
- return HTTP::Response->new(HTTP::Status::RC_NOT_FOUND,
- "File '$remote_file' not found"
- );
- }
-
- # It should now be safe to try to list the directory
- my @lsl = $ftp->dir;
-
- # Try to figure out if the user want us to convert the
- # directory listing to HTML.
- my @variants = (
- ['html', 0.60, 'text/html'],
- ['dir', 1.00, 'text/ftp-dir-listing']
- );
-
- #$HTTP::Negotiate::DEBUG=1;
- my $prefer = HTTP::Negotiate::choose(\@variants, $request);
-
- my $content = '';
-
- if (!defined($prefer)) {
- return HTTP::Response->new(HTTP::Status::RC_NOT_ACCEPTABLE,
- "Neither HTML nor directory listing wanted");
- }
- elsif ($prefer eq 'html') {
- $response->header('Content-Type' => 'text/html');
- $content = "<HEAD><TITLE>File Listing</TITLE>\n";
- my $base = $request->uri->clone;
- my $path = $base->path;
- $base->path("$path/") unless $path =~ m|/$|;
- $content .= qq(<BASE HREF="$base">\n</HEAD>\n);
- $content .= "<BODY>\n<UL>\n";
- for (File::Listing::parse_dir(\@lsl, 'GMT')) {
- my ($name, $type, $size, $mtime, $mode) = @$_;
- $content .= qq( <LI> <a href="$name">$name</a>);
- $content .= " $size bytes" if $type eq 'f';
- $content .= "\n";
- }
- $content .= "</UL></body>\n";
- }
- else {
- $response->header('Content-Type', 'text/ftp-dir-listing');
- $content = join("\n", @lsl, '');
- }
-
- $response->header('Content-Length', length($content));
-
- if ($method ne 'HEAD') {
- $response = $self->collect_once($arg, $response, $content);
- }
- }
- else {
- my $res = HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
- "FTP return code " . $ftp->code);
- $res->content_type("text/plain");
- $res->content($ftp->message);
- return $res;
- }
- }
- elsif ($method eq 'PUT') {
-
- # method must be PUT
- unless (length($remote_file)) {
- return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
- "Must have a file name to PUT to"
- );
- }
- my $data;
- if ($data = $ftp->stor($remote_file)) {
- my $content = $request->content;
- my $bytes = 0;
- if (defined $content) {
- if (ref($content) eq 'SCALAR') {
- $bytes = $data->write($$content, length($$content));
- }
- elsif (ref($content) eq 'CODE') {
- my ($buf, $n);
- while (length($buf = &$content)) {
- $n = $data->write($buf, length($buf));
- last unless $n;
- $bytes += $n;
- }
- }
- elsif (!ref($content)) {
- if (defined $content && length($content)) {
- $bytes = $data->write($content, length($content));
- }
- }
- else {
- die "Bad content";
- }
- }
- $data->close;
-
- $response->code(HTTP::Status::RC_CREATED);
- $response->header('Content-Type', 'text/plain');
- $response->content("$bytes bytes stored as $remote_file on $host\n")
-
- }
- else {
- my $res = HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
- "FTP return code " . $ftp->code);
- $res->content_type("text/plain");
- $res->content($ftp->message);
- return $res;
- }
- }
- else {
- return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
- "Illegal method $method");
- }
-
- $response;
-}
-
-1;
-
-__END__
-
-# This is what RFC 1738 has to say about FTP access:
-# --------------------------------------------------
-#
-# 3.2. FTP
-#
-# The FTP URL scheme is used to designate files and directories on
-# Internet hosts accessible using the FTP protocol (RFC959).
-#
-# A FTP URL follow the syntax described in Section 3.1. If :<port> is
-# omitted, the port defaults to 21.
-#
-# 3.2.1. FTP Name and Password
-#
-# A user name and password may be supplied; they are used in the ftp
-# "USER" and "PASS" commands after first making the connection to the
-# FTP server. If no user name or password is supplied and one is
-# requested by the FTP server, the conventions for "anonymous" FTP are
-# to be used, as follows:
-#
-# The user name "anonymous" is supplied.
-#
-# The password is supplied as the Internet e-mail address
-# of the end user accessing the resource.
-#
-# If the URL supplies a user name but no password, and the remote
-# server requests a password, the program interpreting the FTP URL
-# should request one from the user.
-#
-# 3.2.2. FTP url-path
-#
-# The url-path of a FTP URL has the following syntax:
-#
-# <cwd1>/<cwd2>/.../<cwdN>/<name>;type=<typecode>
-#
-# Where <cwd1> through <cwdN> and <name> are (possibly encoded) strings
-# and <typecode> is one of the characters "a", "i", or "d". The part
-# ";type=<typecode>" may be omitted. The <cwdx> and <name> parts may be
-# empty. The whole url-path may be omitted, including the "/"
-# delimiting it from the prefix containing user, password, host, and
-# port.
-#
-# The url-path is interpreted as a series of FTP commands as follows:
-#
-# Each of the <cwd> elements is to be supplied, sequentially, as the
-# argument to a CWD (change working directory) command.
-#
-# If the typecode is "d", perform a NLST (name list) command with
-# <name> as the argument, and interpret the results as a file
-# directory listing.
-#
-# Otherwise, perform a TYPE command with <typecode> as the argument,
-# and then access the file whose name is <name> (for example, using
-# the RETR command.)
-#
-# Within a name or CWD component, the characters "/" and ";" are
-# reserved and must be encoded. The components are decoded prior to
-# their use in the FTP protocol. In particular, if the appropriate FTP
-# sequence to access a particular file requires supplying a string
-# containing a "/" as an argument to a CWD or RETR command, it is
-# necessary to encode each "/".
-#
-# For example, the URL <URL:ftp://myname@host.dom/%2Fetc/motd> is
-# interpreted by FTP-ing to "host.dom", logging in as "myname"
-# (prompting for a password if it is asked for), and then executing
-# "CWD /etc" and then "RETR motd". This has a different meaning from
-# <URL:ftp://myname@host.dom/etc/motd> which would "CWD etc" and then
-# "RETR motd"; the initial "CWD" might be executed relative to the
-# default directory for "myname". On the other hand,
-# <URL:ftp://myname@host.dom//etc/motd>, would "CWD " with a null
-# argument, then "CWD etc", and then "RETR motd".
-#
-# FTP URLs may also be used for other operations; for example, it is
-# possible to update a file on a remote file server, or infer
-# information about it from the directory listings. The mechanism for
-# doing so is not spelled out here.
-#
-# 3.2.3. FTP Typecode is Optional
-#
-# The entire ;type=<typecode> part of a FTP URL is optional. If it is
-# omitted, the client program interpreting the URL must guess the
-# appropriate mode to use. In general, the data content type of a file
-# can only be guessed from the name, e.g., from the suffix of the name;
-# the appropriate type code to be used for transfer of the file can
-# then be deduced from the data content of the file.
-#
-# 3.2.4 Hierarchy
-#
-# For some file systems, the "/" used to denote the hierarchical
-# structure of the URL corresponds to the delimiter used to construct a
-# file name hierarchy, and thus, the filename will look similar to the
-# URL path. This does NOT mean that the URL is a Unix filename.
-#
-# 3.2.5. Optimization
-#
-# Clients accessing resources via FTP may employ additional heuristics
-# to optimize the interaction. For some FTP servers, for example, it
-# may be reasonable to keep the control connection open while accessing
-# multiple URLs from the same server. However, there is no common
-# hierarchical model to the FTP protocol, so if a directory change
-# command has been given, it is impossible in general to deduce what
-# sequence should be given to navigate to another directory for a
-# second retrieval, if the paths are different. The only reliable
-# algorithm is to disconnect and reestablish the control connection.
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/gopher.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/gopher.pm
deleted file mode 100644
index 1b46df4a07..0000000000
--- a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/gopher.pm
+++ /dev/null
@@ -1,213 +0,0 @@
-package LWP::Protocol::gopher;
-
-# Implementation of the gopher protocol (RFC 1436)
-#
-# This code is based on 'wwwgopher.pl,v 0.10 1994/10/17 18:12:34 shelden'
-# which in turn is a vastly modified version of Oscar's http'get()
-# dated 28/3/94 in <ftp://cui.unige.ch/PUBLIC/oscar/scripts/http.pl>
-# including contributions from Marc van Heyningen and Martijn Koster.
-
-use strict;
-
-our $VERSION = '6.61';
-
-require HTTP::Response;
-require HTTP::Status;
-require IO::Socket;
-require IO::Select;
-
-use parent qw(LWP::Protocol);
-
-
-my %gopher2mimetype = (
- '0' => 'text/plain', # 0 file
- '1' => 'text/html', # 1 menu
- # 2 CSO phone-book server
- # 3 Error
- '4' => 'application/mac-binhex40', # 4 BinHexed Macintosh file
- '5' => 'application/zip', # 5 DOS binary archive of some sort
- '6' => 'application/octet-stream', # 6 UNIX uuencoded file.
- '7' => 'text/html', # 7 Index-Search server
- # 8 telnet session
- '9' => 'application/octet-stream', # 9 binary file
- 'h' => 'text/html', # html
- 'g' => 'image/gif', # gif
- 'I' => 'image/*', # some kind of image
-);
-
-my %gopher2encoding = (
- '6' => 'x_uuencode', # 6 UNIX uuencoded file.
-);
-
-sub request
-{
- my($self, $request, $proxy, $arg, $size, $timeout) = @_;
-
- $size = 4096 unless $size;
-
- # check proxy
- if (defined $proxy) {
- return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
- 'You can not proxy through the gopher');
- }
-
- my $url = $request->uri;
- die "bad scheme" if $url->scheme ne 'gopher';
-
-
- my $method = $request->method;
- unless ($method eq 'GET' || $method eq 'HEAD') {
- return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
- 'Library does not allow method ' .
- "$method for 'gopher:' URLs");
- }
-
- my $gophertype = $url->gopher_type;
- unless (exists $gopher2mimetype{$gophertype}) {
- return HTTP::Response->new(HTTP::Status::RC_NOT_IMPLEMENTED,
- 'Library does not support gophertype ' .
- $gophertype);
- }
-
- my $response = HTTP::Response->new(HTTP::Status::RC_OK, "OK");
- $response->header('Content-type' => $gopher2mimetype{$gophertype}
- || 'text/plain');
- $response->header('Content-Encoding' => $gopher2encoding{$gophertype})
- if exists $gopher2encoding{$gophertype};
-
- if ($method eq 'HEAD') {
- # XXX: don't even try it so we set this header
- $response->header('Client-Warning' => 'Client answer only');
- return $response;
- }
-
- if ($gophertype eq '7' && ! $url->search) {
- # the url is the prompt for a gopher search; supply boiler-plate
- return $self->collect_once($arg, $response, <<"EOT");
-<HEAD>
-<TITLE>Gopher Index</TITLE>
-<ISINDEX>
-</HEAD>
-<BODY>
-<H1>$url<BR>Gopher Search</H1>
-This is a searchable Gopher index.
-Use the search function of your browser to enter search terms.
-</BODY>
-EOT
- }
-
- my $host = $url->host;
- my $port = $url->port;
-
- my $requestLine = "";
-
- my $selector = $url->selector;
- if (defined $selector) {
- $requestLine .= $selector;
- my $search = $url->search;
- if (defined $search) {
- $requestLine .= "\t$search";
- my $string = $url->string;
- if (defined $string) {
- $requestLine .= "\t$string";
- }
- }
- }
- $requestLine .= "\015\012";
-
- # potential request headers are just ignored
-
- # Ok, lets make the request
- my $socket = IO::Socket::INET->new(PeerAddr => $host,
- PeerPort => $port,
- LocalAddr => $self->{ua}{local_address},
- Proto => 'tcp',
- Timeout => $timeout);
- die "Can't connect to $host:$port" unless $socket;
- my $sel = IO::Select->new($socket);
-
- {
- die "write timeout" if $timeout && !$sel->can_write($timeout);
- my $n = syswrite($socket, $requestLine, length($requestLine));
- die $! unless defined($n);
- die "short write" if $n != length($requestLine);
- }
-
- my $user_arg = $arg;
-
- # must handle menus in a special way since they are to be
- # converted to HTML. Undefing $arg ensures that the user does
- # not see the data before we get a change to convert it.
- $arg = undef if $gophertype eq '1' || $gophertype eq '7';
-
- # collect response
- my $buf = '';
- $response = $self->collect($arg, $response, sub {
- die "read timeout" if $timeout && !$sel->can_read($timeout);
- my $n = sysread($socket, $buf, $size);
- die $! unless defined($n);
- return \$buf;
- } );
-
- # Convert menu to HTML and return data to user.
- if ($gophertype eq '1' || $gophertype eq '7') {
- my $content = menu2html($response->content);
- if (defined $user_arg) {
- $response = $self->collect_once($user_arg, $response, $content);
- }
- else {
- $response->content($content);
- }
- }
-
- $response;
-}
-
-
-sub gopher2url
-{
- my($gophertype, $path, $host, $port) = @_;
-
- my $url;
-
- if ($gophertype eq '8' || $gophertype eq 'T') {
- # telnet session
- $url = $HTTP::URI_CLASS->new($gophertype eq '8' ? 'telnet:':'tn3270:');
- $url->user($path) if defined $path;
- }
- else {
- $path = URI::Escape::uri_escape($path);
- $url = $HTTP::URI_CLASS->new("gopher:/$gophertype$path");
- }
- $url->host($host);
- $url->port($port);
- $url;
-}
-
-sub menu2html {
- my($menu) = @_;
-
- $menu =~ tr/\015//d; # remove carriage return
- my $tmp = <<"EOT";
-<HTML>
-<HEAD>
- <TITLE>Gopher menu</TITLE>
-</HEAD>
-<BODY>
-<H1>Gopher menu</H1>
-EOT
- for (split("\n", $menu)) {
- last if /^\./;
- my($pretty, $path, $host, $port) = split("\t");
-
- $pretty =~ s/^(.)//;
- my $type = $1;
-
- my $url = gopher2url($type, $path, $host, $port)->as_string;
- $tmp .= qq{<A HREF="$url">$pretty</A><BR>\n};
- }
- $tmp .= "</BODY>\n</HTML>\n";
- $tmp;
-}
-
-1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/http.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/http.pm
deleted file mode 100644
index 88b4c60df3..0000000000
--- a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/http.pm
+++ /dev/null
@@ -1,523 +0,0 @@
-package LWP::Protocol::http;
-
-use strict;
-
-our $VERSION = '6.61';
-
-require HTTP::Response;
-require HTTP::Status;
-require Net::HTTP;
-
-use parent qw(LWP::Protocol);
-
-our @EXTRA_SOCK_OPTS;
-my $CRLF = "\015\012";
-
-sub _new_socket
-{
- my($self, $host, $port, $timeout) = @_;
-
- # IPv6 literal IP address should be [bracketed] to remove
- # ambiguity between ip address and port number.
- if ( ($host =~ /:/) && ($host !~ /^\[/) ) {
- $host = "[$host]";
- }
-
- local($^W) = 0; # IO::Socket::INET can be noisy
- my $sock = $self->socket_class->new(PeerAddr => $host,
- PeerPort => $port,
- LocalAddr => $self->{ua}{local_address},
- Proto => 'tcp',
- Timeout => $timeout,
- KeepAlive => !!$self->{ua}{conn_cache},
- SendTE => $self->{ua}{send_te},
- $self->_extra_sock_opts($host, $port),
- );
-
- unless ($sock) {
- # IO::Socket::INET leaves additional error messages in $@
- my $status = "Can't connect to $host:$port";
- if ($@ =~ /\bconnect: (.*)/ ||
- $@ =~ /\b(Bad hostname)\b/ ||
- $@ =~ /\b(nodename nor servname provided, or not known)\b/ ||
- $@ =~ /\b(certificate verify failed)\b/ ||
- $@ =~ /\b(Crypt-SSLeay can't verify hostnames)\b/
- ) {
- $status .= " ($1)";
- } elsif ($@) {
- $status .= " ($@)";
- }
- die "$status\n\n$@";
- }
-
- # perl 5.005's IO::Socket does not have the blocking method.
- eval { $sock->blocking(0); };
-
- $sock;
-}
-
-sub socket_type
-{
- return "http";
-}
-
-sub socket_class
-{
- my $self = shift;
- (ref($self) || $self) . "::Socket";
-}
-
-sub _extra_sock_opts # to be overridden by subclass
-{
- return @EXTRA_SOCK_OPTS;
-}
-
-sub _check_sock
-{
- #my($self, $req, $sock) = @_;
-}
-
-sub _get_sock_info
-{
- my($self, $res, $sock) = @_;
- if (defined(my $peerhost = $sock->peerhost)) {
- $res->header("Client-Peer" => "$peerhost:" . $sock->peerport);
- }
-}
-
-sub _fixup_header
-{
- my($self, $h, $url, $proxy) = @_;
-
- # Extract 'Host' header
- my $hhost = $url->authority;
- if ($hhost =~ s/^([^\@]*)\@//) { # get rid of potential "user:pass@"
- # add authorization header if we need them. HTTP URLs do
- # not really support specification of user and password, but
- # we allow it.
- if (defined($1) && not $h->header('Authorization')) {
- require URI::Escape;
- $h->authorization_basic(map URI::Escape::uri_unescape($_),
- split(":", $1, 2));
- }
- }
- $h->init_header('Host' => $hhost);
-
- if ($proxy && $url->scheme ne 'https') {
- # Check the proxy URI's userinfo() for proxy credentials
- # export http_proxy="http://proxyuser:proxypass@proxyhost:port".
- # For https only the initial CONNECT requests needs authorization.
- my $p_auth = $proxy->userinfo();
- if(defined $p_auth) {
- require URI::Escape;
- $h->proxy_authorization_basic(map URI::Escape::uri_unescape($_),
- split(":", $p_auth, 2))
- }
- }
-}
-
-sub hlist_remove {
- my($hlist, $k) = @_;
- $k = lc $k;
- for (my $i = @$hlist - 2; $i >= 0; $i -= 2) {
- next unless lc($hlist->[$i]) eq $k;
- splice(@$hlist, $i, 2);
- }
-}
-
-sub request
-{
- my($self, $request, $proxy, $arg, $size, $timeout) = @_;
-
- $size ||= 4096;
-
- # check method
- my $method = $request->method;
- unless ($method =~ /^[A-Za-z0-9_!\#\$%&\'*+\-.^\`|~]+$/) { # HTTP token
- return HTTP::Response->new( HTTP::Status::RC_BAD_REQUEST,
- 'Library does not allow method ' .
- "$method for 'http:' URLs");
- }
-
- my $url = $request->uri;
-
- # Proxying SSL with a http proxy needs issues a CONNECT request to build a
- # tunnel and then upgrades the tunnel to SSL. But when doing keep-alive the
- # https request does not need to be the first request in the connection, so
- # we need to distinguish between
- # - not yet connected (create socket and ssl upgrade)
- # - connected but not inside ssl tunnel (ssl upgrade)
- # - inside ssl tunnel to the target - once we are in the tunnel to the
- # target we cannot only reuse the tunnel for more https requests with the
- # same target
-
- my $ssl_tunnel = $proxy && $url->scheme eq 'https'
- && $url->host.":".$url->port;
-
- my ($host,$port) = $proxy
- ? ($proxy->host,$proxy->port)
- : ($url->host,$url->port);
- my $fullpath =
- $method eq 'CONNECT' ? $url->host . ":" . $url->port :
- $proxy && ! $ssl_tunnel ? $url->as_string :
- do {
- my $path = $url->path_query;
- $path = "/$path" if $path !~m{^/};
- $path
- };
-
- my $socket;
- my $conn_cache = $self->{ua}{conn_cache};
- my $cache_key;
- if ( $conn_cache ) {
- $cache_key = "$host:$port";
- # For https we reuse the socket immediately only if it has an established
- # tunnel to the target. Otherwise a CONNECT request followed by an SSL
- # upgrade need to be done first. The request itself might reuse an
- # existing non-ssl connection to the proxy
- $cache_key .= "!".$ssl_tunnel if $ssl_tunnel;
- if ( $socket = $conn_cache->withdraw($self->socket_type,$cache_key)) {
- if ($socket->can_read(0)) {
- # if the socket is readable, then either the peer has closed the
- # connection or there are some garbage bytes on it. In either
- # case we abandon it.
- $socket->close;
- $socket = undef;
- } # else use $socket
- else {
- $socket->timeout($timeout);
- }
- }
- }
-
- if ( ! $socket && $ssl_tunnel ) {
- my $proto_https = LWP::Protocol::create('https',$self->{ua})
- or die "no support for scheme https found";
-
- # only if ssl socket class is IO::Socket::SSL we can upgrade
- # a plain socket to SSL. In case of Net::SSL we fall back to
- # the old version
- if ( my $upgrade_sub = $proto_https->can('_upgrade_sock')) {
- my $response = $self->request(
- HTTP::Request->new('CONNECT',"http://$ssl_tunnel"),
- $proxy,
- undef,$size,$timeout
- );
- $response->is_success or die
- "establishing SSL tunnel failed: ".$response->status_line;
- $socket = $upgrade_sub->($proto_https,
- $response->{client_socket},$url)
- or die "SSL upgrade failed: $@";
- } else {
- $socket = $proto_https->_new_socket($url->host,$url->port,$timeout);
- }
- }
-
- if ( ! $socket ) {
- # connect to remote site w/o reusing established socket
- $socket = $self->_new_socket($host, $port, $timeout );
- }
-
- my $http_version = "";
- if (my $proto = $request->protocol) {
- if ($proto =~ /^(?:HTTP\/)?(1.\d+)$/) {
- $http_version = $1;
- $socket->http_version($http_version);
- $socket->send_te(0) if $http_version eq "1.0";
- }
- }
-
- $self->_check_sock($request, $socket);
-
- my @h;
- my $request_headers = $request->headers->clone;
- $self->_fixup_header($request_headers, $url, $proxy);
-
- $request_headers->scan(sub {
- my($k, $v) = @_;
- $k =~ s/^://;
- $v =~ tr/\n/ /;
- push(@h, $k, $v);
- });
-
- my $content_ref = $request->content_ref;
- $content_ref = $$content_ref if ref($$content_ref);
- my $chunked;
- my $has_content;
-
- if (ref($content_ref) eq 'CODE') {
- my $clen = $request_headers->header('Content-Length');
- $has_content++ if $clen;
- unless (defined $clen) {
- push(@h, "Transfer-Encoding" => "chunked");
- $has_content++;
- $chunked++;
- }
- }
- else {
- # Set (or override) Content-Length header
- my $clen = $request_headers->header('Content-Length');
- if (defined($$content_ref) && length($$content_ref)) {
- $has_content = length($$content_ref);
- if (!defined($clen) || $clen ne $has_content) {
- if (defined $clen) {
- warn "Content-Length header value was wrong, fixed";
- hlist_remove(\@h, 'Content-Length');
- }
- push(@h, 'Content-Length' => $has_content);
- }
- }
- elsif ($clen) {
- warn "Content-Length set when there is no content, fixed";
- hlist_remove(\@h, 'Content-Length');
- }
- }
-
- my $write_wait = 0;
- $write_wait = 2
- if ($request_headers->header("Expect") || "") =~ /100-continue/;
-
- my $req_buf = $socket->format_request($method, $fullpath, @h);
- #print "------\n$req_buf\n------\n";
-
- if (!$has_content || $write_wait || $has_content > 8*1024) {
- WRITE:
- {
- # Since this just writes out the header block it should almost
- # always succeed to send the whole buffer in a single write call.
- my $n = $socket->syswrite($req_buf, length($req_buf));
- unless (defined $n) {
- redo WRITE if $!{EINTR};
- if ($!{EWOULDBLOCK} || $!{EAGAIN}) {
- select(undef, undef, undef, 0.1);
- redo WRITE;
- }
- die "write failed: $!";
- }
- if ($n) {
- substr($req_buf, 0, $n, "");
- }
- else {
- select(undef, undef, undef, 0.5);
- }
- redo WRITE if length $req_buf;
- }
- }
-
- my($code, $mess, @junk);
- my $drop_connection;
-
- if ($has_content) {
- my $eof;
- my $wbuf;
- my $woffset = 0;
- INITIAL_READ:
- if ($write_wait) {
- # skip filling $wbuf when waiting for 100-continue
- # because if the response is a redirect or auth required
- # the request will be cloned and there is no way
- # to reset the input stream
- # return here via the label after the 100-continue is read
- }
- elsif (ref($content_ref) eq 'CODE') {
- my $buf = &$content_ref();
- $buf = "" unless defined($buf);
- $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF
- if $chunked;
- substr($buf, 0, 0) = $req_buf if $req_buf;
- $wbuf = \$buf;
- }
- else {
- if ($req_buf) {
- my $buf = $req_buf . $$content_ref;
- $wbuf = \$buf;
- }
- else {
- $wbuf = $content_ref;
- }
- $eof = 1;
- }
-
- my $fbits = '';
- vec($fbits, fileno($socket), 1) = 1;
-
- WRITE:
- while ($write_wait || $woffset < length($$wbuf)) {
-
- my $sel_timeout = $timeout;
- if ($write_wait) {
- $sel_timeout = $write_wait if $write_wait < $sel_timeout;
- }
- my $time_before;
- $time_before = time if $sel_timeout;
-
- my $rbits = $fbits;
- my $wbits = $write_wait ? undef : $fbits;
- my $sel_timeout_before = $sel_timeout;
- SELECT:
- {
- my $nfound = select($rbits, $wbits, undef, $sel_timeout);
- if ($nfound < 0) {
- if ($!{EINTR} || $!{EWOULDBLOCK} || $!{EAGAIN}) {
- if ($time_before) {
- $sel_timeout = $sel_timeout_before - (time - $time_before);
- $sel_timeout = 0 if $sel_timeout < 0;
- }
- redo SELECT;
- }
- die "select failed: $!";
- }
- }
-
- if ($write_wait) {
- $write_wait -= time - $time_before;
- $write_wait = 0 if $write_wait < 0;
- }
-
- if (defined($rbits) && $rbits =~ /[^\0]/) {
- # readable
- my $buf = $socket->_rbuf;
- my $n = $socket->sysread($buf, 1024, length($buf));
- unless (defined $n) {
- die "read failed: $!" unless $!{EINTR} || $!{EWOULDBLOCK} || $!{EAGAIN};
- # if we get here the rest of the block will do nothing
- # and we will retry the read on the next round
- }
- elsif ($n == 0) {
- # the server closed the connection before we finished
- # writing all the request content. No need to write any more.
- $drop_connection++;
- last WRITE;
- }
- $socket->_rbuf($buf);
- if (!$code && $buf =~ /\015?\012\015?\012/) {
- # a whole response header is present, so we can read it without blocking
- ($code, $mess, @h) = $socket->read_response_headers(laxed => 1,
- junk_out => \@junk,
- );
- if ($code eq "100") {
- $write_wait = 0;
- undef($code);
- goto INITIAL_READ;
- }
- else {
- $drop_connection++;
- last WRITE;
- # XXX should perhaps try to abort write in a nice way too
- }
- }
- }
- if (defined($wbits) && $wbits =~ /[^\0]/) {
- my $n = $socket->syswrite($$wbuf, length($$wbuf), $woffset);
- unless (defined $n) {
- die "write failed: $!" unless $!{EINTR} || $!{EWOULDBLOCK} || $!{EAGAIN};
- $n = 0; # will retry write on the next round
- }
- elsif ($n == 0) {
- die "write failed: no bytes written";
- }
- $woffset += $n;
-
- if (!$eof && $woffset >= length($$wbuf)) {
- # need to refill buffer from $content_ref code
- my $buf = &$content_ref();
- $buf = "" unless defined($buf);
- $eof++ unless length($buf);
- $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF
- if $chunked;
- $wbuf = \$buf;
- $woffset = 0;
- }
- }
- } # WRITE
- }
-
- ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
- unless $code;
- ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
- if $code eq "100";
-
- my $response = HTTP::Response->new($code, $mess);
- my $peer_http_version = $socket->peer_http_version;
- $response->protocol("HTTP/$peer_http_version");
- {
- local $HTTP::Headers::TRANSLATE_UNDERSCORE;
- $response->push_header(@h);
- }
- $response->push_header("Client-Junk" => \@junk) if @junk;
-
- $response->request($request);
- $self->_get_sock_info($response, $socket);
-
- if ($method eq "CONNECT") {
- $response->{client_socket} = $socket; # so it can be picked up
- return $response;
- }
-
- if (my @te = $response->remove_header('Transfer-Encoding')) {
- $response->push_header('Client-Transfer-Encoding', \@te);
- }
- $response->push_header('Client-Response-Num', scalar $socket->increment_response_count);
-
- my $complete;
- $response = $self->collect($arg, $response, sub {
- my $buf = ""; #prevent use of uninitialized value in SSLeay.xs
- my $n;
- READ:
- {
- $n = $socket->read_entity_body($buf, $size);
- unless (defined $n) {
- redo READ if $!{EINTR} || $!{EWOULDBLOCK} || $!{EAGAIN} || $!{ENOTTY};
- die "read failed: $!";
- }
- redo READ if $n == -1;
- }
- $complete++ if !$n;
- return \$buf;
- } );
- $drop_connection++ unless $complete;
-
- @h = $socket->get_trailers;
- if (@h) {
- local $HTTP::Headers::TRANSLATE_UNDERSCORE;
- $response->push_header(@h);
- }
-
- # keep-alive support
- unless ($drop_connection) {
- if ($cache_key) {
- my %connection = map { (lc($_) => 1) }
- split(/\s*,\s*/, ($response->header("Connection") || ""));
- if (($peer_http_version eq "1.1" && !$connection{close}) ||
- $connection{"keep-alive"})
- {
- $conn_cache->deposit($self->socket_type, $cache_key, $socket);
- }
- }
- }
-
- $response;
-}
-
-
-#-----------------------------------------------------------
-package # hide from PAUSE
- LWP::Protocol::http::SocketMethods;
-
-sub ping {
- my $self = shift;
- !$self->can_read(0);
-}
-
-sub increment_response_count {
- my $self = shift;
- return ++${*$self}{'myhttp_response_count'};
-}
-
-#-----------------------------------------------------------
-package # hide from PAUSE
- LWP::Protocol::http::Socket;
-
-use parent -norequire, qw(LWP::Protocol::http::SocketMethods Net::HTTP);
-
-1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/loopback.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/loopback.pm
deleted file mode 100644
index a1b095ea70..0000000000
--- a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/loopback.pm
+++ /dev/null
@@ -1,27 +0,0 @@
-package LWP::Protocol::loopback;
-
-use strict;
-
-our $VERSION = '6.61';
-
-require HTTP::Response;
-
-use parent qw(LWP::Protocol);
-
-sub request {
- my($self, $request, $proxy, $arg, $size, $timeout) = @_;
-
- my $response = HTTP::Response->new(200, "OK");
- $response->content_type("message/http; msgtype=request");
-
- $response->header("Via", "loopback/1.0 $proxy")
- if $proxy;
-
- $response->header("X-Arg", $arg);
- $response->header("X-Read-Size", $size);
- $response->header("X-Timeout", $timeout);
-
- return $self->collect_once($arg, $response, $request->as_string);
-}
-
-1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/mailto.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/mailto.pm
deleted file mode 100644
index 29f934bb26..0000000000
--- a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/mailto.pm
+++ /dev/null
@@ -1,184 +0,0 @@
-package LWP::Protocol::mailto;
-
-# This module implements the mailto protocol. It is just a simple
-# frontend to the Unix sendmail program except on MacOS, where it uses
-# Mail::Internet.
-
-require HTTP::Request;
-require HTTP::Response;
-require HTTP::Status;
-
-use Carp;
-use strict;
-
-our $VERSION = '6.61';
-
-use parent qw(LWP::Protocol);
-our $SENDMAIL;
-
-unless ($SENDMAIL = $ENV{SENDMAIL}) {
- for my $sm (qw(/usr/sbin/sendmail
- /usr/lib/sendmail
- /usr/ucblib/sendmail
- ))
- {
- if (-x $sm) {
- $SENDMAIL = $sm;
- last;
- }
- }
- die "Can't find the 'sendmail' program" unless $SENDMAIL;
-}
-
-sub request
-{
- my($self, $request, $proxy, $arg, $size) = @_;
-
- my ($mail, $addr) if $^O eq "MacOS";
- my @text = () if $^O eq "MacOS";
-
- # check proxy
- if (defined $proxy)
- {
- return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
- 'You can not proxy with mail');
- }
-
- # check method
- my $method = $request->method;
-
- if ($method ne 'POST') {
- return HTTP::Response->new( HTTP::Status::RC_BAD_REQUEST,
- 'Library does not allow method ' .
- "$method for 'mailto:' URLs");
- }
-
- # check url
- my $url = $request->uri;
-
- my $scheme = $url->scheme;
- if ($scheme ne 'mailto') {
- return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR,
- "LWP::Protocol::mailto::request called for '$scheme'");
- }
- if ($^O eq "MacOS") {
- eval {
- require Mail::Internet;
- };
- if($@) {
- return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR,
- "You don't have MailTools installed");
- }
- unless ($ENV{SMTPHOSTS}) {
- return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR,
- "You don't have SMTPHOSTS defined");
- }
- }
- else {
- unless (-x $SENDMAIL) {
- return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR,
- "You don't have $SENDMAIL");
- }
- }
- if ($^O eq "MacOS") {
- $mail = Mail::Internet->new or
- return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR,
- "Can't get a Mail::Internet object");
- }
- else {
- open(SENDMAIL, "| $SENDMAIL -oi -t") or
- return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR,
- "Can't run $SENDMAIL: $!");
- }
- if ($^O eq "MacOS") {
- $addr = $url->encoded822addr;
- }
- else {
- $request = $request->clone; # we modify a copy
- my @h = $url->headers; # URL headers override those in the request
- while (@h) {
- my $k = shift @h;
- my $v = shift @h;
- next unless defined $v;
- if (lc($k) eq "body") {
- $request->content($v);
- }
- else {
- $request->push_header($k => $v);
- }
- }
- }
- if ($^O eq "MacOS") {
- $mail->add(To => $addr);
- $mail->add(split(/[:\n]/,$request->headers_as_string));
- }
- else {
- print SENDMAIL $request->headers_as_string;
- print SENDMAIL "\n";
- }
- my $content = $request->content;
- if (defined $content) {
- my $contRef = ref($content) ? $content : \$content;
- if (ref($contRef) eq 'SCALAR') {
- if ($^O eq "MacOS") {
- @text = split("\n",$$contRef);
- foreach (@text) {
- $_ .= "\n";
- }
- }
- else {
- print SENDMAIL $$contRef;
- }
-
- }
- elsif (ref($contRef) eq 'CODE') {
- # Callback provides data
- my $d;
- if ($^O eq "MacOS") {
- my $stuff = "";
- while (length($d = &$contRef)) {
- $stuff .= $d;
- }
- @text = split("\n",$stuff);
- foreach (@text) {
- $_ .= "\n";
- }
- }
- else {
- print SENDMAIL $d;
- }
- }
- }
- if ($^O eq "MacOS") {
- $mail->body(\@text);
- unless ($mail->smtpsend) {
- return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR,
- "Mail::Internet->smtpsend unable to send message to <$addr>");
- }
- }
- else {
- unless (close(SENDMAIL)) {
- my $err = $! ? "$!" : "Exit status $?";
- return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR,
- "$SENDMAIL: $err");
- }
- }
-
-
- my $response = HTTP::Response->new(HTTP::Status::RC_ACCEPTED,
- "Mail accepted");
- $response->header('Content-Type', 'text/plain');
- if ($^O eq "MacOS") {
- $response->header('Server' => "Mail::Internet $Mail::Internet::VERSION");
- $response->content("Message sent to <$addr>\n");
- }
- else {
- $response->header('Server' => $SENDMAIL);
- my $to = $request->header("To");
- $response->content("Message sent to <$to>\n");
- }
-
- return $response;
-}
-
-1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/nntp.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/nntp.pm
deleted file mode 100644
index 1042cd40c3..0000000000
--- a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/nntp.pm
+++ /dev/null
@@ -1,150 +0,0 @@
-package LWP::Protocol::nntp;
-
-# Implementation of the Network News Transfer Protocol (RFC 977)
-
-use parent qw(LWP::Protocol);
-
-our $VERSION = '6.61';
-
-require HTTP::Response;
-require HTTP::Status;
-require Net::NNTP;
-
-use strict;
-
-
-sub request {
- my ($self, $request, $proxy, $arg, $size, $timeout) = @_;
-
- $size = 4096 unless $size;
-
- # Check for proxy
- if (defined $proxy) {
- return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
- 'You can not proxy through NNTP');
- }
-
- # Check that the scheme is as expected
- my $url = $request->uri;
- my $scheme = $url->scheme;
- unless ($scheme eq 'news' || $scheme eq 'nntp') {
- return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR,
- "LWP::Protocol::nntp::request called for '$scheme'");
- }
-
- # check for a valid method
- my $method = $request->method;
- unless ($method eq 'GET' || $method eq 'HEAD' || $method eq 'POST') {
- return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
- 'Library does not allow method ' . "$method for '$scheme:' URLs");
- }
-
- # extract the identifier and check against posting to an article
- my $groupart = $url->_group;
- my $is_art = $groupart =~ /@/;
-
- if ($is_art && $method eq 'POST') {
- return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
- "Can't post to an article <$groupart>");
- }
-
- my $nntp = Net::NNTP->new(
- $url->host,
-
- #Port => 18574,
- Timeout => $timeout,
-
- #Debug => 1,
- );
- die "Can't connect to nntp server" unless $nntp;
-
- # Check the initial welcome message from the NNTP server
- if ($nntp->status != 2) {
- return HTTP::Response->new(HTTP::Status::RC_SERVICE_UNAVAILABLE,
- $nntp->message);
- }
- my $response = HTTP::Response->new(HTTP::Status::RC_OK, "OK");
-
- my $mess = $nntp->message;
-
- # Try to extract server name from greeting message.
- # Don't know if this works well for a large class of servers, but
- # this works for our server.
- $mess =~ s/\s+ready\b.*//;
- $mess =~ s/^\S+\s+//;
- $response->header(Server => $mess);
-
- # First we handle posting of articles
- if ($method eq 'POST') {
- $nntp->quit;
- $nntp = undef;
- $response->code(HTTP::Status::RC_NOT_IMPLEMENTED);
- $response->message("POST not implemented yet");
- return $response;
- }
-
- # The method must be "GET" or "HEAD" by now
- if (!$is_art) {
- if (!$nntp->group($groupart)) {
- $response->code(HTTP::Status::RC_NOT_FOUND);
- $response->message($nntp->message);
- }
- $nntp->quit;
- $nntp = undef;
-
- # HEAD: just check if the group exists
- if ($method eq 'GET' && $response->is_success) {
- $response->code(HTTP::Status::RC_NOT_IMPLEMENTED);
- $response->message("GET newsgroup not implemented yet");
- }
- return $response;
- }
-
- # Send command to server to retrieve an article (or just the headers)
- my $get = $method eq 'HEAD' ? "head" : "article";
- my $art = $nntp->$get("<$groupart>");
- unless ($art) {
- $nntp->quit;
- $response->code(HTTP::Status::RC_NOT_FOUND);
- $response->message($nntp->message);
- $nntp = undef;
- return $response;
- }
-
- # Parse headers
- my ($key, $val);
- local $_;
- while ($_ = shift @$art) {
- if (/^\s+$/) {
- last; # end of headers
- }
- elsif (/^(\S+):\s*(.*)/) {
- $response->push_header($key, $val) if $key;
- ($key, $val) = ($1, $2);
- }
- elsif (/^\s+(.*)/) {
- next unless $key;
- $val .= $1;
- }
- else {
- unshift(@$art, $_);
- last;
- }
- }
- $response->push_header($key, $val) if $key;
-
- # Ensure that there is a Content-Type header
- $response->header("Content-Type", "text/plain")
- unless $response->header("Content-Type");
-
- # Collect the body
- $response = $self->collect_once($arg, $response, join("", @$art)) if @$art;
-
- # Say goodbye to the server
- $nntp->quit;
- $nntp = undef;
-
- $response;
-}
-
-1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/nogo.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/nogo.pm
deleted file mode 100644
index dcc54cfc7d..0000000000
--- a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/nogo.pm
+++ /dev/null
@@ -1,25 +0,0 @@
-package LWP::Protocol::nogo;
-# If you want to disable access to a particular scheme, use this
-# class and then call
-# LWP::Protocol::implementor(that_scheme, 'LWP::Protocol::nogo');
-# For then on, attempts to access URLs with that scheme will generate
-# a 500 error.
-
-use strict;
-
-our $VERSION = '6.61';
-
-require HTTP::Response;
-require HTTP::Status;
-use parent qw(LWP::Protocol);
-
-sub request {
- my($self, $request) = @_;
- my $scheme = $request->uri->scheme;
-
- return HTTP::Response->new(
- HTTP::Status::RC_INTERNAL_SERVER_ERROR,
- "Access to \'$scheme\' URIs has been disabled"
- );
-}
-1;