diff options
Diffstat (limited to 'Master/tlpkg/tlperl/site/lib/LWP/Protocol')
-rw-r--r-- | Master/tlpkg/tlperl/site/lib/LWP/Protocol/GHTTP.pm | 73 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/site/lib/LWP/Protocol/cpan.pm | 12 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/site/lib/LWP/Protocol/data.pm | 12 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/site/lib/LWP/Protocol/file.pm | 23 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/site/lib/LWP/Protocol/ftp.pm | 647 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/site/lib/LWP/Protocol/gopher.pm | 16 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/site/lib/LWP/Protocol/http.pm | 22 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/site/lib/LWP/Protocol/loopback.pm | 6 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/site/lib/LWP/Protocol/mailto.pm | 29 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/site/lib/LWP/Protocol/nntp.pm | 129 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/site/lib/LWP/Protocol/nogo.pm | 11 |
11 files changed, 455 insertions, 525 deletions
diff --git a/Master/tlpkg/tlperl/site/lib/LWP/Protocol/GHTTP.pm b/Master/tlpkg/tlperl/site/lib/LWP/Protocol/GHTTP.pm deleted file mode 100644 index 2a356b5fcb1..00000000000 --- a/Master/tlpkg/tlperl/site/lib/LWP/Protocol/GHTTP.pm +++ /dev/null @@ -1,73 +0,0 @@ -package LWP::Protocol::GHTTP; - -# You can tell LWP to use this module for 'http' requests by running -# code like this before you make requests: -# -# require LWP::Protocol::GHTTP; -# LWP::Protocol::implementor('http', 'LWP::Protocol::GHTTP'); -# - -use strict; -use vars qw(@ISA); - -require LWP::Protocol; -@ISA=qw(LWP::Protocol); - -require HTTP::Response; -require HTTP::Status; - -use HTTP::GHTTP qw(METHOD_GET METHOD_HEAD METHOD_POST); - -my %METHOD = -( - GET => METHOD_GET, - HEAD => METHOD_HEAD, - POST => METHOD_POST, -); - -sub request -{ - my($self, $request, $proxy, $arg, $size, $timeout) = @_; - - my $method = $request->method; - unless (exists $METHOD{$method}) { - return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, - "Bad method '$method'"); - } - - my $r = HTTP::GHTTP->new($request->uri); - - # XXX what headers for repeated headers here? - $request->headers->scan(sub { $r->set_header(@_)}); - - $r->set_type($METHOD{$method}); - - # XXX should also deal with subroutine content. - my $cref = $request->content_ref; - $r->set_body($$cref) if length($$cref); - - # XXX is this right - $r->set_proxy($proxy->as_string) if $proxy; - - $r->process_request; - - my $response = HTTP::Response->new($r->get_status); - - # XXX How can get the headers out of $r?? This way is too stupid. - my @headers; - eval { - # Wrapped in eval because this method is not always available - @headers = $r->get_headers; - }; - @headers = qw(Date Connection Server Content-type - Accept-Ranges Server - Content-Length Last-Modified ETag) if $@; - for (@headers) { - my $v = $r->get_header($_); - $response->header($_ => $v) if defined $v; - } - - return $self->collect_once($arg, $response, $r->get_body); -} - -1; diff --git a/Master/tlpkg/tlperl/site/lib/LWP/Protocol/cpan.pm b/Master/tlpkg/tlperl/site/lib/LWP/Protocol/cpan.pm index 66d8f213b98..3288abdbc12 100644 --- a/Master/tlpkg/tlperl/site/lib/LWP/Protocol/cpan.pm +++ b/Master/tlpkg/tlperl/site/lib/LWP/Protocol/cpan.pm @@ -1,10 +1,8 @@ package LWP::Protocol::cpan; - +$LWP::Protocol::cpan::VERSION = '6.25'; use strict; -use vars qw(@ISA); -require LWP::Protocol; -@ISA = qw(LWP::Protocol); +use base qw(LWP::Protocol); require URI; require HTTP::Status; @@ -49,14 +47,14 @@ sub request { # check proxy if (defined $proxy) { - return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, + 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, + return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST, 'Library does not allow method ' . "$method for 'cpan:' URLs"); } @@ -64,7 +62,7 @@ sub request { my $path = $request->uri->path; $path =~ s,^/,,; - my $response = HTTP::Response->new(&HTTP::Status::RC_FOUND); + my $response = HTTP::Response->new(HTTP::Status::RC_FOUND); $response->header("Location" => URI->new_abs($path, $CPAN)); $response; } diff --git a/Master/tlpkg/tlperl/site/lib/LWP/Protocol/data.pm b/Master/tlpkg/tlperl/site/lib/LWP/Protocol/data.pm index c29c3b4f919..3b256528a4f 100644 --- a/Master/tlpkg/tlperl/site/lib/LWP/Protocol/data.pm +++ b/Master/tlpkg/tlperl/site/lib/LWP/Protocol/data.pm @@ -1,15 +1,13 @@ package LWP::Protocol::data; - +$LWP::Protocol::data::VERSION = '6.25'; # Implements access to data:-URLs as specified in RFC 2397 use strict; -use vars qw(@ISA); require HTTP::Response; require HTTP::Status; -require LWP::Protocol; -@ISA = qw(LWP::Protocol); +use base qw(LWP::Protocol); use HTTP::Date qw(time2str); require LWP; # needs version number @@ -21,20 +19,20 @@ sub request # check proxy if (defined $proxy) { - return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST, + 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, + 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 $response = HTTP::Response->new( HTTP::Status::RC_OK, "Document follows"); my $media_type = $url->media_type; diff --git a/Master/tlpkg/tlperl/site/lib/LWP/Protocol/file.pm b/Master/tlpkg/tlperl/site/lib/LWP/Protocol/file.pm index f2887f4b2f3..e83149dbd90 100644 --- a/Master/tlpkg/tlperl/site/lib/LWP/Protocol/file.pm +++ b/Master/tlpkg/tlperl/site/lib/LWP/Protocol/file.pm @@ -1,7 +1,6 @@ package LWP::Protocol::file; - -require LWP::Protocol; -@ISA = qw(LWP::Protocol); +$LWP::Protocol::file::VERSION = '6.25'; +use base qw(LWP::Protocol); use strict; @@ -21,14 +20,14 @@ sub request # check proxy if (defined $proxy) { - return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST, + 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, + return HTTP::Response->new( HTTP::Status::RC_BAD_REQUEST, 'Library does not allow method ' . "$method for 'file:' URLs"); } @@ -38,7 +37,7 @@ sub request my $scheme = $url->scheme; if ($scheme ne 'file') { - return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR, + return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR, "LWP::Protocol::file::request called for '$scheme'"); } @@ -47,11 +46,11 @@ sub request # test file exists and is readable unless (-e $path) { - return HTTP::Response->new( &HTTP::Status::RC_NOT_FOUND, + return HTTP::Response->new( HTTP::Status::RC_NOT_FOUND, "File `$path' does not exist"); } unless (-r _) { - return HTTP::Response->new( &HTTP::Status::RC_FORBIDDEN, + return HTTP::Response->new( HTTP::Status::RC_FORBIDDEN, 'User does not have read permission'); } @@ -67,13 +66,13 @@ sub request if (defined $ims) { my $time = HTTP::Date::str2time($ims); if (defined $time and $time >= $mtime) { - return HTTP::Response->new( &HTTP::Status::RC_NOT_MODIFIED, + 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 ); + my $response = HTTP::Response->new( HTTP::Status::RC_OK ); # fill in response headers $response->header('Last-Modified', HTTP::Date::time2str($mtime)); @@ -81,7 +80,7 @@ sub request 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, + return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR, "Cannot read directory '$path': $!"); my(@files) = sort readdir(D); closedir(D); @@ -128,7 +127,7 @@ sub request # read the file if ($method ne "HEAD") { open(F, $path) or return new - HTTP::Response(&HTTP::Status::RC_INTERNAL_SERVER_ERROR, + HTTP::Response(HTTP::Status::RC_INTERNAL_SERVER_ERROR, "Cannot read file '$path': $!"); binmode(F); $response = $self->collect($arg, $response, sub { diff --git a/Master/tlpkg/tlperl/site/lib/LWP/Protocol/ftp.pm b/Master/tlpkg/tlperl/site/lib/LWP/Protocol/ftp.pm index f478c6ee732..2a96c1b7c55 100644 --- a/Master/tlpkg/tlperl/site/lib/LWP/Protocol/ftp.pm +++ b/Master/tlpkg/tlperl/site/lib/LWP/Protocol/ftp.pm @@ -1,115 +1,114 @@ package LWP::Protocol::ftp; - +$LWP::Protocol::ftp::VERSION = '6.25'; # Implementation of the ftp protocol (RFC 959). We let the Net::FTP # package do all the dirty work. +use base qw(LWP::Protocol); +use strict; -use Carp (); - -use HTTP::Status (); +use Carp (); +use HTTP::Status (); use HTTP::Negotiate (); -use HTTP::Response (); +use HTTP::Response (); use LWP::MediaTypes (); -use File::Listing (); +use File::Listing (); -require LWP::Protocol; -@ISA = qw(LWP::Protocol); -use strict; -eval { +{ + package LWP::Protocol::MyFTP; +$LWP::Protocol::MyFTP::VERSION = '6.25'; +use strict; + use base qw(Net::FTP); - require Net::FTP; - Net::FTP->require_version(2.00); + sub new { + my $class = shift; - use vars qw(@ISA); - @ISA=qw(Net::FTP); + my $self = $class->SUPER::new(@_) || return undef; - sub new { - my $class = shift; + my $mess = $self->message; # welcome message + $mess =~ s|\n.*||s; # only first line left + $mess =~ s|\s*ready\.?$||; - my $self = $class->SUPER::new(@_) || return undef; + # Make the version number more HTTP like + $mess =~ s|\s*\(Version\s*|/| and $mess =~ s|\)$||; + ${*$self}{myftp_server} = $mess; - 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); + #$response->header("Server", $mess); - $self; + $self; } sub http_server { - my $self = shift; - ${*$self}{myftp_server}; + my $self = shift; + ${*$self}{myftp_server}; } sub home { - my $self = shift; - my $old = ${*$self}{myftp_home}; - if (@_) { - ${*$self}{myftp_home} = shift; - } - $old; + 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}); + my $self = shift; + $self->cwd(${*$self}{myftp_home}); } sub request_count { - my $self = shift; - ++${*$self}{myftp_reqcount}; + my $self = shift; + ++${*$self}{myftp_reqcount}; } sub ping { - my $self = shift; - return $self->go_home; + my $self = shift; + return $self->go_home; } - -}; -my $init_failed = $@; - +} sub _connect { - my($self, $host, $port, $user, $account, $password, $timeout) = @_; + 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; - } - } + $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}, - ); + 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, $@); + $@ =~ 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; + + # 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; @@ -121,38 +120,30 @@ sub _connect { } -sub request -{ - my($self, $request, $proxy, $arg, $size, $timeout) = @_; +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'); + 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'"); + 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"); - } - - if ($init_failed) { - return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR, - $init_failed); + return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST, + 'Library does not allow method ' . "$method for 'ftp:' URLs"); } my $host = $url->host; @@ -163,272 +154,290 @@ sub request # 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; - } + 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! + 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); + 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 @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=//; - } + my @params; + ($remote_file, @params) = @$remote_file; + for (@params) { + $type = $_ if s/^type=//; + } } if ($type && $type eq 'a') { - $ftp->ascii; + $ftp->ascii; } else { - $ftp->binary; + $ftp->binary; } for (@path) { - unless ($ftp->cwd($_)) { - return HTTP::Response->new(&HTTP::Status::RC_NOT_FOUND, - "Can't chdir to $_"); - } + 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 - { - } + 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; } - - 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; - } + ); + } + + # 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; - } + + # 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"); + return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST, + "Illegal method $method"); } $response; diff --git a/Master/tlpkg/tlperl/site/lib/LWP/Protocol/gopher.pm b/Master/tlpkg/tlperl/site/lib/LWP/Protocol/gopher.pm index db6c0bfba9d..e6fe5ce8473 100644 --- a/Master/tlpkg/tlperl/site/lib/LWP/Protocol/gopher.pm +++ b/Master/tlpkg/tlperl/site/lib/LWP/Protocol/gopher.pm @@ -1,5 +1,5 @@ package LWP::Protocol::gopher; - +$LWP::Protocol::gopher::VERSION = '6.25'; # Implementation of the gopher protocol (RFC 1436) # # This code is based on 'wwwgopher.pl,v 0.10 1994/10/17 18:12:34 shelden' @@ -8,15 +8,13 @@ package LWP::Protocol::gopher; # including contributions from Marc van Heyningen and Martijn Koster. use strict; -use vars qw(@ISA); require HTTP::Response; require HTTP::Status; require IO::Socket; require IO::Select; -require LWP::Protocol; -@ISA = qw(LWP::Protocol); +use base qw(LWP::Protocol); my %gopher2mimetype = ( @@ -47,7 +45,7 @@ sub request # check proxy if (defined $proxy) { - return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, + return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST, 'You can not proxy through the gopher'); } @@ -57,19 +55,19 @@ sub request my $method = $request->method; unless ($method eq 'GET' || $method eq 'HEAD') { - return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, + 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, + 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"); + my $response = HTTP::Response->new(HTTP::Status::RC_OK, "OK"); $response->header('Content-type' => $gopher2mimetype{$gophertype} || 'text/plain'); $response->header('Content-Encoding' => $gopher2encoding{$gophertype}) @@ -80,7 +78,7 @@ sub request $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"); diff --git a/Master/tlpkg/tlperl/site/lib/LWP/Protocol/http.pm b/Master/tlpkg/tlperl/site/lib/LWP/Protocol/http.pm index 23c361f7055..2266b1e9ea6 100644 --- a/Master/tlpkg/tlperl/site/lib/LWP/Protocol/http.pm +++ b/Master/tlpkg/tlperl/site/lib/LWP/Protocol/http.pm @@ -1,16 +1,14 @@ package LWP::Protocol::http; - +$LWP::Protocol::http::VERSION = '6.25'; use strict; require HTTP::Response; require HTTP::Status; require Net::HTTP; -use vars qw(@ISA @EXTRA_SOCK_OPTS); - -require LWP::Protocol; -@ISA = qw(LWP::Protocol); +use base qw(LWP::Protocol); +our @EXTRA_SOCK_OPTS; my $CRLF = "\015\012"; sub _new_socket @@ -39,6 +37,7 @@ sub _new_socket 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/ ) { @@ -131,7 +130,7 @@ sub request # check method my $method = $request->method; unless ($method =~ /^[A-Za-z0-9_!\#\$%&\'*+\-.^\`|~]+$/) { # HTTP token - return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST, + return HTTP::Response->new( HTTP::Status::RC_BAD_REQUEST, 'Library does not allow method ' . "$method for 'http:' URLs"); } @@ -168,7 +167,7 @@ sub request my $cache_key; if ( $conn_cache ) { $cache_key = "$host:$port"; - # For https we reuse the socket immediatly only if it has an established + # 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 @@ -181,6 +180,9 @@ sub request $socket->close; $socket = undef; } # else use $socket + else { + $socket->timeout($timeout); + } } } @@ -496,7 +498,7 @@ sub request #----------------------------------------------------------- package LWP::Protocol::http::SocketMethods; - +$LWP::Protocol::http::SocketMethods::VERSION = '6.25'; sub ping { my $self = shift; !$self->can_read(0); @@ -509,7 +511,7 @@ sub increment_response_count { #----------------------------------------------------------- package LWP::Protocol::http::Socket; -use vars qw(@ISA); -@ISA = qw(LWP::Protocol::http::SocketMethods Net::HTTP); +$LWP::Protocol::http::Socket::VERSION = '6.25'; +use base qw(LWP::Protocol::http::SocketMethods Net::HTTP); 1; diff --git a/Master/tlpkg/tlperl/site/lib/LWP/Protocol/loopback.pm b/Master/tlpkg/tlperl/site/lib/LWP/Protocol/loopback.pm index 2cd67ae3608..f1e4c9f918e 100644 --- a/Master/tlpkg/tlperl/site/lib/LWP/Protocol/loopback.pm +++ b/Master/tlpkg/tlperl/site/lib/LWP/Protocol/loopback.pm @@ -1,11 +1,9 @@ package LWP::Protocol::loopback; - +$LWP::Protocol::loopback::VERSION = '6.25'; use strict; -use vars qw(@ISA); require HTTP::Response; -require LWP::Protocol; -@ISA = qw(LWP::Protocol); +use base qw(LWP::Protocol); sub request { my($self, $request, $proxy, $arg, $size, $timeout) = @_; diff --git a/Master/tlpkg/tlperl/site/lib/LWP/Protocol/mailto.pm b/Master/tlpkg/tlperl/site/lib/LWP/Protocol/mailto.pm index 46db7162e44..9358695d57d 100644 --- a/Master/tlpkg/tlperl/site/lib/LWP/Protocol/mailto.pm +++ b/Master/tlpkg/tlperl/site/lib/LWP/Protocol/mailto.pm @@ -1,19 +1,18 @@ package LWP::Protocol::mailto; - +$LWP::Protocol::mailto::VERSION = '6.25'; # 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 LWP::Protocol; require HTTP::Request; require HTTP::Response; require HTTP::Status; use Carp; use strict; -use vars qw(@ISA $SENDMAIL); -@ISA = qw(LWP::Protocol); +use base qw(LWP::Protocol); +our $SENDMAIL; unless ($SENDMAIL = $ENV{SENDMAIL}) { for my $sm (qw(/usr/sbin/sendmail @@ -39,7 +38,7 @@ sub request # check proxy if (defined $proxy) { - return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, + return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST, 'You can not proxy with mail'); } @@ -47,7 +46,7 @@ sub request my $method = $request->method; if ($method ne 'POST') { - return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST, + return HTTP::Response->new( HTTP::Status::RC_BAD_REQUEST, 'Library does not allow method ' . "$method for 'mailto:' URLs"); } @@ -57,7 +56,7 @@ sub request my $scheme = $url->scheme; if ($scheme ne 'mailto') { - return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR, + return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR, "LWP::Protocol::mailto::request called for '$scheme'"); } if ($^O eq "MacOS") { @@ -65,28 +64,28 @@ sub request require Mail::Internet; }; if($@) { - return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR, + 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, + 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, + 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, + 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, + return HTTP::Response->new( HTTP::Status::RC_INTERNAL_SERVER_ERROR, "Can't run $SENDMAIL: $!"); } if ($^O eq "MacOS") { @@ -151,20 +150,20 @@ sub request if ($^O eq "MacOS") { $mail->body(\@text); unless ($mail->smtpsend) { - return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR, + 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, + return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR, "$SENDMAIL: $err"); } } - my $response = HTTP::Response->new(&HTTP::Status::RC_ACCEPTED, + my $response = HTTP::Response->new(HTTP::Status::RC_ACCEPTED, "Mail accepted"); $response->header('Content-Type', 'text/plain'); if ($^O eq "MacOS") { diff --git a/Master/tlpkg/tlperl/site/lib/LWP/Protocol/nntp.pm b/Master/tlpkg/tlperl/site/lib/LWP/Protocol/nntp.pm index 788477d488a..9727a247a51 100644 --- a/Master/tlpkg/tlperl/site/lib/LWP/Protocol/nntp.pm +++ b/Master/tlpkg/tlperl/site/lib/LWP/Protocol/nntp.pm @@ -1,9 +1,8 @@ package LWP::Protocol::nntp; - +$LWP::Protocol::nntp::VERSION = '6.25'; # Implementation of the Network News Transfer Protocol (RFC 977) -require LWP::Protocol; -@ISA = qw(LWP::Protocol); +use base qw(LWP::Protocol); require HTTP::Response; require HTTP::Status; @@ -12,56 +11,57 @@ require Net::NNTP; use strict; -sub request -{ - my($self, $request, $proxy, $arg, $size, $timeout) = @_; +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'); + 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 $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'"); + 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"); + 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 =~ /@/; + 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>"); + 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, - ); + 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); + return HTTP::Response->new(HTTP::Status::RC_SERVICE_UNAVAILABLE, + $nntp->message); } - my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK"); + my $response = HTTP::Response->new(HTTP::Status::RC_OK, "OK"); my $mess = $nntp->message; @@ -74,66 +74,69 @@ sub request # 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; + $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; + 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; $nntp = undef; - $response->code(&HTTP::Status::RC_NOT_FOUND); - $response->message($nntp->message); - return $response; + $nntp->quit; + $response->code(HTTP::Status::RC_NOT_FOUND); + $response->message($nntp->message); + $nntp = undef; + return $response; } # Parse headers - my($key, $val); + 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; - } + 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"); + unless $response->header("Content-Type"); # Collect the body - $response = $self->collect_once($arg, $response, join("", @$art)) - if @$art; + $response = $self->collect_once($arg, $response, join("", @$art)) if @$art; # Say goodbye to the server $nntp->quit; diff --git a/Master/tlpkg/tlperl/site/lib/LWP/Protocol/nogo.pm b/Master/tlpkg/tlperl/site/lib/LWP/Protocol/nogo.pm index 68150a722d5..a9b0e411ee7 100644 --- a/Master/tlpkg/tlperl/site/lib/LWP/Protocol/nogo.pm +++ b/Master/tlpkg/tlperl/site/lib/LWP/Protocol/nogo.pm @@ -4,20 +4,19 @@ package LWP::Protocol::nogo; # LWP::Protocol::implementor(that_scheme, 'LWP::Protocol::nogo'); # For then on, attempts to access URLs with that scheme will generate # a 500 error. - +$LWP::Protocol::nogo::VERSION = '6.25'; use strict; -use vars qw(@ISA); + require HTTP::Response; require HTTP::Status; -require LWP::Protocol; -@ISA = qw(LWP::Protocol); +use base qw(LWP::Protocol); sub request { my($self, $request) = @_; my $scheme = $request->uri->scheme; - + return HTTP::Response->new( - &HTTP::Status::RC_INTERNAL_SERVER_ERROR, + HTTP::Status::RC_INTERNAL_SERVER_ERROR, "Access to \'$scheme\' URIs has been disabled" ); } |