@@ -1,3 +1,141 @@
+2008-07-25 Gisle Aas <gisle@ActiveState.com>
+
+ Release 5.814
+
+ Gisle Aas (13):
+ Typo fix.
+ Add HTTP::Message::decodable()
+ Use decoded_content in the synposis
+ Avoid adding an empty first part in $mess->add_part()
+ Get rid of all the manual dependency tests.
+ Simplify the Makefile.PL (no interactivity)
+ Provide DELETE method in HTTP::Request::Common [RT#37481]
+ Checkbox picks up nearby text in description of alternates [RT#36771]
+ HTML::Form::possible_values() should not returned disabled values [RT#35248]
+ File::Listing documentation claimed only 'unix' format was supported [RT#22021]
+ File::Listing only support English locales [RT#28879]
+ Make common-req.t use Test.pm
+ Typo; CAN_TALK_TO_OUTSELF
+
+ Bill Mann (1):
+ Fix up File::Listings fallback to dosftp [RT#23540]
+
+ Hans-H. Froehlich (1):
+ File::Listing parse failure on BSD Linux based systems [RT#26724]
+
+
+
+2008-06-17 Gisle Aas <gisle@ActiveState.com>
+
+ Release 5.813
+
+ Ville Skytta (3):
+ RobotUA constructor ignores delay, use_sleep [RT#35456]
+ Spelling fixes [RT#35457]
+ Add HTTP::Response->filename [RT#35458]
+
+ Mark Stosberg (2):
+ Better diagnostics when the HTML::TokeParser constructor fails [RT#35607]
+ Multiple forms with same-named <select> parse wrongly [RT#35607]
+
+ Gisle Aas (1):
+ Provide a progress method that does something that might be useful.
+
+ Spiros Denaxas (1):
+ Documentation typo fix [RT#36132]
+
+
+
+2008-04-16 Gisle Aas <gisle@ActiveState.com>
+
+ Release 5.812
+
+ Gisle Aas (6):
+ Typo fix.
+ Simplified Net::HTTP::Methods constructor call.
+ Croak if Net::HTTP constructor called with no argument.
+ Avoid calling $self->peerport to figure out what the port is.
+ 5.811 breaks SSL requests [RT#35090]
+ Make test suite compatible with perl-5.6.1.
+
+ Toru Yamaguchi (1):
+ Wrong treatment of qop value in Digest Authentication [RT#35055]
+
+
+
+2008-04-14 Gisle Aas <gisle@ActiveState.com>
+
+ Release 5.811
+
+ Gisle Aas (6):
+ Avoid "used only once" warning for $Config::Config.
+ Make HTTP::Request::Common::PUT set Content-Length header [RT#34772]
+ Added the add_content_utf8 method to HTTP::Message.
+ Typo fix.
+ Retry syscalls when they fail with EINTR or EAGAIN [RT#34093,32356]
+ Allow HTTP::Content content that can be downgraded to bytes.
+
+ Gavin Peters (1):
+ HTML::Form does not recognise multiple select items with same name [RT#18993]
+
+ Mark Stosberg (1):
+ Document how HTTP::Status codes correspond to the classification functions [RT#20819]
+
+ Robert Stone (1):
+ Allow 100, 204, 304 responses to have content [RT#17907]
+
+ sasao (1):
+ HTTP::Request::Common::POST suppressed filename="0" in Content-Disposition [RT#18887]
+
+
+
+2008-04-08 Gisle Aas <gisle@ActiveState.com>
+
+ Release 5.810
+
+ Gisle Aas (10):
+ Small documentation issues [RT#31346]
+ Explain $netloc argument to $ua->credentials [RT#31969]
+ Make lwp-request honour option -b while dumping links [RT#31347]
+ Ignore params for date convenience methods [RT#30579]
+ Get rid of all the old CVS $Keyword:...$ templates. Set $VERSION to 5.810.
+ Update Copyright year.
+ Drop some sample URLs that were failing.
+ Complement the HTTP::Status codes [RT#29619]
+ Don't allow HTTP::Message content to be set to Unicode strings.
+ Refactor test for Encode.pm
+
+ Ville Skytta (3):
+ Spelling fixes [RT#33272]
+ Trigger HTML::HeadParser for XHTML [RT#33271]
+ Escape status line in error_as_HTML, convert to lowercase [RT#33270]
+
+ Alexey Tourbin (2):
+ Typo fix [RT#33843]
+ Protocol/file.pm: postpone load of URI::Escape and HTML::Entities [RT#33842]
+
+ Daniel Hedlund (1):
+ HTML::Form Module and <button> element clicks
+
+ Adam Kennedy (1):
+ HTTP::Cookies handle malformed empty Set-Cookie badly [RT#29401]
+
+ Jacob J (1):
+ [HTTP::Request::Common] Does not handle filenames containing " [RT#30538]
+
+ Rolf Grossmann (1):
+ Allow malformed chars in $mess->decoded_content [RT#17368]
+
+ FWILES (1):
+ Croak if LWP::UserAgent is constructed with hash ref as argument [RT#28597]
+
+ Adam Sjogren (1):
+ Disabled, checked radiobutton being submitted [RT#33512]
+
+ DAVIDRW (1):
+ warn if TextInput's maxlength exceeded [RT#32239]
+
+
2007-08-05 Gisle Aas <gisle@ActiveState.com>
Release 5.808
@@ -80,13 +80,17 @@ t/base/message-old.t Test HTTP::Request/HTTP::Response
t/base/message-parts.t Test HTTP::Message parts method
t/base/negotiate.t Test HTTP::Negotiation module
t/base/protocols.t Test protocol methods of LWP::UserAgent
+t/base/request.t Test additional HTTP::Request methods
t/base/response.t Test additional HTTP::Response methods
t/base/status.t Test HTTP::Status module
t/base/ua.t Basic LWP::UserAgent tests
t/html/form.t Test HTML::Form module
t/html/form-param.t More HTML::Form tests.
+t/html/form-multi-select.t More HTML::Form tests
+t/html/form-maxlength.t More HTML::Form tests
t/live/apache.t
t/live/apache-listing.t Test File::Listing::apache package
+t/live/https.t
t/live/jigsaw-auth-b.t
t/live/jigsaw-auth-d.t
t/live/jigsaw-chunk.t
@@ -118,3 +122,4 @@ t/robot/rules-dbm.t Test WWW::RobotRules::AnyDBM_File
t/robot/rules.t Test WWW::RobotRules
t/robot/ua-get.t
t/robot/ua.t Test LWP::RobotUA
+META.yml Module meta-data (added by MakeMaker)
@@ -0,0 +1,19 @@
+--- #YAML:1.0
+name: libwww-perl
+version: 5.814
+abstract: ~
+license: ~
+author: ~
+generated_by: ExtUtils::MakeMaker version 6.42_01
+distribution_type: module
+requires:
+ Compress::Zlib: 1.10
+ Digest::MD5: 0
+ HTML::Parser: 3.33
+ HTML::Tagset: 0
+ MIME::Base64: 2.1
+ Net::FTP: 2.58
+ URI: 1.10
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.3.html
+ version: 1.3
@@ -1,292 +1,55 @@
-# This -*- perl -*- script writes the Makefile for libwww-perl
-# $Id: Makefile.PL,v 1.77 2007/07/19 20:26:10 gisle Exp $
+#!perl -w
-require 5.005;
+require 5.006;
use strict;
-use ExtUtils::MakeMaker qw(WriteMakefile prompt);
-use Config qw(%Config);
-
-#--- Configuration section ---
-
-my @programs_to_install = qw(lwp-request lwp-mirror lwp-rget lwp-download);
-my @request_aliases = qw(GET HEAD POST);
-
-#--- End Configuration - You should not have to change anything below this line
-
-
-# Allow us to suppress all program installation with the -n (library only)
-# option. This is for those that don't want to mess with the configuration
-# section of this file.
-use Getopt::Std;
-use vars qw($opt_n);
-unless (getopts("n")) {
- die "Usage: $0 [-n]\n";
-}
-@programs_to_install = () if $opt_n || grep /^LIB=/, @ARGV;
-
-# Check if we should try to run tests that talk to ourself
-system(qq("$^X" talk-to-ourself));
-if ($?) {
- print <<EOT;
-
-You appear to have a misconfigured system, so I will disable tests
-that try to talk HTTP to a local server.
-EOT
- unlink("t/CAN_TALK_TO_OURSELF");
-}
-else {
- open(CAN_TALK_TO_OURSELF, ">t/CAN_TALK_TO_OURSELF") || die "Can't create CAN_TALK_TO_OURSELF: $!";
- close(CAN_TALK_TO_OURSELF);
-}
-
-# Check if we should try to run the live tests
-open(CHANGES, "Changes") || die "Can't open Changes: $!";
-my $release_date;
-while (<CHANGES>) {
- if (/^(\d{4}-\d{2}-\d{2})\D/) {
- $release_date = $1;
- last;
- }
-}
-close(CHANGES);
-die "Can't figure out release date" unless $release_date;
-#print "Release date: $release_date\n";
-
-my $some_time_ago = sprintf "%04d-%02d-%02d",
- sub { ($_[5]+1900, $_[4]+1, $_[3])}->(localtime(time - 45 * 24*60*60));
-if ($some_time_ago lt $release_date) {
- # Check if we have internet connection
- require IO::Socket;
- my $s = IO::Socket::INET->new(PeerAddr => "www.google.com:80",
- Timeout => 10,
- );
- if ($s) {
- # XXX could try to send a GET to it???
- close($s);
-
- print <<EOT;
-
-You appear to be directly connected to the Internet. I have some tests
-that tries to access some sites on the net to verify that the new HTTP/1.1
-support works as it should.
-
-EOT
-
- if (prompt("Do you want to enable these tests?", "y") =~ /^y/i) {
- open(ENABLED, ">t/live/ENABLED") || die "Can't enable: $!";
- close(ENABLED);
-
- # Figure out if the compress lib works and signal that with
- # a file for the test suite to find. We don't want the
- # test script to do this 'require' itself because we want
- # to test that the module loads it on demand as it should.
- eval {
- require Compress::Zlib;
- Compress::Zlib->VERSION(1.10);
- open(ZLIB_OK, ">t/live/ZLIB_OK") || die "Can't create ZLIB_OK: $!";
- print ZLIB_OK "$Compress::Zlib::VERSION\n";
- close(ZLIB_OK);
- };
- if ($@) {
- #warn $@;
- unlink("t/live/ZLIB_OK");
- }
- }
- else {
- unlink("t/live/ENABLED");
- }
- }
-}
-
-if (@programs_to_install) {
- print <<EOT;
-
-This package comes with some sample programs that I can try
-to install in $Config{installscript}.
-
- Note that you can avoid these questions by passing
- the '-n' option to 'Makefile.PL'.
-
-EOT
- my @tmp;
- for (@programs_to_install) {
- if (prompt("Do you want to install $_?", "y") =~ /^y/) {
- push(@tmp, $_);
- }
- }
- @programs_to_install = @tmp;
-}
-
-if (grep($_ eq 'lwp-request', @programs_to_install) && @request_aliases) {
- print <<EOT;
-
-The lwp-request program will use the name it is invoked with to
-determine what HTTP method to use. I can set up alias for the most
-common HTTP methods. These alias are also installed in
-$Config{installscript}.
-
-EOT
- my @tmp;
- for my $alias (@request_aliases) {
- my $default = "n";
- if (prompt("Do you want to install the $alias alias?", $default) =~ /^y/) {
- push(@tmp, $alias);
- }
- }
- @request_aliases = @tmp;
-}
-else {
- @request_aliases = ();
-}
-
-# Check for non-standard modules that are used by this library.
-$| = 1;
-my $missing_modules = 0;
-
-print "\nChecking for URI...........";
-eval {
- require URI;
- URI->VERSION(1.10);
-};
-if ($@) {
- print " failed\n";
- $missing_modules++;
- print <<EOT;
-$@
-The URI module must be installed. WWW without URIs would not
-be that great :-)
-
-EOT
- sleep(2); # Don't hurry too much
-}
-else {
- print " ok\n";
-}
-print "Checking for HTML::Parser..";
-eval {
- require HTML::HeadParser;
- HTML::Parser->VERSION(3.33);
-};
-if ($@) {
- print " failed\n";
- $missing_modules++;
- print <<EOT;
-$@
-The HTML::Parser is needed to extract correct base URI information from
-HTML so that we can resolve relative links correctly. The HTML::Form
-module also need HTML::TokeParser to work.
-
-EOT
- sleep(2); # Don't hurry too much
-}
-else {
- print " ok\n";
-}
-
-print "Checking for MIME::Base64..";
-eval {
- require MIME::Base64;
- #MIME::Base64->VERSION('2.00');
-};
-if ($@) {
- print " failed\n";
- $missing_modules++;
- print <<EOT;
-$@
-The Base64 encoding is used in authentication headers in HTTP.
-
-EOT
- sleep(2); # Don't hurry too much
-}
-else {
- print " ok\n";
-}
-
-print "Checking for Net::FTP......";
-eval {
- require Net::FTP;
- Net::FTP->VERSION('2.58');
-};
-if ($@) {
- print " failed\n";
- $missing_modules++;
- print <<EOT;
-$@
-The libwww-perl library normally use the Net::FTP module when
-accessing ftp servers. You would have to install this package or
-configure your application to use a proxy server for making ftp
-requests work. Net::FTP is part of the 'libnet' distribution.
-
-EOT
- sleep(2); # Don't hurry too much
-}
-else {
- print " ok\n";
-}
-
-print "Checking for Digest::MD5 ..";
-eval {
- require Digest::MD5;
+use ExtUtils::MakeMaker qw(WriteMakefile);
+use Getopt::Long qw(GetOptions);
+
+GetOptions(\my %opt,
+ 'aliases',
+ 'no-programs|n',
+ 'live-tests',
+) or do {
+ die "Usage: $0 [--aliases] [--no-programs] [--live-tests]\n";
};
-if ($@) {
- print " failed\n";
- $missing_modules++;
- print <<EOT;
-$@
-The Digest::MD5 library is needed if you want to be able use the
-experimental "Digest Access Authentication" scheme. Since very few
-servers implement this authentication scheme, you should normally not
-worry too much about this.
-EOT
-}
-else {
- print " ok\n";
-}
+my @prog;
+push(@prog, qw(lwp-request lwp-mirror lwp-rget lwp-download))
+ unless $opt{'no-programs'} || grep /^LIB=/, @ARGV;
-print <<EOT if $missing_modules;
-The missing modules can be obtained from CPAN. Visit
-<URL:http://www.perl.com/CPAN/> to find a CPAN site near you.
-
-EOT
-
-print "\n";
-
-if (@request_aliases) {
+if ($opt{'aliases'} && grep(/lwp-request/, @prog)) {
require File::Copy;
- for (@request_aliases) {
+ for (qw(GET HEAD POST)) {
File::Copy::copy("bin/lwp-request", "bin/$_") || die "Can't copy bin/$_";
- chmod(0755, "bin/$_");
- push(@programs_to_install, $_);
+ chmod(0755, "bin/$_");
+ push(@prog, $_);
}
}
-
-# Ok, now it is time to really generate the Makefile
+system($^X, "talk-to-ourself");
+flag_file("t/CAN_TALK_TO_OURSELF", $? == 0);
+flag_file("t/live/ENABLED", $opt{'live-tests'});
WriteMakefile(
- NAME => 'LWP',
- DISTNAME => 'libwww-perl',
- VERSION_FROM => 'lib/LWP.pm',
- EXE_FILES => [ map "bin/$_", @programs_to_install ],
- PREREQ_PM => { 'URI' => "1.10",
- 'MIME::Base64' => "2.1",
- 'Net::FTP' => "2.58",
- 'HTML::Tagset' => 0,
- 'HTML::Parser' => "3.33",
- 'Digest::MD5' => 0,
- 'Compress::Zlib' => "1.10",
- },
- 'clean' => { FILES => join(" ", map "bin/$_", @request_aliases) },
- 'dist' => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
+ NAME => 'LWP',
+ DISTNAME => 'libwww-perl',
+ VERSION_FROM => 'lib/LWP.pm',
+ EXE_FILES => [ map "bin/$_", @prog ],
+ PREREQ_PM => {
+ 'URI' => "1.10",
+ 'MIME::Base64' => "2.1",
+ 'Net::FTP' => "2.58",
+ 'HTML::Tagset' => 0,
+ 'HTML::Parser' => "3.33",
+ 'Digest::MD5' => 0,
+ 'Compress::Zlib' => "1.10",
+ },
+ clean => { FILES => join(" ", map "bin/$_", grep /^[A-Z]+$/, @prog) },
);
+exit;
-
-package MY;
-
-# What happens when we say 'make test'
-sub test
+sub MY::test
{
q(
TEST_VERBOSE=0
@@ -298,22 +61,12 @@ test: all
}
-# Determine things that should *not* be installed
-sub libscan
-{
- my($self, $path) = @_;
- return '' if $path =~ m/\.(pl|dtd|sgml)$/;
- return '' if $path =~ m:\bCVS/:;
- return '' if $path =~ m/~$/;
- $path;
-}
-
-# Pass libwww-perl version number to pod2man
-sub manifypods
-{
- my $self = shift;
- my $ver = $self->{VERSION} || "";
- local($_) = $self->SUPER::manifypods(@_);
- s/pod2man\s*$/pod2man --release libwww-perl-$ver/m;
- $_;
+sub flag_file {
+ my($file, $create) = @_;
+ if ($create) {
+ open(my $fh, ">", $file) || die "Can't create $file: $!";
+ }
+ else {
+ unlink($file);
+ }
}
@@ -10,44 +10,28 @@ and functions that allow you to write WWW clients. The library also
contain modules that are of more general use and even classes that
help you implement simple HTTP servers.
-There are actually two versions of libwww-perl: one for Perl4, and one
-for Perl5. Both have a similar architecture, loosely based on the CERN
-Library of Common Code (nowadays known as 'w3c-libwww').
-
-The Perl4 version was maintained by Roy Fielding, and was the
-basis for tools such as MOMSpider. The perl4 version of libwww-perl
-and much more information about its libraries can still be found at:
-http://www.ics.uci.edu/pub/websoft/libwww-perl/
-
-The Perl5 version (this package) is a complete rewrite for Perl5: the
-code is organized in Modules, provides an Object Oriented API, and
-offers lots of extended functionality.
-
-
PREREQUISITES
In order to install and use this package you will need Perl version
-5.005 or better. Some modules within this package depend on other
+5.6 or better. Some modules within this package depend on other
packages that are distributed separately from Perl. We recommend that
you have the following packages installed before you install
libwww-perl:
URI
MIME-Base64
+ HTML-Tagset
HTML-Parser
libnet
Digest-MD5
Compress-Zlib
-These packages should be available on CPAN (see below).
-
If you want to access sites using the https protocol, then you need to
install the Crypt::SSLeay or the IO::Socket::SSL module. The
README.SSL file will tell you more about how libwww-perl supports SSL.
-
INSTALLATION
You install libwww-perl using the normal perl module distribution drill:
@@ -57,29 +41,16 @@ You install libwww-perl using the normal perl module distribution drill:
make test
make install
-You can edit the configuration section of Makefile.PL to select which
-programs to install in addition to the library itself. If you don't
-want to install any programs (only the library files) and don't want
-to mess with the Makefile.PL then pass the '-n' option to Makefile.PL:
-
- perl Makefile.PL -n
-
-If you want to install a private copy of libwww-perl in your home
-directory, then you should try to produce the initial Makefile with
-something like this command:
-
- perl Makefile.PL LIB=~/perl
-
-The Makefile.PL program will start out by checking your perl
-installation for a few packages that are recommended to be installed
-together with libwww-perl.
+If you don't want to install any programs (only the library files) then
+pass the '--no-programs' option to Makefile.PL:
+ perl Makefile.PL --no-programs
DOCUMENTATION
-See ./lib/LWP.pm for an overview of the library. See ./ChangeLog for
-recent changes.
+See the lib/LWP.pm file for an overview of the library. See the
+Changes file for recent changes.
POD style documentation is included in all modules and scripts. These
are normally converted to manual pages and installed as part of the
@@ -88,35 +59,32 @@ utility to extract and read documentation from the module files
directly.
-
SUPPORT
-Questions about how to use this library should be directed to the
-comp.lang.perl.modules USENET Newsgroup. Bug reports and suggestions
-for improvements can be sent to the <libwww@perl.org> mailing
-list. This mailing list is also the place for general discussions and
-development of the libwww-perl package.
-
-You can join the mailing list by sending a message to
-<libwww-subscribe@perl.org>.
- ^^^^^^^^^^
+Bug reports and suggestions for improvements can be sent to the
+<libwww@perl.org> mailing list. This mailing list is also the place
+for general discussions and development of the libwww-perl package.
AVAILABILITY
-The latest version of libwww-perl should always be available from:
+The latest version of libwww-perl is available from CPAN:
+
+ http://search.cpan.org/dist/libwww-perl/
+
+If you want to hack on the source it might be a good idea to grab the
+latest version with git using the command:
- http://www.linpro.no/lwp/
+ git clone git://gitorious.org/libwww-perl/mainline.git lwp
-The library is also available from the Comprehensive Perl Archive
-Network (CPAN). Visit <URL:http://www.perl.com/CPAN/> to find a CPAN
-site near you.
+You can also browse the git repository at:
+ http://gitorious.org/projects/libwww-perl
COPYRIGHT
- © 1995-2005 Gisle Aas. All rights reserved.
+ © 1995-2008 Gisle Aas. All rights reserved.
© 1995 Martijn Koster. All rights reserved.
This library is free software; you can redistribute it and/or modify
@@ -1,7 +1,5 @@
#!/usr/bin/perl -w
-# $Id: lwp-download,v 2.16 2007/07/19 20:26:11 gisle Exp $
-
=head1 NAME
lwp-download - Fetch large files from the web
@@ -75,11 +73,10 @@ unless (getopts('a', \%opt)) {
my $url = URI->new(shift || usage());
my $argfile = shift;
usage() if defined($argfile) && !length($argfile);
-my $version = q$Revision: 2.16 $;
-$version =~ s/[^\d.]//g;
+my $VERSION = "5.813";
my $ua = LWP::UserAgent->new(
- agent => "lwp-download/$version ",
+ agent => "lwp-download/$VERSION ",
keep_alive => 1,
env_proxy => 1,
);
@@ -108,21 +105,12 @@ my $res = $ua->request(HTTP::Request->new(GET => $url),
}
unless (defined $argfile) {
- # must find a suitable name to use. First thing
- # to do is to look for the "Content-Disposition"
- # header defined by RFC1806. This is also supported
- # by Netscape
- my $cd = $res->header("Content-Disposition");
- if ($cd && $cd =~ /\bfilename\s*=\s*(\S+)/) {
- $file = $1;
- $file =~ s/;$//;
- $file =~ s/^([\"\'])(.*)\1$/$2/;
- $file =~ s,.*[\\/],,; # basename
- }
+ # find a suitable name to use
+ $file = $res->filename;
# if this fails we try to make something from the URL
unless ($file) {
- my $req = $res->request; # now always there
+ my $req = $res->request; # not always there
my $rurl = $req ? $req->url : $url;
$file = ($rurl->path_segments)[-1];
@@ -1,7 +1,5 @@
#!/usr/bin/perl -w
-# $Id: lwp-mirror,v 2.3 2004/04/10 11:19:33 gisle Exp $
-#
# Simple mirror utility using LWP
=head1 NAME
@@ -47,7 +45,7 @@ $progname = $0;
$progname =~ s,.*/,,; # use basename only
$progname =~ s/\.\w*$//; #strip extension if any
-$VERSION = sprintf("%d.%02d", q$Revision: 2.3 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.810";
$opt_h = undef; # print usage
$opt_v = undef; # print version
@@ -1,18 +1,16 @@
#!/usr/bin/perl -w
-# $Id: lwp-request,v 2.8 2007/07/19 20:26:11 gisle Exp $
-#
# Simple user agent using LWP library.
=head1 NAME
-lwp-request - Simple command line user agent
+lwp-request, GET, POST, HEAD - Simple command line user agent
=head1 SYNOPSIS
- lwp-request [-aeEdvhx] [-m method] [-b <base URL>] [-t <timeout>]
- [-i <if-modified-since>] [-c <content-type>] [-C <credentials>]
- [-p <proxy-url>] [-o <format>] <url>...
+B<lwp-request> [B<-afPuUsSedvhx>] [B<-m> I<method>] [B<-b> I<base URL>] [B<-t> I<timeout>]
+ [B<-i> I<if-modified-since>] [B<-c> I<content-type>]
+ [B<-C> I<credentials>] [B<-p> I<proxy-url>] [B<-o> I<format>] I<url>...
=head1 DESCRIPTION
@@ -71,6 +69,10 @@ Set the proxy to be used for the requests. The program also loads
proxy settings from the environment. You can disable this with the
C<-P> option.
+=item -P
+
+Don't load proxy settings from environment.
+
=item -H <header>
Send this HTTP header with each request. You can specify several, e.g.:
@@ -182,7 +184,7 @@ $progname = $0;
$progname =~ s,.*[\\/],,; # use basename only
$progname =~ s/\.\w*$//; # strip extension, if any
-$VERSION = sprintf("%d.%02d", q$Revision: 2.8 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.810";
require LWP;
@@ -473,6 +475,7 @@ while ($url = shift) {
};
$options{'o'} eq 'links' && do {
my $base = $response->base;
+ $base = $options{'b'} if $options{'b'};
for ( @{ $html->extract_links } ) {
my($link, $elem) = @$_;
my $tag = uc $elem->tag;
@@ -527,6 +530,8 @@ Usage: $progname [-options] <url>...
-p <proxyurl> use this as a proxy
-P don't load proxy settings from environment
-H <header> send this HTTP header (you can specify several)
+ -C <username>:<password>
+ provide credentials for basic authentication
-u Display method and URL before any response
-U Display request headers (implies -u)
@@ -152,7 +152,7 @@ my $progname = $0;
$progname =~ s|.*/||; # only basename left
$progname =~ s/\.\w*$//; #strip extension if any
-$VERSION = sprintf("%d.%02d", q$Revision: 2.4 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.810";
#$Getopt::Long::debug = 1;
#$Getopt::Long::ignorecase = 0;
@@ -1,6 +1,6 @@
package Bundle::LWP;
-$VERSION = sprintf("%d.%02d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.810";
1;
@@ -1,9 +1,7 @@
package File::Listing;
-# $Id: Listing.pm,v 1.15 2003/10/26 14:24:22 gisle Exp $
-
sub Version { $VERSION; }
-$VERSION = sprintf("%d.%02d", q$Revision: 1.15 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.814";
require Exporter;
@ISA = qw(Exporter);
@@ -116,8 +114,7 @@ package File::Listing::unix;
use HTTP::Date qw(str2time);
# A place to remember current directory from last line parsed.
-use vars qw($curdir);
-no strict qw(vars);
+use vars qw($curdir @ISA);
@ISA = qw(File::Listing);
@@ -144,7 +141,7 @@ sub line
.* # Graps
\D(\d+) # File size
\s+ # Some space
- (\w{3}\s+\d+\s+(?:\d{1,2}:\d{2}|\d{4})) # Date
+ (\w{3}\s+\d+\s+(?:\d{1,2}:\d{2}|\d{4})|\d{4}-\d{2}-\d{2}\s+\d{2}:\d{2}) # Date
\s+ # Some more space
(.*)$ # File name
/x )
@@ -199,6 +196,7 @@ sub line
}
else {
# parse failed, check if the dosftp parse understands it
+ File::Listing::dosftp->init();
return(File::Listing::dosftp->line($_,$tz,$error));
}
@@ -211,8 +209,7 @@ package File::Listing::dosftp;
use HTTP::Date qw(str2time);
# A place to remember current directory from last line parsed.
-use vars qw($curdir);
-no strict qw(vars);
+use vars qw($curdir @ISA);
@ISA = qw(File::Listing);
@@ -232,11 +229,11 @@ sub line
s/\015//g;
- my ($kind, $size, $date, $name);
+ my ($date, $size_or_dir, $name, $size);
# 02-05-96 10:48AM 1415 src.slf
# 09-10-96 09:18AM <DIR> sl_util
- if (($date,$size_or_dir,$name) =
+ if (($date, $size_or_dir, $name) =
/^(\d\d-\d\d-\d\d\s+\d\d:\d\d\wM) # Date and time info
\s+ # Some space
(<\w{3}>|\d+) # Dir or Size
@@ -255,9 +252,7 @@ sub line
$type = 'f';
$size = $size_or_dir;
}
- return [$name, $type, $size, str2time($date, $tz),
- File::Listing::file_mode($kind)];
-
+ return [$name, $type, $size, str2time($date, $tz), undef];
}
else {
return () unless defined $error;
@@ -280,6 +275,8 @@ package File::Listing::netware;
package File::Listing::apache;
+use vars qw(@ISA);
+
@ISA = qw(File::Listing);
@@ -358,6 +355,7 @@ File::Listing - parse directory listing
=head1 SYNOPSIS
use File::Listing qw(parse_dir);
+ $ENV{LANG} = "C"; # dates in non-English locales not supported
for (parse_dir(`ls -l`)) {
($name, $type, $size, $mtime, $mode) = @$_;
next if $type ne 'f'; # plain file
@@ -371,10 +369,7 @@ File::Listing - parse directory listing
=head1 DESCRIPTION
This module exports a single function called parse_dir(), which can be
-used to parse directory listings. Currently it only understand Unix
-C<'ls -l'> and C<'ls -lR'> format. It should eventually be able to
-most things you might get back from a ftp server file listing (LIST
-command), i.e. VMS listings, NT listings, DOS listings,...
+used to parse directory listings.
The first parameter to parse_dir() is the directory listing to parse.
It can be a scalar, a reference to an array of directory lines or a
@@ -384,10 +379,10 @@ The second parameter is the time zone to use when parsing time stamps
in the listing. If this value is undefined, then the local time zone is
assumed.
-The third parameter is the type of listing to assume. The values will
-be strings like 'unix', 'vms', 'dos'. Currently only 'unix' is
-implemented and this is also the default value. Ideally, the listing
-type should be determined automatically.
+The third parameter is the type of listing to assume. Currently
+supported formats are 'unix', 'apache' and 'dosftp'. The default
+value 'unix'. Ideally, the listing type should be determined
+automatically.
The fourth parameter specifies how unparseable lines should be treated.
Values can be 'ignore', 'warn' or a code reference. Warn means that
@@ -1,13 +1,11 @@
package HTML::Form;
-# $Id: Form.pm,v 1.54 2005/12/07 14:32:27 gisle Exp $
-
use strict;
use URI;
use Carp ();
use vars qw($VERSION);
-$VERSION = sprintf("%d.%03d", q$Revision: 1.54 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.814";
my %form_tags = map {$_ => 1} qw(input textarea button select option);
@@ -17,13 +15,13 @@ my %type2class = (
hidden => "TextInput",
textarea => "TextInput",
- button => "IgnoreInput",
"reset" => "IgnoreInput",
radio => "ListInput",
checkbox => "ListInput",
option => "ListInput",
+ button => "SubmitInput",
submit => "SubmitInput",
image => "ImageInput",
file => "FileInput",
@@ -115,10 +113,7 @@ sub parse
require HTML::TokeParser;
my $p = HTML::TokeParser->new(ref($html) ? $html->decoded_content(ref => 1) : \$html);
- eval {
- # optimization
- $p->report_tags(qw(form input textarea select optgroup option keygen label));
- };
+ die "Failed to create HTML::TokeParser object" unless $p;
my $base_uri = delete $opt{base};
my $verbose = delete $opt{verbose};
@@ -139,6 +134,8 @@ sub parse
my @forms;
my $f; # current form
+ my %openselect; # index to the open instance of a select
+
while (my $t = $p->get_tag) {
my($tag,$attr) = @$t;
if ($tag eq "form") {
@@ -149,6 +146,7 @@ sub parse
$action,
$attr->{'enctype'});
$f->{attr} = $attr;
+ %openselect = ();
push(@forms, $f);
my(%labels, $current_label);
while (my $t = $p->get_tag) {
@@ -183,6 +181,10 @@ sub parse
my $type = delete $attr->{type} || "text";
$f->push_input($type, $attr);
}
+ elsif ($tag eq "button") {
+ my $type = delete $attr->{type} || "submit";
+ $f->push_input($type, $attr);
+ }
elsif ($tag eq "textarea") {
$attr->{textarea_value} = $attr->{value}
if exists $attr->{value};
@@ -196,6 +198,9 @@ sub parse
$attr->{"select_$_"} = delete $attr->{$_}
if exists $attr->{$_};
}
+ # count this new select option separately
+ $openselect{$attr->{name}}++;
+
while ($t = $p->get_tag) {
my $tag = shift @$t;
last if $tag eq "/select";
@@ -214,6 +219,7 @@ sub parse
$a{value_name} = $p->get_trimmed_text;
$a{value} = delete $a{value_name}
unless defined $a{value};
+ $a{idx} = $openselect{$attr->{name}};
$f->push_input("option", \%a);
}
else {
@@ -903,7 +909,7 @@ sub form_name_value
my $self = shift;
my $name = $self->{'name'};
return unless defined $name;
- return if $self->{disabled};
+ return if $self->disabled;
my $value = $self->value;
return unless defined $value;
return ($name => $value);
@@ -964,7 +970,11 @@ sub value
if (@_) {
Carp::carp("Input '$self->{name}' is readonly")
if $^W && $self->{readonly};
- $self->{value} = shift;
+ my $new = shift;
+ my $n = exists $self->{maxlength} ? $self->{maxlength} : undef;
+ Carp::carp("Input '$self->{name}' has maxlength '$n'")
+ if $^W && defined($n) && defined($new) && length($new) > $n;
+ $self->{value} = $new;
}
$old;
}
@@ -1043,7 +1053,7 @@ sub add_to_form
my $m = $self->{menu}[0];
$m->{disabled}++ if delete $self->{option_disabled};
- my $prev = $form->find_input($self->{name}, $self->{type});
+ my $prev = $form->find_input($self->{name}, $self->{type}, $self->{idx});
return $self->SUPER::add_to_form($form) unless $prev;
# merge menues
@@ -1176,13 +1186,13 @@ sub check
sub possible_values
{
my $self = shift;
- map $_->{value}, @{$self->{menu}};
+ map $_->{value}, grep !$_->{disabled}, @{$self->{menu}};
}
sub other_possible_values
{
my $self = shift;
- map $_->{value}, grep !$_->{seen}, @{$self->{menu}};
+ map $_->{value}, grep !$_->{seen} && !$_->{disabled}, @{$self->{menu}};
}
sub value_names {
@@ -4,7 +4,7 @@ use strict;
use vars qw(@ISA $VERSION);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.7 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.810";
require HTTP::Cookies;
@ISA=qw(HTTP::Cookies);
@@ -3,7 +3,7 @@ package HTTP::Cookies::Netscape;
use strict;
use vars qw(@ISA $VERSION);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.26 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.810";
require HTTP::Cookies;
@ISA=qw(HTTP::Cookies);
@@ -6,7 +6,7 @@ use HTTP::Headers::Util qw(split_header_words join_header_words);
use LWP::Debug ();
use vars qw($VERSION $EPOCH_OFFSET);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.39 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.810";
# Legacy: because "use "HTTP::Cookies" used be the ONLY way
# to load the class HTTP::Cookies::Netscape.
@@ -199,7 +199,7 @@ sub extract_cookies
if (@ns_set) {
# The old Netscape cookie format for Set-Cookie
- # http://www.netscape.com/newsref/std/cookie_spec.html
+ # http://wp.netscape.com/newsref/std/cookie_spec.html
# can for instance contain an unquoted "," in the expires
# field, so we have to use this ad-hoc parser.
my $now = time();
@@ -240,6 +240,7 @@ sub extract_cookies
}
$first_param = 0;
}
+ next unless @cur;
next if $in_set2{$cur[0]};
# push(@cur, "Port" => $req_port);
@@ -626,7 +627,7 @@ knows about.
Cookies are a general mechanism which server side connections can use
to both store and retrieve information on the client side of the
connection. For more information about cookies refer to
-<URL:http://www.netscape.com/newsref/std/cookie_spec.html> and
+<URL:http://wp.netscape.com/newsref/std/cookie_spec.html> and
<URL:http://www.cookiecentral.com/>. This module also implements the
new style cookies described in I<RFC 2965>.
The two variants of cookies are supposed to be able to coexist happily.
@@ -1,11 +1,9 @@
package HTTP::Daemon;
-# $Id: Daemon.pm,v 1.39 2007/07/19 21:24:31 gisle Exp $
-
use strict;
use vars qw($VERSION @ISA $PROTO $DEBUG);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.39 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.810";
use IO::Socket qw(AF_INET INADDR_ANY inet_ntoa);
@ISA=qw(IO::Socket::INET);
@@ -1,6 +1,6 @@
-package HTTP::Date; # $Date: 2005/12/06 11:09:25 $
+package HTTP::Date;
-$VERSION = sprintf("%d.%02d", q$Revision: 1.47 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.810";
require 5.004;
require Exporter;
@@ -2,7 +2,7 @@ package HTTP::Headers::Auth;
use strict;
use vars qw($VERSION);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.810";
use HTTP::Headers;
@@ -2,7 +2,7 @@ package HTTP::Headers::ETag;
use strict;
use vars qw($VERSION);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.810";
require HTTP::Date;
@@ -3,7 +3,7 @@ package HTTP::Headers::Util;
use strict;
use vars qw($VERSION @ISA @EXPORT_OK);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.13 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.810";
require Exporter;
@ISA=qw(Exporter);
@@ -1,12 +1,10 @@
package HTTP::Headers;
-# $Id: Headers.pm,v 1.64 2005/12/08 12:11:48 gisle Exp $
-
use strict;
use Carp ();
use vars qw($VERSION $TRANSLATE_UNDERSCORE);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.64 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.810";
# The $TRANSLATE_UNDERSCORE variable controls whether '_' can be used
# as a replacement for '-' in header field names.
@@ -260,6 +258,7 @@ sub _date_header
if (defined $time) {
$self->_header($header, HTTP::Date::time2str($time));
}
+ $old =~ s/;.*// if defined($old);
HTTP::Date::str2time($old);
}
@@ -292,6 +291,19 @@ sub content_type {
wantarray ? @ct : $ct[0];
}
+sub _is_html {
+ my $self = shift;
+ return $self->content_type eq 'text/html' || $self->_is_xhtml;
+}
+
+sub _is_xhtml {
+ my $ct = shift->content_type;
+ for (qw(application/xhtml+xml application/vnd.wap.xhtml+xml)) {
+ return 1 if $_ eq $ct;
+ }
+ return 0;
+}
+
sub referer {
my $self = shift;
if (@_ && $_[0] =~ /#/) {
@@ -529,7 +541,7 @@ values will be substituted with this line ending sequence.
=head1 CONVENIENCE METHODS
The most frequently used headers can also be accessed through the
-following convenience methods. These methods can both be used to read
+following convenience Methods. These methods can both be used to read
and to set the value of a header. The header value is set if you pass
an argument to the method. The old header value is always returned.
If the given header did not exist then C<undef> is returned.
@@ -1,10 +1,8 @@
package HTTP::Message;
-# $Id: Message.pm,v 1.57 2005/02/18 20:29:01 gisle Exp $
-
use strict;
use vars qw($VERSION $AUTOLOAD);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.57 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.814";
require HTTP::Headers;
require Carp;
@@ -13,7 +11,14 @@ my $CRLF = "\015\012"; # "\r\n" is not portable
$HTTP::URI_CLASS ||= $ENV{PERL_HTTP_URI_CLASS} || "URI";
eval "require $HTTP::URI_CLASS"; die $@ if $@;
-
+*_utf8_downgrade = defined(&utf8::downgrade) ?
+ sub {
+ utf8::downgrade($_[0], 1) or
+ Carp::croak("HTTP::Message content must be bytes")
+ }
+ :
+ sub {
+ };
sub new
{
@@ -30,7 +35,12 @@ sub new
else {
$header = HTTP::Headers->new;
}
- $content = '' unless defined $content;
+ if (defined $content) {
+ _utf8_downgrade($content);
+ }
+ else {
+ $content = '';
+ }
bless {
'_headers' => $header,
@@ -105,6 +115,7 @@ sub content {
sub _set_content {
my $self = $_[0];
+ _utf8_downgrade($_[1]);
if (!ref($_[1]) && ref($self->{_content}) eq "SCALAR") {
${$self->{_content}} = $_[1];
}
@@ -124,6 +135,8 @@ sub add_content
my $chunkref = \$_[0];
$chunkref = $$chunkref if ref($$chunkref); # legacy
+ _utf8_downgrade($$chunkref);
+
my $ref = ref($self->{_content});
if (!$ref) {
$self->{_content} .= $$chunkref;
@@ -137,6 +150,12 @@ sub add_content
delete $self->{_parts};
}
+sub add_content_utf8 {
+ my($self, $buf) = @_;
+ utf8::upgrade($buf);
+ utf8::encode($buf);
+ $self->add_content($buf);
+}
sub content_ref
{
@@ -269,7 +288,7 @@ sub decoded_content
$content_ref_iscopy++;
}
$content_ref = \Encode::decode($charset, $$content_ref,
- Encode::FB_CROAK() | Encode::LEAVE_SRC());
+ ($opt{charset_strict} ? Encode::FB_CROAK() : 0) | Encode::LEAVE_SRC());
}
}
};
@@ -282,6 +301,26 @@ sub decoded_content
}
+sub decodable
+{
+ # should match the Content-Encoding values that decoded_content can deal with
+ my $self = shift;
+ my @enc;
+ # XXX preferably we should deterine if the modules are available without loading
+ # them here
+ eval {
+ require Compress::Zlib;
+ push(@enc, "gzip", "x-gzip", "deflate");
+ };
+ eval {
+ require Compess::Bzip2;
+ push(@enc, "x-bzip2");
+ };
+ # we don't care about announcing the 'base64' and 'quoted-printable' stuff
+ return wantarray ? @enc : join(", ", @enc);
+}
+
+
sub as_string
{
my($self, $eol) = @_;
@@ -334,7 +373,10 @@ sub add_part {
my $p = HTTP::Message->new($self->remove_content_headers,
$self->content(""));
$self->content_type("multipart/mixed");
- $self->{_parts} = [$p];
+ $self->{_parts} = [];
+ if ($p->headers->header_field_names || $p->content ne "") {
+ push(@{$self->{_parts}}, $p);
+ }
}
elsif (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR") {
$self->_parts;
@@ -543,7 +585,7 @@ but it will make your program a whole character shorter :-)
=item $mess->content
-=item $mess->content( $content )
+=item $mess->content( $bytes )
The content() method sets the raw content if an argument is given. If no
argument is given the content is not touched. In either case the
@@ -553,14 +595,19 @@ Note that the content should be a string of bytes. Strings in perl
can contain characters outside the range of a byte. The C<Encode>
module can be used to turn such strings into a string of bytes.
-=item $mess->add_content( $data )
+=item $mess->add_content( $bytes )
+
+The add_content() methods appends more data bytes to the end of the
+current content buffer.
+
+=item $mess->add_content_utf8( $string )
-The add_content() methods appends more data to the end of the current
-content buffer.
+The add_content_utf8() method appends the UTF-8 bytes representing the
+string to the end of the current content buffer.
=item $mess->content_ref
-=item $mess->content_ref( \$content )
+=item $mess->content_ref( \$bytes )
The content_ref() method will return a reference to content buffer string.
It can be more efficient to access the content this way if the content
@@ -579,9 +626,9 @@ add_content() will refuse to do anything.
=item $mess->decoded_content( %options )
-Returns the content with any C<Content-Encoding> undone and strings
-mapped to perl's Unicode strings. If the C<Content-Encoding> or
-C<charset> of the message is unknown this method will fail by
+Returns the content with any C<Content-Encoding> undone and the raw
+content encoded to perl's Unicode strings. If the C<Content-Encoding>
+or C<charset> of the message is unknown this method will fail by
returning C<undef>.
The following options can be specified.
@@ -597,11 +644,17 @@ C<none> can used to suppress decoding of the charset.
This override the default charset of "ISO-8859-1".
+=item C<charset_strict>
+
+Abort decoding if malformed characters is found in the content. By
+default you get the substitution character ("\x{FFFD}") in place of
+malformed characters.
+
=item C<raise_error>
If TRUE then raise an exception if not able to decode content. Reason
might be that the specified C<Content-Encoding> or C<charset> is not
-supported. If this option is FALSE, then decode_content() will return
+supported. If this option is FALSE, then decoded_content() will return
C<undef> on errors, but will still set $@.
=item C<ref>
@@ -612,6 +665,17 @@ the raw content as no data copying is required in this case.
=back
+=item $mess->decodeable
+
+=item HTTP::Message::decodeable()
+
+This returns the encoding identifiers that decoded_content() can
+process. In scalar context returns a comma separated string of
+identifiers.
+
+This value is suitable for initializing the C<Accept-Encoding> request
+header field.
+
=item $mess->parts
=item $mess->parts( @parts )
@@ -626,7 +690,7 @@ The argumentless form will return a list of C<HTTP::Message> objects.
If the content type of $msg is not C<multipart/*> or C<message/*> then
this will return the empty list. In scalar context only the first
object is returned. The returned message parts should be regarded as
-are read only (future versions of this library might make it possible
+read-only (future versions of this library might make it possible
to modify the parent by modifying the parts).
If the content type of $msg is C<message/*> then there will only be
@@ -635,7 +699,7 @@ one part returned.
If the content type is C<message/http>, then the return value will be
either an C<HTTP::Request> or an C<HTTP::Response> object.
-If an @parts argument is given, then the content of the message will
+If an @parts argument is given, then the content of the message will be
modified. The array reference form is provided so that an empty list
can be provided. The @parts array should contain C<HTTP::Message>
objects. The @parts objects are owned by $mess after this call and
@@ -1,9 +1,6 @@
-# $Id: Negotiate.pm,v 1.16 2005/12/06 13:51:46 gisle Exp $
-#
-
package HTTP::Negotiate;
-$VERSION = sprintf("%d.%02d", q$Revision: 1.16 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.813";
sub Version { $VERSION; }
require 5.002;
@@ -21,7 +18,7 @@ sub choose ($;$)
my(%accept);
unless (defined $request) {
- # Create a request object from the CGI envirionment variables
+ # Create a request object from the CGI environment variables
$request = new HTTP::Headers;
$request->header('Accept', $ENV{HTTP_ACCEPT})
if $ENV{HTTP_ACCEPT};
@@ -108,7 +105,7 @@ sub choose ($;$)
}
my @Q = (); # This is where we collect the results of the
- # quality calcualtions
+ # quality calculations
# Calculate quality for all the variants that are available.
for (@$variants) {
@@ -129,9 +126,9 @@ sub choose ($;$)
# Calculate encoding quality
my $qe = 1;
- # If the variant has no assignes Content-Encoding, or if no
+ # If the variant has no assigned Content-Encoding, or if no
# Accept-Encoding field is present, then the value assigned
- # is "qe=1". If *all* of the variant's content encoddings
+ # is "qe=1". If *all* of the variant's content encodings
# are listed in the Accept-Encoding field, then the value
# assigned is "qw=1". If *any* of the variant's content
# encodings are not listed in the provided Accept-Encoding
@@ -153,7 +150,7 @@ sub choose ($;$)
# Calculate charset quality
my $qc = 1;
- # If the variant's media-type has not charset parameter,
+ # If the variant's media-type has no charset parameter,
# or the variant's charset is US-ASCII, or if no Accept-Charset
# field is present, then the value assigned is "qc=1". If the
# variant's charset is listed in the Accept-Charset field,
@@ -170,7 +167,7 @@ sub choose ($;$)
my @lang = ref($lang) ? @$lang : ($lang);
# If any of the variant's content languages are listed
# in the Accept-Language field, the the value assigned is
- # the maximus of the "q" paramet values for thos language
+ # the largest of the "q" parameter values for those language
# tags.
my $q = undef;
for (@lang) {
@@ -322,8 +319,8 @@ HTTP::Negotiate - choose a variant to serve
['var3', 0.3, 'image/gif', undef, undef, undef, 43555],
];
- @prefered = choose($variants, $request_headers);
- $the_one = choose($variants);
+ @preferred = choose($variants, $request_headers);
+ $the_one = choose($variants);
=head1 DESCRIPTION
@@ -1,5 +1,3 @@
-# $Id: Common.pm,v 1.28 2007/07/19 20:46:48 gisle Exp $
-#
package HTTP::Request::Common;
use strict;
@@ -10,18 +8,19 @@ $DYNAMIC_FILE_UPLOAD ||= 0; # make it defined (don't know why)
require Exporter;
*import = \&Exporter::import;
@EXPORT =qw(GET HEAD PUT POST);
-@EXPORT_OK = qw($DYNAMIC_FILE_UPLOAD);
+@EXPORT_OK = qw($DYNAMIC_FILE_UPLOAD DELETE);
require HTTP::Request;
use Carp();
-$VERSION = sprintf("%d.%02d", q$Revision: 1.28 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.814";
my $CRLF = "\015\012"; # "\r\n" is not portable
sub GET { _simple_req('GET', @_); }
sub HEAD { _simple_req('HEAD', @_); }
sub PUT { _simple_req('PUT' , @_); }
+sub DELETE { _simple_req('DELETE', @_); }
sub POST
{
@@ -106,6 +105,7 @@ sub _simple_req
while (($k,$v) = splice(@_, 0, 2)) {
if (lc($k) eq 'content') {
$req->add_content($v);
+ $req->header("Content-Length", length(${$req->content_ref}));
}
else {
$req->push_header($k, $v);
@@ -134,8 +134,12 @@ sub form_data # RFC1867
$usename = $file;
$usename =~ s,.*/,, if defined($usename);
}
+ $k =~ s/([\\\"])/\\$1/g;
my $disp = qq(form-data; name="$k");
- $disp .= qq(; filename="$usename") if $usename;
+ if (defined($usename) and length($usename)) {
+ $usename =~ s/([\\\"])/\\$1/g;
+ $disp .= qq(; filename="$usename");
+ }
my $content = "";
my $h = HTTP::Headers->new(@headers);
if ($file) {
@@ -349,6 +353,13 @@ there is no way to directly specify a header that is actually called
"Content". If you really need this you must update the request
returned in a separate statement.
+=item DELETE $url
+
+=item DELETE $url, Header => Value,...
+
+Like GET() but the method in the request is "DELETE". This funciton
+is not exported by default.
+
=item POST $url
=item POST $url, Header => Value,...
@@ -1,10 +1,8 @@
package HTTP::Request;
-# $Id: Request.pm,v 1.40 2004/04/07 10:44:47 gisle Exp $
-
require HTTP::Message;
@ISA = qw(HTTP::Message);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.40 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.814";
use strict;
@@ -89,6 +87,12 @@ sub uri
*url = \&uri; # legacy
+sub accept_decodable
+{
+ my $self = shift;
+ $self->header("Accept-Encoding", scalar($self->decodable));
+}
+
sub as_string
{
my $self = shift;
@@ -178,9 +182,14 @@ C<HTTP::Headers> via C<HTTP::Message>. See L<HTTP::Headers> for
details and other similar methods that can be used to access the
headers.
+=item $r->accept_decodable
+
+This will set the C<Accept-Encoding> header to the list of encodings
+that decoded_content() can decode.
+
=item $r->content
-=item $r->content( $content )
+=item $r->content( $bytes )
This is used to get/set the content and it is inherited from the
C<HTTP::Message> base class. See L<HTTP::Message> for details and
@@ -1,10 +1,8 @@
package HTTP::Response;
-# $Id: Response.pm,v 1.53 2005/12/06 13:19:09 gisle Exp $
-
require HTTP::Message;
@ISA = qw(HTTP::Message);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.53 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.813";
use strict;
use HTTP::Status ();
@@ -98,6 +96,78 @@ sub base
}
+sub filename
+{
+ my $self = shift;
+ my $file;
+
+ my $cd = $self->header('Content-Disposition');
+ if ($cd) {
+ require HTTP::Headers::Util;
+ if (my @cd = HTTP::Headers::Util::split_header_words($cd)) {
+ my ($disposition, undef, %cd_param) = @{$cd[-1]};
+ $file = $cd_param{filename};
+
+ # RFC 2047 encoded?
+ if ($file && $file =~ /^=\?(.+?)\?(.+?)\?(.+)\?=$/) {
+ my $charset = $1;
+ my $encoding = uc($2);
+ my $encfile = $3;
+
+ if ($encoding eq 'Q' || $encoding eq 'B') {
+ local($SIG{__DIE__});
+ eval {
+ if ($encoding eq 'Q') {
+ $encfile =~ s/_/ /g;
+ require MIME::QuotedPrint;
+ $encfile = MIME::QuotedPrint::decode($encfile);
+ }
+ else { # $encoding eq 'B'
+ require MIME::Base64;
+ $encfile = MIME::Base64::decode($encfile);
+ }
+
+ require Encode;
+ require encoding;
+ # This is ugly use of non-public API, but is there
+ # a better way to accomplish what we want (locally
+ # as-is usable filename string)?
+ my $locale_charset = encoding::_get_locale_encoding();
+ Encode::from_to($encfile, $charset, $locale_charset);
+ };
+
+ $file = $encfile unless $@;
+ }
+ }
+ }
+ }
+
+ my $uri;
+ unless (defined($file) && length($file)) {
+ if (my $cl = $self->header('Content-Location')) {
+ $uri = URI->new($cl);
+ }
+ elsif (my $request = $self->request) {
+ $uri = $request->uri;
+ }
+
+ if ($uri) {
+ $file = ($uri->path_segments)[-1];
+ }
+ }
+
+ if ($file) {
+ $file =~ s,.*[\\/],,; # basename
+ }
+
+ if ($file && !length($file)) {
+ $file = undef;
+ }
+
+ $file;
+}
+
+
sub as_string
{
require HTTP::Status;
@@ -121,17 +191,18 @@ sub is_error { HTTP::Status::is_error (shift->{'_rc'}); }
sub error_as_HTML
{
+ require HTML::Entities;
my $self = shift;
my $title = 'An Error Occurred';
- my $body = $self->status_line;
+ my $body = HTML::Entities::encode($self->status_line);
return <<EOM;
-<HTML>
-<HEAD><TITLE>$title</TITLE></HEAD>
-<BODY>
-<H1>$title</H1>
-$body
-</BODY>
-</HTML>
+<html>
+<head><title>$title</title></head>
+<body>
+<h1>$title</h1>
+<p>$body</p>
+</body>
+</html>
EOM
}
@@ -311,7 +382,7 @@ headers.
=item $r->content
-=item $r->content( $content )
+=item $r->content( $bytes )
This is used to get/set the raw content and it is inherited from the
C<HTTP::Message> base class. See L<HTTP::Message> for details and
@@ -320,7 +391,7 @@ other methods that can be used to access the content.
=item $r->decoded_content( %options )
This will return the content after any C<Content-Encoding> and
-charsets has been decoded. See L<HTTP::Message> for details.
+charsets have been decoded. See L<HTTP::Message> for details.
=item $r->request
@@ -377,8 +448,7 @@ received some redirect responses first.
=back
-If neither of these sources provide an absolute URI, undef is
-returned.
+If none of these sources provide an absolute URI, undef is returned.
When the LWP protocol modules produce the HTTP::Response object, then
any base URI embedded in the document (step 1) will already have
@@ -386,6 +456,41 @@ initialized the "Content-Base:" header. This means that this method
only performs the last 2 steps (the content is not always available
either).
+=item $r->filename
+
+Returns a filename for this response. Note that doing sanity checks
+on the returned filename (eg. removing characters that cannot be used
+on the target filesystem where the filename would be used, and
+laundering it for security purposes) are the caller's responsibility;
+the only related thing done by this method is that it makes a simple
+attempt to return a plain filename with no preceding path segments.
+
+The filename is obtained from one the following sources (in priority
+order):
+
+=over 4
+
+=item 1.
+
+A "Content-Disposition:" header in the response. Proper decoding of
+RFC 2047 encoded filenames requires the C<MIME::QuotedPrint> (for "Q"
+encoding), C<MIME::Base64> (for "B" encoding), and C<Encode> modules.
+
+=item 2.
+
+A "Content-Location:" header in the response.
+
+=item 3.
+
+The URI used to request this response. This might not be the original
+URI that was passed to $ua->request() method, because we might have
+received some redirect responses first.
+
+=back
+
+If a filename cannot be derived from any of these sources, undef is
+returned.
+
=item $r->as_string
=item $r->as_string( $eol )
@@ -1,9 +1,7 @@
package HTTP::Status;
-# $Id: Status.pm,v 1.28 2003/10/23 18:56:01 uid39246 Exp $
-
use strict;
-require 5.002; # becase we use prototypes
+require 5.002; # because we use prototypes
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
@@ -11,14 +9,17 @@ require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(is_info is_success is_redirect is_error status_message);
@EXPORT_OK = qw(is_client_error is_server_error);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.28 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.811";
# Note also addition of mnemonics to @EXPORT below
+# Unmarked codes are from RFC 2616
+# See also: http://en.wikipedia.org/wiki/List_of_HTTP_status_codes
+
my %StatusCode = (
100 => 'Continue',
101 => 'Switching Protocols',
- 102 => 'Processing', # WebDAV
+ 102 => 'Processing', # RFC 2518 (WebDAV)
200 => 'OK',
201 => 'Created',
202 => 'Accepted',
@@ -26,7 +27,7 @@ my %StatusCode = (
204 => 'No Content',
205 => 'Reset Content',
206 => 'Partial Content',
- 207 => 'Multi-Status', # WebDAV
+ 207 => 'Multi-Status', # RFC 2518 (WebDAV)
300 => 'Multiple Choices',
301 => 'Moved Permanently',
302 => 'Found',
@@ -52,16 +53,22 @@ my %StatusCode = (
415 => 'Unsupported Media Type',
416 => 'Request Range Not Satisfiable',
417 => 'Expectation Failed',
- 422 => 'Unprocessable Entity', # WebDAV
- 423 => 'Locked', # WebDAV
- 424 => 'Failed Dependency', # WebDAV
+ 422 => 'Unprocessable Entity', # RFC 2518 (WebDAV)
+ 423 => 'Locked', # RFC 2518 (WebDAV)
+ 424 => 'Failed Dependency', # RFC 2518 (WebDAV)
+ 425 => 'No code', # WebDAV Advanced Collections
+ 426 => 'Upgrade Required', # RFC 2817
+ 449 => 'Retry with', # unofficial Microsoft
500 => 'Internal Server Error',
501 => 'Not Implemented',
502 => 'Bad Gateway',
503 => 'Service Unavailable',
504 => 'Gateway Timeout',
505 => 'HTTP Version Not Supported',
- 507 => 'Insufficient Storage', # WebDAV
+ 506 => 'Variant Also Negotiates', # RFC 2295
+ 507 => 'Insufficient Storage', # RFC 2518 (WebDAV)
+ 509 => 'Bandwidth Limit Exceeded', # unofficial
+ 510 => 'Not Extended', # RFC 2774
);
my $mnemonicCode = '';
@@ -166,6 +173,9 @@ names:
RC_UNPROCESSABLE_ENTITY (422)
RC_LOCKED (423)
RC_FAILED_DEPENDENCY (424)
+ RC_NO_CODE (425)
+ RC_UPGRADE_REQUIRED (426)
+ RC_RETRY_WITH (449)
RC_INTERNAL_SERVER_ERROR (500)
RC_NOT_IMPLEMENTED (501)
@@ -173,7 +183,10 @@ names:
RC_SERVICE_UNAVAILABLE (503)
RC_GATEWAY_TIMEOUT (504)
RC_HTTP_VERSION_NOT_SUPPORTED (505)
+ RC_VARIANT_ALSO_NEGOTIATES (506)
RC_INSUFFICIENT_STORAGE (507)
+ RC_BANDWIDTH_LIMIT_EXCEEDED (509)
+ RC_NOT_EXTENDED (510)
=head1 FUNCTIONS
@@ -190,28 +203,28 @@ names above. If the $code is unknown, then C<undef> is returned.
=item is_info( $code )
-Return TRUE if C<$code> is an I<Informational> status code. This
+Return TRUE if C<$code> is an I<Informational> status code (1xx). This
class of status code indicates a provisional response which can't have
any content.
=item is_success( $code )
-Return TRUE if C<$code> is a I<Successful> status code.
+Return TRUE if C<$code> is a I<Successful> status code (2xx).
=item is_redirect( $code )
-Return TRUE if C<$code> is a I<Redirection> status code. This class of
+Return TRUE if C<$code> is a I<Redirection> status code (3xx). This class of
status code indicates that further action needs to be taken by the
user agent in order to fulfill the request.
=item is_error( $code )
-Return TRUE if C<$code> is an I<Error> status code. The function
+Return TRUE if C<$code> is an I<Error> status code (4xx or 5xx). The function
return TRUE for both client error or a server error status codes.
=item is_client_error( $code )
-Return TRUE if C<$code> is an I<Client Error> status code. This class
+Return TRUE if C<$code> is an I<Client Error> status code (4xx). This class
of status code is intended for cases in which the client seems to have
erred.
@@ -219,7 +232,7 @@ This function is B<not> exported by default.
=item is_server_error( $code )
-Return TRUE if C<$code> is an I<Server Error> status code. This class
+Return TRUE if C<$code> is an I<Server Error> status code (5xx). This class
of status codes is intended for cases in which the server is aware
that it has erred or is incapable of performing the request.
@@ -28,7 +28,7 @@ sub authenticate
push(@digest, $auth_param->{nonce});
if ($auth_param->{qop}) {
- push(@digest, $nc, $cnonce, $auth_param->{qop});
+ push(@digest, $nc, $cnonce, ($auth_param->{qop} =~ m|^auth[,;]auth-int$|) ? 'auth' : $auth_param->{qop});
}
$md5->add(join(":", $request->method, $uri));
@@ -42,7 +42,7 @@ sub authenticate
my %resp = map { $_ => $auth_param->{$_} } qw(realm nonce opaque);
@resp{qw(username uri response algorithm)} = ($user, $uri, $digest, "MD5");
- if (($auth_param->{qop} || "") eq "auth") {
+ if (($auth_param->{qop} || "") =~ m|^auth([,;]auth-int)?$|) {
@resp{qw(qop cnonce nc)} = ("auth", $cnonce, $nc);
}
@@ -3,7 +3,7 @@ package LWP::Authen::Ntlm;
use strict;
use vars qw/$VERSION/;
-$VERSION = '0.05';
+$VERSION = '5.810';
use Authen::NTLM "1.02";
use MIME::Base64 "2.12";
@@ -1,11 +1,9 @@
package LWP::ConnCache;
-# $Id: ConnCache.pm,v 1.6 2004/04/09 15:07:04 gisle Exp $
-
use strict;
use vars qw($VERSION $DEBUG);
-$VERSION = "0.01";
+$VERSION = "5.810";
sub new {
@@ -1,7 +1,5 @@
package LWP::Debug;
-# $Id: Debug.pm,v 1.15 2004/04/09 15:07:04 gisle Exp $
-
require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(level trace debug conns);
@@ -1,7 +1,5 @@
package LWP::DebugFile;
-# $Id: DebugFile.pm,v 1.3 2003/10/23 18:56:01 uid39246 Exp $
-
use strict;
use LWP::Debug ();
@@ -1,12 +1,10 @@
package LWP::MediaTypes;
-# $Id: MediaTypes.pm,v 1.33 2007/07/19 20:26:11 gisle Exp $
-
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(guess_media_type media_suffix);
@EXPORT_OK = qw(add_type add_encoding read_media_types);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.33 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.810";
require LWP::Debug;
use strict;
@@ -1,7 +1,5 @@
package LWP::MemberMixin;
-# $Id: MemberMixin.pm,v 1.8 2004/04/09 15:07:04 gisle Exp $
-
sub _elem
{
my $self = shift;
@@ -1,8 +1,5 @@
package LWP::Protocol::GHTTP;
-# $Id: GHTTP.pm,v 1.3 2003/10/14 12:01:27 gisle Exp $
-
-#
# You can tell LWP to use this module for 'http' requests by running
# code like this before you make requests:
#
@@ -1,10 +1,7 @@
-#
-# $Id: data.pm,v 1.2 1998/11/19 21:45:01 aas Exp $
-#
-# Implements access to data:-URLs as specified in RFC 2397
+package LWP::Protocol::data;
+# Implements access to data:-URLs as specified in RFC 2397
-package LWP::Protocol::data;
use strict;
use vars qw(@ISA);
@@ -1,6 +1,3 @@
-#
-# $Id: file.pm,v 1.23 2004/11/15 22:53:36 gisle Exp $
-
package LWP::Protocol::file;
require LWP::Protocol;
@@ -14,10 +11,6 @@ require HTTP::Response;
require HTTP::Status;
require HTTP::Date;
-require URI::Escape;
-require HTML::Entities;
-
-
sub request
{
@@ -96,6 +89,8 @@ sub request
closedir(D);
# Make directory listing
+ require URI::Escape;
+ require HTML::Entities;
my $pathe = $path . ( $^O eq 'MacOS' ? ':' : '/');
for (@files) {
my $furl = URI::Escape::uri_escape($_);
@@ -1,11 +1,8 @@
-#
-# $Id: ftp.pm,v 1.36 2003/10/23 19:11:32 uid39246 Exp $
+package LWP::Protocol::ftp;
# Implementation of the ftp protocol (RFC 959). We let the Net::FTP
# package do all the dirty work.
-package LWP::Protocol::ftp;
-
use Carp ();
use HTTP::Status ();
@@ -1,5 +1,4 @@
-#
-# $Id: gopher.pm,v 1.20 2003/10/23 19:11:33 uid39246 Exp $
+package LWP::Protocol::gopher;
# Implementation of the gopher protocol (RFC 1436)
#
@@ -7,9 +6,6 @@
# which in turn is a vastly modified version of Oscar's http'get()
# dated 28/3/94 in <ftp://cui.unige.ch/PUBLIC/oscar/scripts/http.pl>
# including contributions from Marc van Heyningen and Martijn Koster.
-#
-
-package LWP::Protocol::gopher;
use strict;
use vars qw(@ISA);
@@ -1,6 +1,3 @@
-# $Id: http.pm,v 1.70 2005/12/08 10:28:01 gisle Exp $
-#
-
package LWP::Protocol::http;
use strict;
@@ -206,12 +203,26 @@ sub request
#print "------\n$req_buf\n------\n";
if (!$has_content || $write_wait || $has_content > 8*1024) {
- # XXX need to watch out for write timeouts
- my $n = $socket->syswrite($req_buf, length($req_buf));
- die $! unless defined($n);
- die "short write" unless $n == length($req_buf);
- #LWP::Debug::conns($req_buf);
- $req_buf = "";
+ do {
+ # Since this just writes out the header block it should almost
+ # always succeed to send the whole buffer in a single write call.
+ my $n = $socket->syswrite($req_buf, length($req_buf));
+ unless (defined $n) {
+ redo if $!{EINTR};
+ if ($!{EAGAIN}) {
+ select(undef, undef, undef, 0.1);
+ redo;
+ }
+ die "write failed: $!";
+ }
+ if ($n) {
+ substr($req_buf, 0, $n, "");
+ }
+ else {
+ select(undef, undef, undef, 0.5);
+ }
+ }
+ while (length $req_buf);
}
my($code, $mess, @junk);
@@ -243,20 +254,32 @@ sub request
my $fbits = '';
vec($fbits, fileno($socket), 1) = 1;
+ WRITE:
while ($woffset < length($$wbuf)) {
- my $time_before;
my $sel_timeout = $timeout;
if ($write_wait) {
- $time_before = time;
$sel_timeout = $write_wait if $write_wait < $sel_timeout;
}
+ my $time_before;
+ $time_before = time if $sel_timeout;
my $rbits = $fbits;
my $wbits = $write_wait ? undef : $fbits;
- my $nfound = select($rbits, $wbits, undef, $sel_timeout);
- unless (defined $nfound) {
- die "select failed: $!";
+ my $sel_timeout_before = $sel_timeout;
+ SELECT:
+ {
+ my $nfound = select($rbits, $wbits, undef, $sel_timeout);
+ unless (defined $nfound) {
+ if ($!{EINTR} || $!{EAGAIN}) {
+ if ($time_before) {
+ $sel_timeout = $sel_timeout_before - (time - $time_before);
+ $sel_timeout = 0 if $sel_timeout < 0;
+ }
+ redo SELECT;
+ }
+ die "select failed: $!";
+ }
}
if ($write_wait) {
@@ -268,12 +291,20 @@ sub request
# readable
my $buf = $socket->_rbuf;
my $n = $socket->sysread($buf, 1024, length($buf));
- unless ($n) {
- die "EOF";
+ unless (defined $n) {
+ die "read failed: $!" unless $!{EINTR} || $!{EAGAIN};
+ # if we get here the rest of the block will do nothing
+ # and we will retry the read on the next round
+ }
+ elsif ($n == 0) {
+ # the server closed the connection before we finished
+ # writing all the request content. No need to write any more.
+ $drop_connection++;
+ last WRITE;
}
$socket->_rbuf($buf);
- if ($buf =~ /\015?\012\015?\012/) {
- # a whole response present
+ if (!$code && $buf =~ /\015?\012\015?\012/) {
+ # a whole response header is present, so we can read it without blocking
($code, $mess, @h) = $socket->read_response_headers(laxed => 1,
junk_out => \@junk,
);
@@ -283,16 +314,19 @@ sub request
}
else {
$drop_connection++;
- last;
+ last WRITE;
# XXX should perhaps try to abort write in a nice way too
}
}
}
if (defined($wbits) && $wbits =~ /[^\0]/) {
my $n = $socket->syswrite($$wbuf, length($$wbuf), $woffset);
- unless ($n) {
- die "syswrite: $!" unless defined $n;
- die "syswrite: no bytes written";
+ unless (defined $n) {
+ die "write failed: $!" unless $!{EINTR} || $!{EAGAIN};
+ $n = 0; # will retry write on the next round
+ }
+ elsif ($n == 0) {
+ die "write failed: no bytes written";
}
$woffset += $n;
@@ -307,7 +341,7 @@ sub request
$woffset = 0;
}
}
- }
+ } # WRITE
}
($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
@@ -344,7 +378,10 @@ sub request
READ:
{
$n = $socket->read_entity_body($buf, $size);
- die "Can't read entity body: $!" unless defined $n;
+ unless (defined $n) {
+ redo READ if $!{EINTR} || $!{EAGAIN};
+ die "read failed: $!";
+ }
redo READ if $n == -1;
}
$complete++ if !$n;
@@ -396,9 +433,24 @@ sub can_read {
my($self, $timeout) = @_;
my $fbits = '';
vec($fbits, fileno($self), 1) = 1;
- my $nfound = select($fbits, undef, undef, $timeout);
- die "select failed: $!" unless defined $nfound;
- return $nfound > 0;
+ SELECT:
+ {
+ my $before;
+ $before = time if $timeout;
+ my $nfound = select($fbits, undef, undef, $timeout);
+ unless (defined $nfound) {
+ if ($!{EINTR} || $!{EAGAIN}) {
+ # don't really think EAGAIN can happen here
+ if ($timeout) {
+ $timeout -= time - $before;
+ $timeout = 0 if $timeout < 0;
+ }
+ redo SELECT;
+ }
+ die "select failed: $!";
+ }
+ return $nfound > 0;
+ }
}
sub ping {
@@ -1,6 +1,3 @@
-#
-# $Id: http10.pm,v 1.3 2003/10/23 19:11:33 uid39246 Exp $
-
package LWP::Protocol::http10;
use strict;
@@ -1,8 +1,5 @@
-#
package LWP::Protocol::https;
-# $Id: https.pm,v 1.12 2003/10/15 10:35:47 gisle Exp $
-
use strict;
use vars qw(@ISA);
@@ -1,10 +1,7 @@
-#
-# $Id: https10.pm,v 1.4 2007/07/20 06:16:58 gisle Exp $
+package LWP::Protocol::https10;
use strict;
-package LWP::Protocol::https10;
-
# Figure out which SSL implementation to use
use vars qw($SSL_CLASS);
if ($Net::SSL::VERSION) {
@@ -1,12 +1,9 @@
-#
-# $Id: mailto.pm,v 1.12 2004/05/21 08:56:15 gisle Exp $
-#
+package LWP::Protocol::mailto;
+
# This module implements the mailto protocol. It is just a simple
# frontend to the Unix sendmail program except on MacOS, where it uses
# Mail::Internet.
-package LWP::Protocol::mailto;
-
require LWP::Protocol;
require HTTP::Request;
require HTTP::Response;
@@ -1,10 +1,6 @@
-#
-# $Id: nntp.pm,v 1.11 2007/07/19 20:26:11 gisle Exp $
+package LWP::Protocol::nntp;
# Implementation of the Network News Transfer Protocol (RFC 977)
-#
-
-package LWP::Protocol::nntp;
require LWP::Protocol;
@ISA = qw(LWP::Protocol);
@@ -1,10 +1,8 @@
package LWP::Protocol;
-# $Id: Protocol.pm,v 1.46 2007/07/19 20:26:11 gisle Exp $
-
require LWP::MemberMixin;
@ISA = qw(LWP::MemberMixin);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.46 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.810";
use strict;
use Carp ();
@@ -101,9 +99,10 @@ sub collect
my($ua, $parse_head, $max_size) = @{$self}{qw(ua parse_head max_size)};
my $parser;
- if ($parse_head && $response->content_type eq 'text/html') {
+ if ($parse_head && $response->_is_html) {
require HTML::HeadParser;
$parser = HTML::HeadParser->new($response->{'_headers'});
+ $parser->xml_mode(1) if $response->_is_xhtml;
$parser->utf8_mode(1) if $] >= 5.008 && $HTML::Parser::VERSION >= 3.40;
}
my $content_size = 0;
@@ -1,10 +1,8 @@
package LWP::RobotUA;
-# $Id: RobotUA.pm,v 1.27 2004/04/06 13:14:37 gisle Exp $
-
require LWP::UserAgent;
@ISA = qw(LWP::UserAgent);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.27 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.813";
require WWW::RobotRules;
require HTTP::Request;
@@ -50,8 +48,8 @@ sub new
my $self = LWP::UserAgent->new(%cnf);
$self = bless $self, $class;
- $self->{'delay'} = 1; # minutes
- $self->{'use_sleep'} = 1;
+ $self->{'delay'} = $delay; # minutes
+ $self->{'use_sleep'} = $use_sleep;
if ($rules) {
$rules->agent($cnf{agent});
@@ -1,7 +1,5 @@
package LWP::Simple;
-# $Id: Simple.pm,v 1.41 2004/05/21 09:11:55 gisle Exp $
-
use strict;
use vars qw($ua %loop_check $FULL_LWP @EXPORT @EXPORT_OK $VERSION);
@@ -16,7 +14,7 @@ require Exporter;
use HTTP::Status;
push(@EXPORT, @HTTP::Status::EXPORT);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.41 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.810";
$FULL_LWP++ if grep {lc($_) eq "http_proxy"} keys %ENV;
@@ -1,13 +1,11 @@
package LWP::UserAgent;
-# $Id: UserAgent.pm,v 2.36 2006/06/05 08:36:37 gisle Exp $
-
use strict;
use vars qw(@ISA $VERSION);
require LWP::MemberMixin;
@ISA = qw(LWP::MemberMixin);
-$VERSION = sprintf("%d.%03d", q$Revision: 2.36 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.814";
use HTTP::Request ();
use HTTP::Response ();
@@ -32,6 +30,10 @@ if ($ENV{PERL_LWP_USE_HTTP_10}) {
sub new
{
+ # Check for common user mistake
+ Carp::croak("Options to LWP::UserAgent should be key/value pairs, not hash reference")
+ if ref($_[1]) eq 'HASH';
+
my($class, %cnf) = @_;
LWP::Debug::trace('()');
@@ -45,6 +47,7 @@ sub new
$use_eval = 1 unless defined $use_eval;
my $parse_head = delete $cnf{parse_head};
$parse_head = 1 unless defined $parse_head;
+ my $show_progress = delete $cnf{show_progress};
my $max_size = delete $cnf{max_size};
my $max_redirect = delete $cnf{max_redirect};
$max_redirect = 7 unless defined $max_redirect;
@@ -84,6 +87,7 @@ sub new
timeout => $timeout,
use_eval => $use_eval,
parse_head => $parse_head,
+ show_progress=> $show_progress,
max_size => $max_size,
max_redirect => $max_redirect,
proxy => {},
@@ -209,7 +213,7 @@ EOT
@{$self}{qw(timeout cookie_jar use_eval parse_head max_size)};
my $response;
- $self->progress("begin");
+ $self->progress("begin", $request);
if ($use_eval) {
# we eval, and turn dies into responses below
eval {
@@ -488,9 +492,36 @@ sub _process_colonic_headers {
return $arg;
}
+my @ANI = qw(- \ | /);
+
sub progress {
- my($self, $status, $response) = @_;
- # subclasses might override this
+ my($self, $status, $m) = @_;
+ return unless $self->{show_progress};
+ if ($status eq "begin") {
+ print STDERR "** ", $m->method, " ", $m->uri, " ==> ";
+ $self->{progress_start} = time;
+ $self->{progress_lastp} = "";
+ $self->{progress_ani} = 0;
+ }
+ elsif ($status eq "end") {
+ delete $self->{progress_lastp};
+ delete $self->{progress_ani};
+ print STDERR $m->status_line;
+ my $t = time - delete $self->{progress_start};
+ print STDERR " (${t}s)" if $t;
+ print STDERR "\n";
+ }
+ elsif ($status eq "tick") {
+ print STDERR "$ANI[$self->{progress_ani}++]\b";
+ $self->{progress_ani} %= @ANI;
+ }
+ else {
+ my $p = sprintf "%3.0f%%", $status * 100;
+ return if $p eq $self->{progress_lastp};
+ print STDERR "$p\b\b\b\b";
+ $self->{progress_lastp} = $p;
+ }
+ STDERR->flush;
}
@@ -833,7 +864,7 @@ LWP::UserAgent - Web user agent class
my $response = $ua->get('http://search.cpan.org/');
if ($response->is_success) {
- print $response->content; # or whatever
+ print $response->decoded_content; # or whatever
}
else {
die $response->status_line;
@@ -987,9 +1018,7 @@ is really just a shortcut for:
Get/set the headers object that will provide default header values for
any requests sent. By default this will be an empty C<HTTP::Headers>
-object. Example:
-
- $ua->default_headers->push_header('Accept-Language' => "no, en");
+object.
=item $ua->default_header( $field )
@@ -998,6 +1027,7 @@ object. Example:
This is just a short-cut for $ua->default_headers->header( $field =>
$value ). Example:
+ $ua->default_header('Accept-Encoding' => scalar HTTP::Message::decodable());
$ua->default_header('Accept-Language' => "no, en");
=item $ua->conn_cache
@@ -1012,6 +1042,11 @@ for details.
Set the user name and password to be used for a realm. It is often more
useful to specialize the get_basic_credentials() method instead.
+The $netloc a string of the form "<host>:<port>". The username and
+password will only be passed to this server. Example:
+
+ $ua->credentials("www.example.com:80", "Some Realm", "foo", "secret");
+
=item $ua->max_size
=item $ua->max_size( $bytes )
@@ -1353,7 +1388,7 @@ with this library.
The base implementation simply checks a set of pre-stored member
variables, set up with the credentials() method.
-=item $ua->progress( $status, $response )
+=item $ua->progress( $status, $request_or_response )
This is called frequently as the response is received regardless of
how the content is processed. The method is called with $status
@@ -1362,6 +1397,9 @@ before the request method returns. In between these $status will be
the fraction of the response currently received or the string "tick"
if the fraction can't be calculated.
+When $status is "begin" the second argument is the request object,
+otherwise it is the response object.
+
=back
=head1 SEE ALSO
@@ -1379,7 +1417,7 @@ specialized user agents based on C<LWP::UserAgent>.
=head1 COPYRIGHT
-Copyright 1995-2004 Gisle Aas.
+Copyright 1995-2008 Gisle Aas.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
@@ -1,5 +1,3 @@
-# $Id: media.types,v 1.5 2004/04/06 11:15:04 gisle Exp $
-#
# This file defines the mapping from file name extentions to media types.
# Media types where the subtype does not have the "x-" prefix should be
# registered by IANA:
@@ -1,9 +1,6 @@
-#
-# $Id: LWP.pm,v 1.152 2007/08/05 13:23:32 gisle Exp $
-
package LWP;
-$VERSION = "5.808";
+$VERSION = "5.814";
sub Version { $VERSION; }
require 5.005;
@@ -639,7 +636,7 @@ libwww-perl-0.40 library for details.
=head1 COPYRIGHT
- Copyright 1995-2005, Gisle Aas
+ Copyright 1995-2008, Gisle Aas
Copyright 1995, Martijn Koster
This library is free software; you can redistribute it and/or
@@ -650,7 +647,7 @@ modify it under the same terms as Perl itself.
The latest version of this library is likely to be available from CPAN
as well as:
- http://www.linpro.no/lwp/
+ http://gitorious.org/projects/libwww-perl
The best place to discuss this code is on the <libwww@perl.org>
mailing list.
@@ -1,18 +1,18 @@
package Net::HTTP::Methods;
-# $Id: Methods.pm,v 1.22 2005/12/07 10:01:37 gisle Exp $
-
require 5.005; # 4-arg substr
use strict;
use vars qw($VERSION);
-$VERSION = "1.02";
+$VERSION = "5.812";
my $CRLF = "\015\012"; # "\r\n" is not portable
sub new {
- my($class, %cnf) = @_;
+ my $class = shift;
+ unshift(@_, "Host") if @_ == 1;
+ my %cnf = @_;
require Symbol;
my $self = bless Symbol::gensym(), $class;
return $self->http_configure(\%cnf);
@@ -25,14 +25,27 @@ sub http_configure {
my $explict_host = (exists $cnf->{Host});
my $host = delete $cnf->{Host};
my $peer = $cnf->{PeerAddr} || $cnf->{PeerHost};
- if ($host) {
- $cnf->{PeerAddr} = $host unless $peer;
+ if (!$peer) {
+ die "No Host option provided" unless $host;
+ $cnf->{PeerAddr} = $peer = $host;
+ }
+
+ if ($peer =~ s,:(\d+)$,,) {
+ $cnf->{PeerPort} = int($1); # always override
+ }
+ if (!$cnf->{PeerPort}) {
+ $cnf->{PeerPort} = $self->http_default_port;
}
- elsif (!$explict_host) {
+
+ if (!$explict_host) {
$host = $peer;
$host =~ s/:.*//;
}
- $cnf->{PeerPort} = $self->http_default_port unless $cnf->{PeerPort};
+ if ($host && $host !~ /:/) {
+ my $p = $cnf->{PeerPort};
+ $host .= ":$p" if $p != $self->http_default_port;
+ }
+
$cnf->{Proto} = 'tcp';
my $keep_alive = delete $cnf->{KeepAlive};
@@ -48,10 +61,6 @@ sub http_configure {
return undef unless $self->http_connect($cnf);
- if ($host && $host !~ /:/) {
- my $p = $self->peerport;
- $host .= ":$p" if $p != $self->http_default_port;
- }
$self->host($host);
$self->keep_alive($keep_alive);
$self->send_te($send_te);
@@ -229,11 +238,26 @@ sub my_readline {
if $max_line_length && length($_) > $max_line_length;
# need to read more data to find a line ending
- my $n = $self->sysread($_, 1024, length);
- if (!$n) {
- return undef unless length;
- return substr($_, 0, length, "");
- }
+ READ:
+ {
+ my $n = $self->sysread($_, 1024, length);
+ unless (defined $n) {
+ redo READ if $!{EINTR};
+ if ($!{EAGAIN}) {
+ # Hmm, we must be reading from a non-blocking socket
+ # XXX Should really wait until this socket is readable,...
+ select(undef, undef, undef, 0.1); # but this will do for now
+ redo READ;
+ }
+ # if we have already accumulated some data let's at least
+ # return that as a line
+ die "read failed: $!" unless length;
+ }
+ unless ($n) {
+ return undef unless length;
+ return substr($_, 0, length, "");
+ }
+ }
}
die "Line too long ($pos; limit is $max_line_length)"
if $max_line_length && $pos > $max_line_length;
@@ -368,8 +392,8 @@ sub read_entity_body {
delete ${*$self}{'http_bytes'};
my $method = shift(@{${*$self}{'http_request_method'}});
my $status = ${*$self}{'http_status'};
- if ($method eq "HEAD" || $status =~ /^(?:1|[23]04)/) {
- # these responses are always empty
+ if ($method eq "HEAD") {
+ # this response is always empty regardless of other headers
$bytes = 0;
}
elsif (my $te = ${*$self}{'http_te'}) {
@@ -409,6 +433,11 @@ sub read_entity_body {
elsif (defined(my $content_length = ${*$self}{'http_content_length'})) {
$bytes = $content_length;
}
+ elsif ($status =~ /^(?:1|[23]04)/) {
+ # RFC 2616 says that these responses should always be empty
+ # but that does not appear to be true in practice [RT#17907]
+ $bytes = 0;
+ }
else {
# XXX Multi-Part types are self delimiting, but RFC 2616 says we
# only has to deal with 'multipart/byteranges'
@@ -1,11 +1,10 @@
package Net::HTTP::NB;
-# $Id: NB.pm,v 1.6 2004/11/12 16:18:11 gisle Exp $
-
use strict;
use vars qw($VERSION @ISA);
-$VERSION = "0.03";
+$VERSION = "5.810";
+
require Net::HTTP;
@ISA=qw(Net::HTTP);
@@ -1,16 +1,21 @@
package Net::HTTP;
-# $Id: HTTP.pm,v 1.47 2005/12/06 12:02:22 gisle Exp $
-
use strict;
use vars qw($VERSION @ISA);
-$VERSION = "1.00";
+$VERSION = "5.812";
eval { require IO::Socket::INET } || require IO::Socket;
require Net::HTTP::Methods;
+require Carp;
@ISA=qw(IO::Socket::INET Net::HTTP::Methods);
+sub new {
+ my $class = shift;
+ Carp::croak("No Host option provided") unless @_;
+ $class->SUPER::new(@_);
+}
+
sub configure {
my($self, $cnf) = @_;
$self->http_configure($cnf);
@@ -215,7 +220,12 @@ read_response_headers() call.
The return value will be C<undef> on read errors, 0 on EOF, -1 if no data
could be returned this time, otherwise the number of bytes assigned
-to $buf. The $buf set to "" when the return value is -1.
+to $buf. The $buf is set to "" when the return value is -1.
+
+You normally want to retry this call if this function returns either
+-1 or C<undef> with C<$!> as EINTR or EAGAIN (see L<Errno>). EINTR
+can happen if the application catches signals and EAGAIN can happen if
+you made the socket non-blocking.
This method will raise exceptions (die) if the server does not speak
proper HTTP. This can only happen when reading chunked data.
@@ -1,11 +1,9 @@
package Net::HTTPS;
-# $Id: HTTPS.pm,v 1.4 2007/07/19 20:26:11 gisle Exp $
-
use strict;
use vars qw($VERSION $SSL_SOCKET_CLASS @ISA);
-$VERSION = "1.00";
+$VERSION = "5.810";
# Figure out which SSL implementation to use
if ($Net::SSL::VERSION) {
@@ -1,10 +1,8 @@
-# $Id: AnyDBM_File.pm,v 1.11 2003/10/23 19:11:33 uid39246 Exp $
-
package WWW::RobotRules::AnyDBM_File;
require WWW::RobotRules;
@ISA = qw(WWW::RobotRules);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.810";
use Carp ();
use AnyDBM_File;
@@ -1,8 +1,6 @@
package WWW::RobotRules;
-# $Id: RobotRules.pm,v 1.33 2005/09/21 19:36:19 gisle Exp $
-
-$VERSION = sprintf("%d.%02d", q$Revision: 1.33 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "5.810";
sub Version { $VERSION; }
use strict;
@@ -1,37 +1,39 @@
-print "1..22\n";
+#perl -w
+
+use Test;
+plan tests => 51;
use HTTP::Request::Common;
$r = GET 'http://www.sn.no/';
print $r->as_string;
-print "not " unless $r->method eq "GET" and $r->url eq "http://www.sn.no/";
-print "ok 1\n";
+ok($r->method, "GET");
+ok($r->url, "http://www.sn.no/");
$r = HEAD "http://www.sn.no/",
If_Match => 'abc',
From => 'aas@sn.no';
print $r->as_string;
-print "not " unless $r->method eq "HEAD" and $r->url->eq("http://www.sn.no");
-print "ok 2\n";
+ok($r->method, "HEAD");
+ok($r->url->eq("http://www.sn.no"));
-print "not " unless $r->header('If-Match') eq "abc" and $r->header("from") eq "aas\@sn.no";
-print "ok 3\n";
+ok($r->header('If-Match'), "abc");
+ok($r->header("from"), "aas\@sn.no");
$r = PUT "http://www.sn.no",
Content => 'foo';
print $r->as_string, "\n";
-print "not " unless $r->method eq "PUT" and $r->uri->host eq "www.sn.no";
-print "ok 4\n";
+ok($r->method, "PUT");
+ok($r->uri->host, "www.sn.no");
-print "not " if defined($r->header("Content"));
-print "ok 5\n";
+ok(!defined($r->header("Content")));
-print "not " unless ${$r->content_ref} eq "foo" and
- $r->content eq "foo";
-print "ok 6\n";
+ok(${$r->content_ref}, "foo");
+ok($r->content, "foo");
+ok($r->content_length, 3);
#--- Test POST requests ---
@@ -43,26 +45,22 @@ $r = POST "http://www.sn.no", [foo => 'bar;baz',
bar => 'foo';
print $r->as_string, "\n";
-print "not " unless $r->method eq "POST" and
- $r->content_type eq "application/x-www-form-urlencoded" and
- $r->content_length == 58 and
- $r->header("bar") eq "foo";
-print "ok 7\n";
-
-print "not " unless $r->content eq "foo=bar%3Bbaz&baz=a&baz=b&baz=c&foo=zoo%3D%26&space+=+%2B+";
-print "ok 8\n";
+ok($r->method, "POST");
+ok($r->content_type, "application/x-www-form-urlencoded");
+ok($r->content_length, 58);
+ok($r->header("bar"), "foo");
+ok($r->content, "foo=bar%3Bbaz&baz=a&baz=b&baz=c&foo=zoo%3D%26&space+=+%2B+");
$r = POST "mailto:gisle\@aas.no",
Subject => "Heisan",
Content_Type => "text/plain",
Content => "Howdy\n";
-print $r->as_string;
+#print $r->as_string;
-print "not " unless $r->method eq "POST" and
- $r->header("Subject") eq "Heisan" and
- $r->content eq "Howdy\n" and
- $r->content_type eq "text/plain";
-print "ok 9\n";
+ok($r->method, "POST");
+ok($r->header("Subject"), "Heisan");
+ok($r->content, "Howdy\n");
+ok($r->content_type, "text/plain");
#
# POST for File upload
@@ -80,15 +78,14 @@ $r = POST 'http://www.perl.org/survey.cgi',
born => '1964',
file => [$file],
];
-print $r->as_string;
+#print $r->as_string;
unlink($file) or warn "Can't unlink $file: $!";
-print "not " unless $r->method eq "POST" and
- $r->url->path eq "/survey.cgi" and
- $r->content_type eq "multipart/form-data" and
- $r->header(Content_type) =~ /boundary="?([^"]+)"?/;
-print "ok 10\n";
+ok($r->method, "POST");
+ok($r->url->path, "/survey.cgi");
+ok($r->content_type, "multipart/form-data");
+ok($r->header(Content_type) =~ /boundary="?([^"]+)"?/);
$boundary = $1;
$c = $r->content;
@@ -96,54 +93,40 @@ $c =~ s/\r//g;
@c = split(/--\Q$boundary/, $c);
print "$c[5]\n";
-print "not " unless @c == 7 and $c[6] =~ /^--\n/; # 5 parts + header & trailer
-print "ok 11\n";
+ok(@c == 7 and $c[6] =~ /^--\n/); # 5 parts + header & trailer
-print "not " unless $c[2] =~ /^Content-Disposition:\s*form-data;\s*name="email"/m and
- $c[2] =~ /^gisle\@aas.no$/m;
-print "ok 12\n";
+ok($c[2] =~ /^Content-Disposition:\s*form-data;\s*name="email"/m);
+ok($c[2] =~ /^gisle\@aas.no$/m);
-print "not " unless $c[5] =~ /^Content-Disposition:\s*form-data;\s*name="file";\s*filename="$file"/m and
- $c[5] =~ /^Content-Type:\s*text\/plain$/m and
- $c[5] =~ /^foo\nbar\nbaz/m;
-print "ok 13\n";
+ok($c[5] =~ /^Content-Disposition:\s*form-data;\s*name="file";\s*filename="$file"/m);
+ok($c[5] =~ /^Content-Type:\s*text\/plain$/m);
+ok($c[5] =~ /^foo\nbar\nbaz/m);
$r = POST 'http://www.perl.org/survey.cgi',
- [ file => [ undef, "xxx", Content_type => "text/html", Content => "<h1>Hello, world!</h1>" ]],
+ [ file => [ undef, "xxy\"", Content_type => "text/html", Content => "<h1>Hello, world!</h1>" ]],
Content_type => 'multipart/form-data';
print $r->as_string;
-if($^O eq "MacOS") {
- print "not " unless $r->content =~ /^--\S+\015\012Content-Disposition:\s*form-data;\s*name="file";\s*filename="xxx"/m and
- $r->content =~ /^\012Content-Type: text\/html/m and
- $r->content =~ /^\012<h1>Hello, world/m;
-}
-else {
- print "not " unless $r->content =~ /^--\S+\015\012Content-Disposition:\s*form-data;\s*name="file";\s*filename="xxx"/m and
- $r->content =~ /^Content-Type: text\/html/m and
- $r->content =~ /^<h1>Hello, world/m;
-}
-print "ok 14\n";
-
+ok($r->content =~ /^--\S+\015\012Content-Disposition:\s*form-data;\s*name="file";\s*filename="xxy\\"/m);
+ok($r->content =~ /^Content-Type: text\/html/m);
+ok($r->content =~ /^<h1>Hello, world/m);
$r = POST 'http://www.perl.org/survey.cgi',
Content_type => 'multipart/form-data',
Content => [ file => [ undef, undef, Content => "foo"]];
-print $r->as_string;
+#print $r->as_string;
-print "not " if $r->content =~ /filename=/;
-print "ok 15\n";
+ok($r->content !~ /filename=/);
# The POST routine can now also take a hash reference.
my %hash = (foo => 42, bar => 24);
$r = POST 'http://www.perl.org/survey.cgi', \%hash;
-print $r->as_string, "\n";
-print "not " unless $r->content =~ /foo=42/ &&
- $r->content =~ /bar=24/ &&
- $r->content_type eq "application/x-www-form-urlencoded" &&
- $r->content_length == 13;
-print "ok 16\n";
+#print $r->as_string, "\n";
+ok($r->content =~ /foo=42/);
+ok($r->content =~ /bar=24/);
+ok($r->content_type, "application/x-www-form-urlencoded");
+ok($r->content_length, 13);
#
@@ -169,16 +152,14 @@ $r = POST 'http://www.perl.org/survey.cgi',
];
print $r->as_string, "\n";
-print "not " unless $r->method eq "POST" and
- $r->url->path eq "/survey.cgi" and
- $r->content_type eq "multipart/form-data" and
- $r->header(Content_type) =~ /boundary="?([^"]+)"?/ and
- ref($r->content) eq "CODE";
-print "ok 17\n";
+ok($r->method, "POST");
+ok($r->url->path, "/survey.cgi");
+ok($r->content_type, "multipart/form-data");
+ok($r->header(Content_type) =~ /boundary="?([^"]+)"?/);
$boundary = $1;
+ok(ref($r->content), "CODE");
-print "not " unless length($boundary) > 10;
-print "ok 18\n";
+ok(length($boundary) > 10);
$code = $r->content;
my $chunk;
@@ -194,12 +175,11 @@ $_ = join("", @chunks);
print int(@chunks), " chunks, total size is ", length($_), " bytes\n";
# should be close to expected size and number of chunks
-print "not " unless abs(@chunks - 15 < 3) and
- abs(length($_) - 26589) < 20;
-print "ok 19\n";
+ok(abs(@chunks - 15 < 3));
+ok(abs(length($_) - 26589) < 20);
$r = POST 'http://www.example.com';
-print "not " unless $r->as_string eq <<EOT; print "ok 20\n";
+ok($r->as_string, <<EOT);
POST http://www.example.com
Content-Length: 0
Content-Type: application/x-www-form-urlencoded
@@ -207,7 +187,7 @@ Content-Type: application/x-www-form-urlencoded
EOT
$r = POST 'http://www.example.com', Content_Type => 'form-data', Content => [];
-print "not " unless $r->as_string eq <<EOT; print "ok 21\n";
+ok($r->as_string, <<EOT);
POST http://www.example.com
Content-Length: 0
Content-Type: multipart/form-data; boundary=none
@@ -216,10 +196,12 @@ EOT
$r = POST 'http://www.example.com', Content_Type => 'form-data';
#print $r->as_string;
-print "not " unless $r->as_string eq <<EOT; print "ok 22\n";
+ok($r->as_string, <<EOT);
POST http://www.example.com
Content-Length: 0
Content-Type: multipart/form-data
EOT
+$r = HTTP::Request::Common::DELETE 'http://www.example.com';
+ok($r->method, "DELETE");
@@ -1,4 +1,4 @@
-print "1..42\n";
+print "1..43\n";
#use LWP::Debug '+';
use HTTP::Cookies;
@@ -658,6 +658,15 @@ print "not " unless $c->as_string eq <<'EOT'; print "ok 42\n";
Set-Cookie3: Expires=10101; path="/"; domain=example.com; discard; version=0
EOT
+# Test empty cookie header [RT#29401]
+$c = HTTP::Cookies->new;
+$res->header("Set-Cookie" => ["CUSTOMER=WILE_E_COYOTE; path=/;", ""]);
+#print $res->as_string;
+$c->extract_cookies($res);
+#print $c->as_string;
+print "not " unless $c->as_string eq <<'EOT'; print "ok 43\n";
+Set-Cookie3: CUSTOMER=WILE_E_COYOTE; path="/"; domain=example.com; path_spec; discard; version=0
+EOT
#-------------------------------------------------------------------
@@ -3,7 +3,7 @@
use strict;
use Test qw(plan ok);
-plan tests => 156;
+plan tests => 157;
my($h, $h2);
sub j { join("|", @_) }
@@ -420,3 +420,9 @@ Content-Type: text/plain
content_type: text/html
foo_bar: 1
EOT
+
+# [RT#30579] IE6 appens "; length = NNNN" on If-Modified-Since (can we handle it)
+$h = HTTP::Headers->new(
+ if_modified_since => "Sat, 29 Oct 1994 19:43:31 GMT; length=34343"
+);
+ok(gmtime($h->if_modified_since), "Sat Oct 29 19:43:31 1994");
@@ -1,6 +1,6 @@
#!./perl -w
-print "1..14\n";
+print "1..15\n";
use strict;
#use Data::Dump ();
@@ -31,10 +31,6 @@ my $LF = "\012";
return $self;
}
- sub peerport {
- return 80;
- }
-
sub print {
my $self = shift;
#Data::Dump::dump("PRINT", @_);
@@ -153,7 +149,7 @@ print "not " unless $res->{error} =~ /Bad header/ && !$res->{code};
print "ok 6\n";
$h = undef; # it is in a bad state now
-$h = HTTP->new(Host => "a") || die; # reconnect
+$h = HTTP->new("a") || die; # reconnect
$res = $h->request(GET => "/09", [], {laxed => 1});
print "not " unless $res->{code} eq "200" && $res->{message} eq "Assumed OK" &&
$res->{content} eq "Hello${CRLF}World!${CRLF}" &&
@@ -196,3 +192,12 @@ print "ok 13\n";
$res = $h->request(TRACE => "/");
print "not " unless $res->{code} eq "200" && $res->{content} eq "TRACE / HTTP/1.0\r\n\r\n";
print "ok 14\n";
+
+require Net::HTTP;
+eval {
+ $h = Net::HTTP->new;
+};
+print "# $@";
+print "not " unless $@;
+print "ok 15\n";
+
@@ -1,4 +1,4 @@
-print "1..6\n";
+print "1..10\n";
use File::Listing;
@@ -84,3 +84,21 @@ print "ok 5\n";
$mode == 0100644 || print "not ";
print "ok 6\n";
+
+@dir = parse_dir(<<'EOT');
+drwxr-xr-x 21 root root 704 2007-03-22 21:48 dir
+EOT
+
+print "not " unless @dir == 1;
+print "ok 7\n";
+
+print "not " unless $dir[0][0] eq "dir";
+print "ok 8\n";
+
+print "not " unless $dir[0][1] eq "d";
+print "ok 9\n";
+
+$timestring = scalar(localtime($dir[0][3]));
+print "# $timestring\n";
+print "not " unless $timestring =~ /^Thu Mar 22 21:48/;
+print "ok 10\n";
@@ -3,10 +3,10 @@
use strict;
use Test qw(plan ok skip);
-plan tests => 95;
+plan tests => 104;
require HTTP::Message;
-require Config;
+use Config qw(%Config);
my($m, $m2, @parts);
@@ -281,6 +281,22 @@ b<CR>
EOT
$m = HTTP::Message->new;
+$m->add_part(HTTP::Message->new([a=>[1..3]], "a"));
+$str = $m->as_string;
+$str =~ s/\r/<CR>/g;
+ok($str, <<EOT);
+Content-Type: multipart/mixed; boundary=xYzZY
+
+--xYzZY<CR>
+A: 1<CR>
+A: 2<CR>
+A: 3<CR>
+<CR>
+a<CR>
+--xYzZY--<CR>
+EOT
+
+$m = HTTP::Message->new;
$m->content_ref(\my $foo);
ok($m->content_ref, \$foo);
$foo = "foo";
@@ -339,23 +355,29 @@ $m->header("Content-Encoding", "gzip, base64");
$m->content_type("text/plain; charset=UTF-8");
$m->content("H4sICFWAq0ECA3h4eAB7v3u/R6ZCSUZqUarCoxm7uAAZKHXiEAAAAA==\n");
+my $NO_ENCODE = $] < 5.008 || ($Config{'extensions'} !~ /\bEncode\b/)
+ ? "No Encode module" : "";
$@ = "";
-skip($] < 5.008 || ($Config::Config{'extensions'} !~ /\bEncode\b/)
- ? "No Encode module" : "",
- sub { eval { $m->decoded_content } }, "\x{FEFF}Hi there \x{263A}\n");
+skip($NO_ENCODE, sub { eval { $m->decoded_content } }, "\x{FEFF}Hi there \x{263A}\n");
ok($@ || "", "");
ok($m->content, "H4sICFWAq0ECA3h4eAB7v3u/R6ZCSUZqUarCoxm7uAAZKHXiEAAAAA==\n");
+ok(grep { $_ eq "gzip" } $m->decodable);
+
my $tmp = MIME::Base64::decode($m->content);
$m->content($tmp);
$m->header("Content-Encoding", "gzip");
$@ = "";
-skip($] < 5.008 || ($Config::Config{'extensions'} !~ /\bEncode\b/)
- ? "No Encode module" : "",
- sub { eval { $m->decoded_content } }, "\x{FEFF}Hi there \x{263A}\n");
+skip($NO_ENCODE, sub { eval { $m->decoded_content } }, "\x{FEFF}Hi there \x{263A}\n");
ok($@ || "", "");
ok($m->content, $tmp);
+$m->remove_header("Content-Encoding");
+$m->content("a\xFF");
+
+skip($NO_ENCODE, sub { $m->decoded_content }, "a\x{FFFD}");
+skip($NO_ENCODE, sub { $m->decoded_content(charset_strict => 1) }, undef);
+
$m->header("Content-Encoding", "foobar");
ok($m->decoded_content, undef);
ok($@ =~ /^Don't know how to decode Content-Encoding 'foobar'/);
@@ -367,3 +389,34 @@ eval {
};
ok($@ =~ /Don't know how to decode Content-Encoding 'foobar'/);
ok($err, 0);
+
+if ($] >= 5.008001) {
+ eval {
+ HTTP::Message->new([], "\x{263A}");
+ };
+ ok($@ =~ /bytes/);
+ $m = HTTP::Message->new;
+ eval {
+ $m->add_content("\x{263A}");
+ };
+ ok($@ =~ /bytes/);
+ eval {
+ $m->content("\x{263A}");
+ };
+ ok($@ =~ /bytes/);
+}
+else {
+ skip("Missing is_utf8 test", undef) for 1..3;
+}
+
+# test the add_content_utf8 method
+if ($] >= 5.008001) {
+ $m = HTTP::Message->new(["Content-Type", "text/plain; charset=UTF-8"]);
+ $m->add_content_utf8("\x{263A}");
+ $m->add_content_utf8("-\xC5");
+ ok($m->content, "\xE2\x98\xBA-\xC3\x85");
+ ok($m->decoded_content, "\x{263A}-\x{00C5}");
+}
+else {
+ skip("Missing is_utf8 test", undef) for 1..2;
+}
@@ -0,0 +1,26 @@
+# Test extra HTTP::Request methods. Basic operation is tested in the
+# message.t test suite.
+
+use strict;
+
+use Test;
+plan tests => 7;
+
+use HTTP::Request;
+
+my $req = HTTP::Request->new(GET => "http://www.example.com");
+$req->accept_decodable;
+
+ok($req->method, "GET");
+ok($req->uri, "http://www.example.com");
+ok($req->header("Accept-Encoding") =~ /\bgzip\b/); # assuming Compress::Zlib is there
+
+($_ = $req->as_string) =~ s/^/# /gm;
+print;
+
+ok($req->method("DELETE"), "GET");
+ok($req->method, "DELETE");
+
+ok($req->uri("http:"), "http://www.example.com");
+ok($req->uri, "http:");
+
@@ -0,0 +1,68 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use lib '.';
+use Test::More tests => 16;
+use HTML::Form;
+
+my $html = do { local $/ = undef; <DATA> };
+my $form = HTML::Form->parse($html, 'foo.html' );
+isa_ok($form, 'HTML::Form');
+my $input = $form->find_input('passwd');
+isa_ok($input, 'HTML::Form::TextInput');
+
+sub set_value {
+ my $input = shift;
+ my $value = shift;
+ my $len = length($value);
+ my $old = $input->value;
+ is( $input->value($value), $old, "set value length=$len" );
+ is( $input->value, $value, "got value length=$len" );
+}
+
+{
+ my @warnings;
+ local $SIG{__WARN__} = sub { push @warnings, @_; };
+ is( $input->{maxlength}, 8, 'got maxlength: 8' );
+
+ $^W = 0;
+
+ set_value( $input, '1234' );
+ is( @warnings, 0, "No warnings so far" );
+
+ set_value( $input, '1234567890' );
+ is( @warnings, 0, "No warnings so far" );
+
+ $^W = 1;
+
+ set_value( $input, '1234' );
+ is( @warnings, 0, "No warnings so far" );
+
+ set_value( $input, '1234567890' );
+ is( @warnings, 1, "Got warning" );
+ like( $warnings[0], qr/^Input 'passwd' has maxlength '8' at /, "Got warning message" );
+}
+
+__DATA__
+
+<form method="post" action="?" enctype="application/x-www-form-urlencoded" name="login">
+<div style="display:none"><input type="hidden" name="node_id" value="109"></div>
+<input type="hidden" name="op" value="login" />
+<input type="hidden" name="lastnode_id" value="109" />
+<table border="0"><tr><td><font size="2">
+Login:</font></td><td>
+<input type="text" name="user" size=10 maxlength=34 />
+</td></tr><tr><td><font size="2">
+Password</font></td><td>
+<input type="password" name="passwd" size=10 MAXLENGTH=8 />
+
+</td></tr></table><font size="2">
+<input type="checkbox" name="expires" value="+10y" />remember me
+<input type="submit" name="login" value="Login" />
+</font><br />
+<a href="?node=What%27s%20my%20password%3F">password reminder</a>
+<br />
+<a href="?node_id=101">Create A New User</a>
+</form>
+
@@ -0,0 +1,97 @@
+#!/usr/bin/perl
+
+# Test for case when multiple forms are on a page with same-named <select> fields.
+
+use strict;
+use Test::More tests => 2;
+use HTML::Form;
+
+{
+ my $test = "the settings of a previous form should not interfere with a latter form (control test with one form)";
+ my @forms = HTML::Form->parse( FakeResponse::One->new );
+ my $cat_form = $forms[0];
+ my @vals = $cat_form->param('age');
+ is_deeply(\@vals,[''], $test);
+}
+{
+ my $test = "the settings of a previous form should not interfere with a latter form (test with two forms)";
+ my @forms = HTML::Form->parse( FakeResponse::TwoForms->new );
+ my $cat_form = $forms[1];
+
+ my @vals = $cat_form->param('age');
+ is_deeply(\@vals,[''], $test);
+}
+
+####
+package FakeResponse::One;
+sub new {
+ bless {}, shift;
+}
+sub base {
+ return "http://foo.com"
+}
+sub decoded_content {
+ my $html = qq{
+ <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+ <html xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <title></title>
+ </head>
+ <body>
+
+ <form name="search_cats">
+ <select name="age" onChange="jumpTo(this)" class="sap-form-item">
+ <option value="" selected="selected">Any</option>
+ <option value="young">Young</option>
+ <option value="adult">Adult</option>
+ <option value="senior">Senior</option>
+ <option value="puppy">Puppy </option>
+ </select>
+ </form>
+ </body></html>
+ };
+ return \$html;
+}
+
+#####
+package FakeResponse::TwoForms;
+sub new {
+ bless {}, shift;
+}
+sub base {
+ return "http://foo.com"
+}
+sub decoded_content {
+ my $html = qq{
+ <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+ <html xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <title></title>
+ </head>
+ <body>
+ <form name="search_dogs" >
+ <select name="age" onChange="jumpTo(this)" class="sap-form-item">
+ <option value="" selected="selected">Any</option>
+ <option value="young">Young</option>
+ <option value="adult">Adult</option>
+ <option value="senior">Senior</option>
+ <option value="puppy">Puppy </option>
+ </select>
+ </form>
+
+
+ <form name="search_cats">
+ <select name="age" onChange="jumpTo(this)" class="sap-form-item">
+ <option value="" selected="selected">Any</option>
+ <option value="young">Young</option>
+ <option value="adult">Adult</option>
+ <option value="senior">Senior</option>
+ <option value="puppy">Puppy </option>
+ </select>
+ </form>
+ </body></html>
+ };
+ return \$html;
+}
@@ -3,7 +3,7 @@
use strict;
use Test qw(plan ok);
-plan tests => 122;
+plan tests => 127;
use HTML::Form;
@@ -417,6 +417,38 @@ ok($@ && $@ =~ /^The value '2' has been disabled/);
ok(eval{$f->find_input("m3", undef, 2)->value(undef)}, undef);
ok($@ && $@ =~ /^The 'm3' field can't be unchecked/);
+# multiple select with the same name [RT#18993]
+$f = HTML::Form->parse(<<EOT, "http://localhost/");
+<form action="target.html" method="get">
+<select name="bug">
+<option selected value=hi>hi
+<option value=mom>mom
+</select>
+<select name="bug">
+<option value=hi>hi
+<option selected value=mom>mom
+</select>
+<select name="nobug">
+<option value=hi>hi
+<option selected value=mom>mom
+</select>
+EOT
+ok(join("|", $f->form), "bug|hi|bug|mom|nobug|mom");
+
+# Try a disabled radiobutton:
+$f = HTML::Form->parse(<<EOT, "http://localhost/");
+<form>
+ <input disabled checked type=radio name=f value=a>
+ <input type=hidden name=f value=b>
+</form>
+
+EOT
+
+ok($f->click->as_string, <<'EOT');
+GET http://localhost/?f=b
+
+EOT
+
$f = HTML::Form->parse(<<EOT, "http://www.example.com");
<!-- from http://www.blooberry.com/indexdot/html/tagpages/k/keygen.htm -->
<form METHOD="post" ACTION="http://example.com/secure/keygen/test.cgi" ENCTYPE="application/x-www-form-urlencoded">
@@ -503,3 +535,48 @@ ok(join(":", $f->find_input("r1")->value_names), "one");
ok(join(":", $f->find_input("r2")->value_names), "two");
ok(join(":", $f->find_input("r3")->value_names), "nested");
ok(join(":", $f->find_input("r4")->value_names), "before and after");
+
+$f = HTML::Form->parse(<<EOT, "http://www.example.com");
+<form>
+ <table>
+ <TR>
+ <TD align="left" colspan="2">
+ Keep me informed on the progress of this election
+ <INPUT type="checkbox" id="keep_informed" name="keep_informed" value="yes" checked>
+ </TD>
+ </TR>
+ <TR>
+ <TD align=left colspan=2>
+ <BR><B>The place you are registered to vote:</B>
+ </TD>
+ </TR>
+ <TR>
+ <TD valign="middle" height="2" align="right">
+ <A name="Note1back">County or Parish</A>
+ </TD>
+ <TD align="left">
+ <INPUT type="text" id="reg_county" size="40" name="reg_county" value="">
+ </TD>
+ <TD align="left" width="10">
+ <A href="#Note2" class="c2" tabindex="-1">Note 2</A>
+ </TD>
+ </TR>
+ </table>
+</form>
+EOT
+ok(join(":", $f->find_input("keep_informed")->value_names), "off:");
+
+$f = HTML::Form->parse(<<EOT, "http://www.example.com");
+<form action="test" method="post">
+<select name="test">
+<option value="1">One</option>
+<option value="2">Two</option>
+<option disabled="disabled" value="3">Three</option>
+</select>
+<input type="submit" name="submit" value="Go">
+</form>
+</body>
+</html>
+EOT
+ok(join(":", $f->find_input("test")->possible_values), "1:2");
+ok(join(":", $f->find_input("test")->other_possible_values), "2");
@@ -8,9 +8,7 @@ my $ok = 1;
# some sample URLs
my @urls = (
- "http://www.apache.org/~jon/scarab/nightly/",
"http://www.apache.org/dist/apr/?C=N&O=D",
- "http://xml.apache.org/dist/batik/",
"http://perl.apache.org/rpm/distrib/",
"http://stein.cshl.org/WWW/software/",
"http://www.cpan.org/modules/by-module/",
@@ -0,0 +1,23 @@
+#!perl -w
+
+use strict;
+use LWP::UserAgent;
+
+my $ua = LWP::UserAgent->new();
+my $res = $ua->simple_request(HTTP::Request->new(GET => "https://www.sun.com"));
+
+if ($res->code == 501 && $res->message =~ /Protocol scheme 'https' is not supported/) {
+ print "1..0 # Skipped: " . $res->message . "\n";
+ exit;
+}
+
+print "1..2\n";
+print "not " unless $res->is_success;
+print "ok 1\n";
+
+print "not " unless $res->content =~ /Sun Microsystems/;
+print "ok 2\n";
+
+my $cref = $res->content_ref;
+substr($$cref, 100) = "..." if length($$cref) > 100;
+print "\n", $res->as_string;
@@ -1,20 +1,5 @@
#!perl -w
-my $zlib_ok;
-for (("", "live/", "t/live/")) {
- if (-f $_ . "ZLIB_OK") {
- $zlib_ok++;
- last;
- }
-}
-
-unless ($zlib_ok) {
- print "1..0\n";
- print "Apparently no working ZLIB installed\n";
- exit;
-}
-
-
print "1..4\n";
use strict;