summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/site/lib/LWP/Protocol
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/site/lib/LWP/Protocol')
-rw-r--r--Master/tlpkg/tlperl/site/lib/LWP/Protocol/GHTTP.pm73
-rw-r--r--Master/tlpkg/tlperl/site/lib/LWP/Protocol/cpan.pm12
-rw-r--r--Master/tlpkg/tlperl/site/lib/LWP/Protocol/data.pm12
-rw-r--r--Master/tlpkg/tlperl/site/lib/LWP/Protocol/file.pm23
-rw-r--r--Master/tlpkg/tlperl/site/lib/LWP/Protocol/ftp.pm647
-rw-r--r--Master/tlpkg/tlperl/site/lib/LWP/Protocol/gopher.pm16
-rw-r--r--Master/tlpkg/tlperl/site/lib/LWP/Protocol/http.pm22
-rw-r--r--Master/tlpkg/tlperl/site/lib/LWP/Protocol/loopback.pm6
-rw-r--r--Master/tlpkg/tlperl/site/lib/LWP/Protocol/mailto.pm29
-rw-r--r--Master/tlpkg/tlperl/site/lib/LWP/Protocol/nntp.pm129
-rw-r--r--Master/tlpkg/tlperl/site/lib/LWP/Protocol/nogo.pm11
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"
);
}