Change history for libwww-perl
-6.18 2017-02-02
+6.19 2017-02-14
+ - Call HTTP::Status constant functions without & (GH#110)
+ - Make bin scripts use LWP's version and not maintain their own (PR #54)
+ - Fix bug triggered in some cases of auth challenges not having a viable
+ protocol (PR#111)
+ - Remove usage of the 'vars' pragma (GH#113)
+
+6.18 2017-02-03
- Update "timeout" when reusing sockets (PR#90)
- Fix bug triggered when calling simple_request() with a malformed URL
(PR#108)
"Gisle Aas <gisle@activestate.com>"
],
"dynamic_config" : 0,
- "generated_by" : "ExtUtils::MakeMaker version 7.1001, CPAN::Meta::Converter version 2.150005",
+ "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150005",
"license" : [
"perl_5"
],
"x_IRC" : "irc://irc.perl.org/#lwp",
"x_MailingList" : "mailto:libwww@perl.org"
},
- "version" : "6.18",
+ "version" : "6.19",
"x_authority" : "cpan:LWWWP",
"x_serialization_backend" : "JSON::PP version 2.27300"
}
File::Copy: '0'
Getopt::Long: '0'
dynamic_config: 0
-generated_by: 'ExtUtils::MakeMaker version 7.1001, CPAN::Meta::Converter version 2.150005'
+generated_by: 'ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150005'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
MailingList: mailto:libwww@perl.org
bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=libwww-perl
repository: https://github.com/libwww-perl/libwww-perl.git
-version: '6.18'
+version: '6.19'
x_authority: cpan:LWWWP
x_serialization_backend: 'CPAN::Meta::YAML version 0.018'
my $url = URI->new(decode(locale => shift) || usage());
my $argfile = encode(locale_fs => decode(locale => shift));
usage() if defined($argfile) && !length($argfile);
-my $VERSION = "6.18";
my $ua = LWP::UserAgent->new(
- agent => "lwp-download/$VERSION ",
+ agent => "lwp-download/$LWP::UserAgent::VERSION ",
keep_alive => 1,
env_proxy => 1,
);
use Encode;
use Encode::Locale;
-my $VERSION = "6.18";
-
GetOptions(\my %opt,
'parse-head',
'max-length=n',
parse_head => $opt{'parse-head'} || 0,
keep_alive => 1,
env_proxy => 1,
- agent => $opt{agent} || "lwp-dump/$VERSION ",
+ agent => $opt{agent} || "lwp-dump/$LWP::UserAgent::VERSION ",
);
my $req = HTTP::Request->new($opt{method} || 'GET' => decode(locale => $url));
$progname =~ s,.*/,,; # use basename only
$progname =~ s/\.\w*$//; #strip extension if any
-$VERSION = "6.18";
-
$opt_h = undef; # print usage
$opt_v = undef; # print version
$opt_t = undef; # timeout
require LWP;
my $DISTNAME = 'libwww-perl-' . LWP::Version();
die <<"EOT";
-This is lwp-mirror version $VERSION ($DISTNAME)
+This is lwp-mirror version $LWP::Simple::VERSION ($DISTNAME)
Copyright 1995-1999, Gisle Aas.
$progname =~ s,.*[\\/],,; # use basename only
$progname =~ s/\.\w*$//; # strip extension, if any
-$VERSION = "6.18";
-
-
require LWP;
use URI;
sub new
{
my $self = LWP::UserAgent::new(@_);
- $self->agent("lwp-request/$main::VERSION ");
+ $self->agent("lwp-request/$LWP::VERSION ");
$self;
}
require LWP;
my $DISTNAME = 'libwww-perl-' . LWP::Version();
die <<"EOT";
-This is lwp-request version $VERSION ($DISTNAME)
+This is lwp-request version $LWP::VERSION ($DISTNAME)
Copyright 1995-1999, Gisle Aas.
package LWP;
-our $VERSION = '6.18';
+our $VERSION = '6.19';
+
sub Version { $VERSION; }
require 5.008;
use strict;
-our $VERSION = '6.18';
+our $VERSION = '6.19';
use Authen::NTLM "1.02";
use MIME::Base64 "2.12";
package LWP::ConnCache;
use strict;
-use vars qw($DEBUG);
-
-our $VERSION = '6.18';
+our $VERSION = '6.19';
+our $DEBUG;
sub new {
my($class, %cnf) = @_;
use base 'LWP::MemberMixin';
-our $VERSION = '6.18';
+our $VERSION = '6.19';
use strict;
use Carp ();
package LWP::Protocol::cpan;
use strict;
-use vars qw(@ISA);
-require LWP::Protocol;
-@ISA = qw(LWP::Protocol);
+use base qw(LWP::Protocol);
require URI;
require HTTP::Status;
# 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");
}
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;
}
# 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
# 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;
package LWP::Protocol::file;
-require LWP::Protocol;
-@ISA = qw(LWP::Protocol);
+use base qw(LWP::Protocol);
use strict;
# 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");
}
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'");
}
# 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');
}
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));
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);
# 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 {
use LWP::MediaTypes ();
use File::Listing ();
-require LWP::Protocol;
-@ISA = qw(LWP::Protocol);
+use base qw(LWP::Protocol);
use strict;
eval {
require Net::FTP;
Net::FTP->require_version(2.00);
- use vars qw(@ISA);
- @ISA=qw(Net::FTP);
+ use base qw(Net::FTP);
sub new {
my $class = shift;
# 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, $@);
+ 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);
+ 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;
# 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 ftp');
}
my $url = $request->uri;
if ($url->scheme ne 'ftp') {
my $scheme = $url->scheme;
- return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+ return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR,
"LWP::Protocol::ftp::request called for '$scheme'");
}
my $method = $request->method;
unless ($method eq 'GET' || $method eq 'HEAD' || $method eq 'PUT') {
- 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 'ftp:' URLs");
}
if ($init_failed) {
- return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+ return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR,
$init_failed);
}
return $ftp if ref($ftp) eq "HTTP::Response"; # ugh!
# Create an initial response object
- my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
+ 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);
for (@path) {
unless ($ftp->cwd($_)) {
- return HTTP::Response->new(&HTTP::Status::RC_NOT_FOUND,
+ return HTTP::Response->new(HTTP::Status::RC_NOT_FOUND,
"Can't chdir to $_");
}
}
$response->last_modified($mod_time);
if (my $ims = $request->if_modified_since) {
if ($mod_time <= $ims) {
- $response->code(&HTTP::Status::RC_NOT_MODIFIED);
+ $response->code(HTTP::Status::RC_NOT_MODIFIED);
$response->message("Not modified");
return $response;
}
}
}
- # We'll use this later to abort the transfer if necessary.
+ # 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;
}
else {
- return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+ 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,
+ return HTTP::Response->new(HTTP::Status::RC_NOT_IMPLEMENTED,
"Server does not support resume.");
}
# 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->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,
+ return HTTP::Response->new(HTTP::Status::RC_NOT_FOUND,
"File '$remote_file' not found");
}
my $content = '';
if (!defined($prefer)) {
- return HTTP::Response->new(&HTTP::Status::RC_NOT_ACCEPTABLE,
+ return HTTP::Response->new(HTTP::Status::RC_NOT_ACCEPTABLE,
"Neither HTML nor directory listing wanted");
}
elsif ($prefer eq 'html') {
}
}
else {
- my $res = HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+ my $res = HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
"FTP return code " . $ftp->code);
$res->content_type("text/plain");
$res->content($ftp->message);
elsif ($method eq 'PUT') {
# method must be PUT
unless (length($remote_file)) {
- return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+ return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
"Must have a file name to PUT to");
}
my $data;
}
$data->close;
- $response->code(&HTTP::Status::RC_CREATED);
+ $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,
+ my $res = HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
"FTP return code " . $ftp->code);
$res->content_type("text/plain");
$res->content($ftp->message);
}
}
else {
- return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+ return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
"Illegal method $method");
}
# 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 = (
# 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');
}
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})
$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");
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
# 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");
}
#-----------------------------------------------------------
package LWP::Protocol::http::Socket;
-use vars qw(@ISA);
-@ISA = qw(LWP::Protocol::http::SocketMethods Net::HTTP);
+use base qw(LWP::Protocol::http::SocketMethods Net::HTTP);
1;
package LWP::Protocol::loopback;
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) = @_;
# 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
# 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');
}
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");
}
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") {
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") {
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") {
# 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;
# Check for 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 NNTP');
}
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,
+ 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,
+ return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
'Library does not allow method ' .
"$method for '$scheme:' URLs");
}
my $is_art = $groupart =~ /@/;
if ($is_art && $method eq 'POST') {
- return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+ return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
"Can't post to an article <$groupart>");
}
# Check the initial welcome message from the NNTP server
if ($nntp->status != 2) {
- return HTTP::Response->new(&HTTP::Status::RC_SERVICE_UNAVAILABLE,
+ 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;
# First we handle posting of articles
if ($method eq 'POST') {
$nntp->quit; $nntp = undef;
- $response->code(&HTTP::Status::RC_NOT_IMPLEMENTED);
+ $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->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->code(HTTP::Status::RC_NOT_IMPLEMENTED);
$response->message("GET newsgroup not implemented yet");
}
return $response;
my $art = $nntp->$get("<$groupart>");
unless ($art) {
$nntp->quit; $nntp = undef;
- $response->code(&HTTP::Status::RC_NOT_FOUND);
+ $response->code(HTTP::Status::RC_NOT_FOUND);
$response->message($nntp->message);
return $response;
}
# a 500 error.
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"
);
}
package LWP::RobotUA;
use base qw(LWP::UserAgent);
-our $VERSION = '6.18';
+
+our $VERSION = '6.19';
require WWW::RobotRules;
require HTTP::Request;
# Check rules
unless ($allowed) {
my $res = HTTP::Response->new(
- &HTTP::Status::RC_FORBIDDEN, 'Forbidden by robots.txt');
+ HTTP::Status::RC_FORBIDDEN, 'Forbidden by robots.txt');
$res->request( $request ); # bind it to that request
return $res;
}
}
else {
my $res = HTTP::Response->new(
- &HTTP::Status::RC_SERVICE_UNAVAILABLE, 'Please, slow down');
+ HTTP::Status::RC_SERVICE_UNAVAILABLE, 'Please, slow down');
$res->header('Retry-After', time2str(time + $wait));
$res->request( $request ); # bind it to that request
return $res;
package LWP::Simple;
use strict;
-use vars qw($ua %loop_check $FULL_LWP @EXPORT @EXPORT_OK);
+
+our $VERSION = '6.19';
require Exporter;
-@EXPORT = qw(get head getprint getstore mirror);
-@EXPORT_OK = qw($ua);
+our @EXPORT = qw(get head getprint getstore mirror);
+our @EXPORT_OK = qw($ua);
# I really hate this. It was a bad idea to do it in the first place.
# Wonder how to get rid of it??? (It even makes LWP::Simple 7% slower
use HTTP::Status;
push(@EXPORT, @HTTP::Status::EXPORT);
-our $VERSION = '6.18';
-
sub import
{
my $pkg = shift;
}
use LWP::UserAgent ();
-use HTTP::Status ();
use HTTP::Date ();
-$ua = LWP::UserAgent->new; # we create a global UserAgent object
+
+our $ua = LWP::UserAgent->new; # we create a global UserAgent object
$ua->agent("LWP::Simple/$VERSION ");
$ua->env_proxy;
-
sub get ($)
{
my $response = $ua->get(shift);
use strict;
use base qw(LWP::MemberMixin);
-our $VERSION = '6.18';
use Carp ();
use HTTP::Request ();
use Scalar::Util qw(blessed);
use Try::Tiny qw(try catch);
+our $VERSION = '6.19';
sub new
{
catch {
my $error = $_;
$error =~ s/ at .* line \d+.*//s; # remove file/line number
- $response = _new_response($request, &HTTP::Status::RC_NOT_IMPLEMENTED, $error);
+ $response = _new_response($request, HTTP::Status::RC_NOT_IMPLEMENTED, $error);
if ($scheme eq "https") {
$response->message($response->message . " (LWP::Protocol::https not installed)");
$response->content_type("text/plain");
my $full = $error;
(my $status = $error) =~ s/\n.*//s;
$status =~ s/ at .* line \d+.*//s; # remove file/line number
- my $code = ($status =~ s/^(\d\d\d)\s+//) ? $1 : &HTTP::Status::RC_INTERNAL_SERVER_ERROR;
+ my $code = ($status =~ s/^(\d\d\d)\s+//) ? $1 : HTTP::Status::RC_INTERNAL_SERVER_ERROR;
$response = _new_response($request, $code, $status, $full);
}
};
};
if ($error) {
- return _new_response($request, &HTTP::Status::RC_BAD_REQUEST, $error);
+ return _new_response($request, HTTP::Status::RC_BAD_REQUEST, $error);
}
return $self->send_request($request, $arg, $size);
}
-sub request
-{
- my($self, $request, $arg, $size, $previous) = @_;
+sub request {
+ my ($self, $request, $arg, $size, $previous) = @_;
my $response = $self->simple_request($request, $arg, $size);
$response->previous($previous) if $previous;
if ($response->redirects >= $self->{max_redirect}) {
$response->header("Client-Warning" =>
- "Redirect loop detected (max_redirect = $self->{max_redirect})");
+ "Redirect loop detected (max_redirect = $self->{max_redirect})"
+ );
return $response;
}
my $code = $response->code;
- if ($code == &HTTP::Status::RC_MOVED_PERMANENTLY or
- $code == &HTTP::Status::RC_FOUND or
- $code == &HTTP::Status::RC_SEE_OTHER or
- $code == &HTTP::Status::RC_TEMPORARY_REDIRECT)
+ if ( $code == HTTP::Status::RC_MOVED_PERMANENTLY
+ or $code == HTTP::Status::RC_FOUND
+ or $code == HTTP::Status::RC_SEE_OTHER
+ or $code == HTTP::Status::RC_TEMPORARY_REDIRECT)
{
- my $referral = $request->clone;
-
- # These headers should never be forwarded
- $referral->remove_header('Host', 'Cookie');
-
- if ($referral->header('Referer') &&
- $request->uri->scheme eq 'https' &&
- $referral->uri->scheme eq 'http')
- {
- # RFC 2616, section 15.1.3.
- # https -> http redirect, suppressing Referer
- $referral->remove_header('Referer');
- }
+ my $referral = $request->clone;
+
+ # These headers should never be forwarded
+ $referral->remove_header('Host', 'Cookie');
- if ($code == &HTTP::Status::RC_SEE_OTHER ||
- $code == &HTTP::Status::RC_FOUND)
+ if ( $referral->header('Referer')
+ && $request->uri->scheme eq 'https'
+ && $referral->uri->scheme eq 'http')
{
- my $method = uc($referral->method);
- unless ($method eq "GET" || $method eq "HEAD") {
- $referral->method("GET");
- $referral->content("");
- $referral->remove_content_headers;
- }
- }
+ # RFC 2616, section 15.1.3.
+ # https -> http redirect, suppressing Referer
+ $referral->remove_header('Referer');
+ }
- # And then we update the URL based on the Location:-header.
- my $referral_uri = $response->header('Location');
- {
- # Some servers erroneously return a relative URL for redirects,
- # so make it absolute if it not already is.
- local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1;
- my $base = $response->base;
- $referral_uri = "" unless defined $referral_uri;
- $referral_uri = $HTTP::URI_CLASS->new($referral_uri, $base)
- ->abs($base);
- }
- $referral->uri($referral_uri);
+ if ( $code == HTTP::Status::RC_SEE_OTHER
+ || $code == HTTP::Status::RC_FOUND)
+ {
+ my $method = uc($referral->method);
+ unless ($method eq "GET" || $method eq "HEAD") {
+ $referral->method("GET");
+ $referral->content("");
+ $referral->remove_content_headers;
+ }
+ }
+
+ # And then we update the URL based on the Location:-header.
+ my $referral_uri = $response->header('Location');
+ {
+ # Some servers erroneously return a relative URL for redirects,
+ # so make it absolute if it not already is.
+ local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1;
+ my $base = $response->base;
+ $referral_uri = "" unless defined $referral_uri;
+ $referral_uri
+ = $HTTP::URI_CLASS->new($referral_uri, $base)->abs($base);
+ }
+ $referral->uri($referral_uri);
- return $response unless $self->redirect_ok($referral, $response);
- return $self->request($referral, $arg, $size, $response);
+ return $response unless $self->redirect_ok($referral, $response);
+ return $self->request($referral, $arg, $size, $response);
}
- elsif ($code == &HTTP::Status::RC_UNAUTHORIZED ||
- $code == &HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED
- )
+ elsif ($code == HTTP::Status::RC_UNAUTHORIZED
+ || $code == HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED)
{
- my $proxy = ($code == &HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED);
- my $ch_header = $proxy || $request->method eq 'CONNECT'
- ? "Proxy-Authenticate" : "WWW-Authenticate";
- my @challenge = $response->header($ch_header);
- unless (@challenge) {
- $response->header("Client-Warning" =>
- "Missing Authenticate header");
- return $response;
- }
+ my $proxy = ($code == HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED);
+ my $ch_header
+ = $proxy || $request->method eq 'CONNECT'
+ ? "Proxy-Authenticate"
+ : "WWW-Authenticate";
+ my @challenges = $response->header($ch_header);
+ unless (@challenges) {
+ $response->header(
+ "Client-Warning" => "Missing Authenticate header");
+ return $response;
+ }
- require HTTP::Headers::Util;
- CHALLENGE: for my $challenge (@challenge) {
- $challenge =~ tr/,/;/; # "," is used to separate auth-params!!
- ($challenge) = HTTP::Headers::Util::split_header_words($challenge);
- my $scheme = shift(@$challenge);
- shift(@$challenge); # no value
- $challenge = { @$challenge }; # make rest into a hash
-
- unless ($scheme =~ /^([a-z]+(?:-[a-z]+)*)$/) {
- $response->header("Client-Warning" =>
- "Bad authentication scheme '$scheme'");
- return $response;
- }
- $scheme = $1; # untainted now
- my $class = "LWP::Authen::\u$scheme";
- $class =~ s/-/_/g;
-
- no strict 'refs';
- unless (%{"$class\::"}) {
- # try to load it
- try {
- (my $req = $class) =~ s{::}{/}g;
- $req .= '.pm' unless $req =~ /\.pm$/;
- require $req;
+ require HTTP::Headers::Util;
+ CHALLENGE: for my $challenge (@challenges) {
+ $challenge =~ tr/,/;/; # "," is used to separate auth-params!!
+ ($challenge) = HTTP::Headers::Util::split_header_words($challenge);
+ my $scheme = shift(@$challenge);
+ shift(@$challenge); # no value
+ $challenge = {@$challenge}; # make rest into a hash
+
+ unless ($scheme =~ /^([a-z]+(?:-[a-z]+)*)$/) {
+ $response->header(
+ "Client-Warning" => "Bad authentication scheme '$scheme'");
+ return $response;
+ }
+ $scheme = $1; # untainted now
+ my $class = "LWP::Authen::\u$scheme";
+ $class =~ s/-/_/g;
+
+ no strict 'refs';
+ unless (%{"$class\::"}) {
+ # try to load it
+ my $error;
+ try {
+ (my $req = $class) =~ s{::}{/}g;
+ $req .= '.pm' unless $req =~ /\.pm$/;
+ require $req;
+ }
+ catch {
+ $error = $_;
+ };
+ if ($error) {
+ if ($error =~ /^Can\'t locate/) {
+ $response->header("Client-Warning" =>
+ "Unsupported authentication scheme '$scheme'");
+ }
+ else {
+ $response->header("Client-Warning" => $error);
+ }
+ next CHALLENGE;
+ }
+ }
+ unless ($class->can("authenticate")) {
+ $response->header("Client-Warning" =>
+ "Unsupported authentication scheme '$scheme'");
+ next CHALLENGE;
+ }
+ return $class->authenticate($self, $proxy, $challenge, $response,
+ $request, $arg, $size);
}
- catch {
- my $error = $_;
- if ($error =~ /^Can\'t locate/) {
- $response->header("Client-Warning" =>
- "Unsupported authentication scheme '$scheme'");
- }
- else {
- $response->header("Client-Warning" => $error);
- }
- next CHALLENGE;
- };
- }
- unless ($class->can("authenticate")) {
- $response->header("Client-Warning" =>
- "Unsupported authentication scheme '$scheme'");
- next CHALLENGE;
- }
- return $class->authenticate($self, $proxy, $challenge, $response,
- $request, $arg, $size);
- }
- return $response;
+ return $response;
}
return $response;
}
-
#
# Now the shortcuts...
#
return $self->default_headers->header(@_);
}
-sub _agent { "libwww-perl/$LWP::VERSION" }
+sub _agent { "libwww-perl/$VERSION" }
sub agent {
my $self = shift;
projects / platform / upstream / perl-libwww-perl.git / commitdiff