+_______________________________________________________________________________
+2013-03-11 Release 6.05
+
+Karen Etheridge (3):
+ Derive message from status code if it was not provided
+ Merge pull request #33 from tomhukins/fix-readme
+ fix typo in comment
+
+Ville Skyttä (3):
+ Spelling fixes.
+ Spelling fix.
+ Merge pull request #34 from berekuk/fix-github-path
+
+Gisle Aas (3):
+ Update repo URL
+ With Net::HTTP 6.04 we don't need our own can_read() and sysread override
+ $ENV{HTTP_PROXY} might override our test setup [RT#81381]
+
+Vyacheslav Matyukhin (1):
+ fix github url in perldoc
+
+Slaven Rezic (1):
+ * Pod is utf-8
+
+Peter Rabbitson (1):
+ Match required perl in Makefile.PL
+
+Tom Hukins (1):
+ Fix Github URLs
+
+
+
+
+_______________________________________________________________________________
+2012-02-18 Release 6.04
+
+Gisle Aas (4):
+ Typo fix; envirionment [RT#72386]
+ Implement $ua->is_online test
+ Add separate option to enable the live jigsaw tests
+ Merge pull request #10 from trcjr/master
+
+Theodore Robert Campbell Jr (3):
+ now with put and delete helpers
+ updated POD
+ unit tests for ua->put and ua->delete
+
+Peter Rabbitson (1):
+ These modules work with 5.8.1
+
+
+
+
+_______________________________________________________________________________
+2011-10-15 Release 6.03
+
+Ville Skyttä (7):
+ Link updates.
+ Attribute documentation wording improvements.
+ Don't parse robots.txt response content unless it's textual.
+ Decode robots.txt response content before attempting to parse it.
+ RobotUA robots.txt response parsing cleanups.
+ Don't parse HEAD of robots.txt responses.
+ Request handler doc grammar fixes.
+
+Gisle Aas (6):
+ Pass on HTTP/1.0 if set as request protocol
+ Remove outdated docs (not touched since 1996 :-)
+ Merge pull request #22 from madsen/RT67947-verify_hostname
+ PERL_LWP_ENV_PROXY tweaks
+ lwp-request didn't respect -H Content-type [RT#70488]
+ lwp-request -H didn't allow repeated headers
+
+Christopher J. Madsen (2):
+ verify_hostname defaults to 0 if ssl_opts provided [RT#67947]
+ Test verify_hostname setting
+
+Bryan Cardillo (1):
+ Fix expect header support to work with content refs.
+
+Moritz Onken (1):
+ add PERL_LWP_ENV_PROXY env variable to enable env_proxy globally
+
+
+
+_______________________________________________________________________________
+2011-03-27 Release 6.02
+
+This is the release where we try to help the CPAN-toolchain be able to install
+the modules required for https-support in LWP. We have done this by unbundling
+the LWP::Protocol::https module from the libwww-perl distribution. In order to
+have https support you now need to install (or depend on) 'LWP::Protocol::https'
+and then this will make sure that all the prerequsite modules comes along.
+See [RT#66838].
+
+This release also removes the old http10 modules that has really been
+deprecated since v5.60. These should have been removed at the v6.00 jump, but
+I forgot.
+
+
+Christopher J. Madsen (1):
+ Ignores env variables when ssl_opts provided [RT#66663]
+
+Gisle Aas (4):
+ Fix typo; Authen::NTLM [RT#66884]
+
+Yury Zavarin (1):
+ Support LWP::ConnCache->new(total_capacity => undef)
+
+
+
+_______________________________________________________________________________
+2011-03-09 Release 6.01
+
+Add missing HTTP::Daemon dependency for the tests.
+
+
+
+_______________________________________________________________________________
+2011-03-08 Release 6.00
+
+Unbundled all modules not in the LWP:: namespace from the libwww-perl
+distribution. The new broken out CPAN distribtions are File-Listing,
+HTML-Form, HTTP-Cookies, HTTP-Daemon, HTTP-Date, HTTP-Message, HTTP-Negotiate,
+Net-HTTP, and WWW-RobotRules. libwww-perl-6 require these to be installed.
+
+This release also drops the unmaintained lwp-rget script from the distribution.
+
+Perl v5.8.8 or better is now required. For older versions of perl please stay
+with libwww-perl-5.837.
+
+For https://... default to verified connections with require IO::Socket::SSL
+and Mozilla::CA modules to be installed. Old behaviour can be requested by
+setting the PERL_LWP_SSL_VERIFY_HOSTNAME environment variable to 0. The
+LWP::UserAgent got new ssl_opts method to control this as well.
+
+Support internationalized URLs from command line scripts and in the proxy
+environment variables.
+
+The lwp-dump script got new --request option.
+
+The lwp-request script got new -E option, contributed by Tony Finch.
+
+Protocol handlers and callbacks can raise HTTP::Response objects as exceptions.
+This will abort the current request and make LWP return the raised response.
+
+
+
_______________________________________________________________________________
2010-09-20 Release 5.837
_______________________________________________________________________________
2009-06-25 Release 5.828
-A quick new release to restore compatiblity with perl-5.6.
+A quick new release to restore compatibility with perl-5.6.
Gisle Aas (4):
Less noisy behaviour when we can't download the documents
- Restore perl-5.6 compatiblity [RT#47054]
+ Restore perl-5.6 compatibility [RT#47054]
Don't decode US-ASCII and ISO-8859-1 content
Some versions of Encode don't support UTF-16-BE [RT#47152]
bin/lwp-dump Writes bin/lwp-dump script
bin/lwp-mirror Writes bin/lwp-mirror script
bin/lwp-request Writes bin/lwp-request script
-bin/lwp-rget Writes bin/lwp-rget script
talk-to-ourself Are we able to run tests talk HTTP to local server?
-lib/Bundle/LWP.pm Defines prereq modules
-lib/File/Listing.pm Parse directory listings
-lib/HTML/Form.pm Parse <form>...</form>
-lib/HTTP/Config.pm Look up stuff based on request/reponse properties
-lib/HTTP/Cookies.pm Cookie storage and management
-lib/HTTP/Cookies/Netscape.pm Deal with the Netscape cookie file format
-lib/HTTP/Cookies/Microsoft.pm Deal with the Microsoft MSIE cookie file format
-lib/HTTP/Daemon.pm A simple httpd
-lib/HTTP/Date.pm Date conversion routines
-lib/HTTP/Headers.pm Class encapsulating HTTP Message headers
-lib/HTTP/Headers/Auth.pm Some methods that deal with authorization.
-lib/HTTP/Headers/ETag.pm Some methods that deal with entity tags
-lib/HTTP/Headers/Util.pm Some utility functions for header values.
-lib/HTTP/Message.pm Class encapsulating HTTP messages
-lib/HTTP/Negotiate.pm Evaluate HTTP content negotiation algoritm
-lib/HTTP/Request.pm Class encapsulating HTTP Requests
-lib/HTTP/Request/Common.pm Generate common requests
-lib/HTTP/Response.pm Class encapsulating HTTP Responses
-lib/HTTP/Status.pm HTTP Status code processing
lib/LWP.pm Includes what you need
lib/LWP/Authen/Basic.pm Basic authentication scheme
lib/LWP/Authen/Digest.pm Digest authentication scheme
lib/LWP/ConnCache.pm Connection cache
lib/LWP/Debug.pm Debugging support
lib/LWP/DebugFile.pm Send debug output to a file
-lib/LWP/MediaTypes.pm Library for guessing media types
lib/LWP/MemberMixin.pm Helps you access %$self
lib/LWP/Protocol.pm Virtual base class for LWP protocols
lib/LWP/Protocol/GHTTP.pm Alternative HTTP protocol handler
lib/LWP/Protocol/ftp.pm Access with the FTP protocol
lib/LWP/Protocol/gopher.pm Access with the Gopher protocol
lib/LWP/Protocol/http.pm Access with HTTP/1.1 protocol
-lib/LWP/Protocol/http10.pm Access with HTTP/1.0 protocol
-lib/LWP/Protocol/https.pm Access with HTTP/1.1 protocol over SSL
-lib/LWP/Protocol/https10.pm Access with HTTP/1.0 protocol over SSL
lib/LWP/Protocol/loopback.pm Returns request (like HTTP TRACE)
lib/LWP/Protocol/mailto.pm Allows you to POST mail using sendmail
lib/LWP/Protocol/nntp.pm Handles access to news: and nntp: URLs
lib/LWP/RobotUA.pm Easy creation of conforming robots
lib/LWP/Simple.pm Procedural LWP interface
lib/LWP/UserAgent.pm A WWW UserAgent class
-lib/LWP/media.types Mapping from file extentions media types
-lib/Net/HTTP.pm Lower level HTTP on an IO::Socket::INET
-lib/Net/HTTP/Methods.pm Lower level HTTP/1.1 protocol
-lib/Net/HTTP/NB.pm Non-blocking HTTP
-lib/Net/HTTPS.pm Lower level HTTP on an SSL socket
-lib/WWW/RobotRules.pm Parse robot.txt files
-lib/WWW/RobotRules/AnyDBM_File.pm Persistent robot rules
lwpcook.pod Libwww-perl examples
lwptut.pod Libwww-perl tutorial
t/README How to run and set up tests
t/TEST Run tests
-t/base/common-req.t Test HTTP::Request::Common module
-t/base/cookies.t Test HTTP::Cookies module
-t/base/date.t Test HTTP::Date module
-t/base/headers-auth.t Test HTTP::Headers::Auth module
-t/base/headers-etag.t Test HTTP::Headers::ETag module
-t/base/headers-util.t Test HTTP::Headers::Util module
-t/base/headers.t Test HTTP::Headers module
-t/base/http.t Test Net::HTTP::Methods module
-t/base/http-config.t Test HTTP::Config module
-t/base/listing.t Test File::Listing module
-t/base/mediatypes.t Test LWP::MediaTypes module
-t/base/message.t Test HTTP::Message
-t/base/message-charset.t Test HTTP::Message content_charset method
-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/status-old.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/html/form-selector.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
-t/live/jigsaw-md5-get.t
-t/live/jigsaw-md5.t
-t/live/jigsaw-neg-get.t
-t/live/jigsaw-neg.t
-t/live/jigsaw-te.t
+t/live/apache-http10.t
+t/live/online.t
+t/live/jigsaw/auth-b.t
+t/live/jigsaw/auth-d.t
+t/live/jigsaw/chunk.t
+t/live/jigsaw/md5-get.t
+t/live/jigsaw/md5.t
+t/live/jigsaw/neg-get.t
+t/live/jigsaw/neg.t
+t/live/jigsaw/te.t
t/local/autoload-get.t
t/local/autoload.t Test autoloading of LWP::Protocol modules
-t/local/chunked.t
t/local/get.t Try to get a local file
t/local/http.t Test http to local server
t/local/protosub.t Test with other protocol module
t/net/mirror.t
t/net/moved.t
t/net/proxy.t
-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)
--- #YAML:1.0
name: libwww-perl
-version: 5.837
+version: 6.05
abstract: The World-Wide Web library for Perl
author:
- Gisle Aas <gisle@activestate.com>
build_requires:
ExtUtils::MakeMaker: 0
requires:
- Compress::Raw::Zlib: 0
Digest::MD5: 0
- HTML::Parser: 3.33
- HTML::Tagset: 0
- IO::Compress::Deflate: 0
- IO::Compress::Gzip: 0
- IO::Uncompress::Gunzip: 0
- IO::Uncompress::Inflate: 0
- IO::Uncompress::RawInflate: 0
+ Encode: 2.12
+ Encode::Locale: 0
+ File::Listing: 6
+ HTML::Entities: 0
+ HTML::HeadParser: 0
+ HTTP::Cookies: 6
+ HTTP::Daemon: 6
+ HTTP::Date: 6
+ HTTP::Negotiate: 6
+ HTTP::Request: 6
+ HTTP::Request::Common: 6
+ HTTP::Response: 6
+ HTTP::Status: 6
+ IO::Select: 0
+ IO::Socket: 0
+ LWP::MediaTypes: 6
MIME::Base64: 2.1
Net::FTP: 2.58
- perl: 5.006
+ Net::HTTP: 6.04
+ perl: 5.008001
URI: 1.10
+ URI::Escape: 0
+ WWW::RobotRules: 6
resources:
MailingList: mailto:libwww@perl.org
- repository: http://github.com/gisle/libwww-perl
+ repository: https://github.com/libwww-perl/libwww-perl
no_index:
directory:
- t
- inc
-generated_by: ExtUtils::MakeMaker version 6.56
+generated_by: ExtUtils::MakeMaker version 6.57_05
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
recommends:
- Crypt::SSLeay: 0
+ Authen::NTLM: 1.02
+ Data::Dump: 0
+ LWP::Protocol::https: 6.02
#!perl -w
-require 5.006;
+require 5.008001;
use strict;
use ExtUtils::MakeMaker;
use Getopt::Long qw(GetOptions);
'aliases',
'no-programs|n',
'live-tests',
+ 'jigsaw-tests',
) or do {
- die "Usage: $0 [--aliases] [--no-programs] [--live-tests]\n";
+ die "Usage: $0 [--aliases] [--no-programs] [--live-tests] [--jigsaw-tests]\n";
};
my @prog;
-push(@prog, qw(lwp-request lwp-mirror lwp-rget lwp-download lwp-dump))
+push(@prog, qw(lwp-request lwp-mirror lwp-download lwp-dump))
unless $opt{'no-programs'} || grep /^LIB=/, @ARGV;
if ($opt{'aliases'} && grep(/lwp-request/, @prog)) {
system($^X, "talk-to-ourself");
flag_file("t/CAN_TALK_TO_OURSELF", $? == 0);
flag_file("t/live/ENABLED", $opt{'live-tests'});
+flag_file("t/live/jigsaw/ENABLED", $opt{'jigsaw-tests'});
WriteMakefile(
NAME => 'LWP',
AUTHOR => 'Gisle Aas <gisle@activestate.com>',
EXE_FILES => [ map "bin/$_", @prog ],
LICENSE => "perl",
- MIN_PERL_VERSION => 5.006,
+ MIN_PERL_VERSION => 5.008001,
PREREQ_PM => {
- 'URI' => "1.10",
- 'MIME::Base64' => "2.1",
- 'Net::FTP' => "2.58",
- 'HTML::Tagset' => 0,
- 'HTML::Parser' => "3.33",
- 'Digest::MD5' => 0,
- 'Compress::Raw::Zlib' => 0,
- 'IO::Compress::Gzip' => 0,
- 'IO::Compress::Deflate' => 0,
- 'IO::Uncompress::Gunzip' => 0,
- 'IO::Uncompress::Inflate' => 0,
- 'IO::Uncompress::RawInflate' => 0,
+ 'Digest::MD5' => 0,
+ 'Encode' => "2.12",
+ 'Encode::Locale' => 0,
+ 'File::Listing' => 6,
+ 'HTML::Entities' => 0,
+ 'HTML::HeadParser' => 0,
+ 'HTTP::Cookies' => 6,
+ 'HTTP::Daemon' => 6,
+ 'HTTP::Date' => 6,
+ 'HTTP::Negotiate' => 6,
+ 'HTTP::Request' => 6,
+ 'HTTP::Request::Common' => 6,
+ 'HTTP::Response' => 6,
+ 'HTTP::Status' => 6,
+ 'IO::Select' => 0,
+ 'IO::Socket' => 0,
+ 'LWP::MediaTypes' => 6,
+ 'MIME::Base64' => "2.1",
+ 'Net::FTP' => "2.58",
+ 'Net::HTTP' => "6.04",
+ 'URI' => "1.10",
+ 'URI::Escape' => 0,
+ 'WWW::RobotRules' => 6,
},
META_MERGE => {
recommends => {
- 'Crypt::SSLeay' => 0,
+ 'LWP::Protocol::https' => '6.02',
+ 'Authen::NTLM' => "1.02",
+ 'Data::Dump' => 0,
},
resources => {
- repository => 'http://github.com/gisle/libwww-perl',
+ repository => 'https://github.com/libwww-perl/libwww-perl',
MailingList => 'mailto:libwww@perl.org',
}
},
clean => { FILES => join(" ", map "bin/$_", grep /^[A-Z]+$/, @prog) },
);
-if($] >= 5.008 && !(eval { require Encode; defined(Encode::decode("UTF-8", "\xff")) })) {
- warn "\nYou lack a working Encode module, and so you will miss out on\n".
- "lots of character set goodness from LWP. However, your perl is\n".
- "sufficiently recent to support it. It is recommended that you\n".
- "install the latest Encode from CPAN.\n\n";
-}
-
sub MY::test
BEGIN {
# compatibility with older versions of MakeMaker
- my $developer = -f "NOTES.txt";
+ my $developer = -f ".gitignore";
my %mm_req = (
LICENCE => 6.31,
META_MERGE => 6.45,
- L I B W W W - P E R L - 5
+ L I B W W W - P E R L - 6
-----------------------------
PREREQUISITES
In order to install and use this package you will need Perl version
-5.6 or better. Some modules within this package depend on other
+5.8.1 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
+ Digest-MD5
+ Encode-Locale
+ HTML-Form
HTML-Parser
+ HTML-Tagset
+ HTTP-Cookies
+ HTTP-Date
+ HTTP-Message
+ HTTP-Negotiate
libnet
- Digest-MD5
- Compress-Zlib
+ LWP-MediaTypes
+ MIME-Base64
+ Net-HTTP
+ URI
+ WWW-RobotRules
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.
+install the LWP::Protocol::https module from CPAN.
INSTALLATION
If you want to hack on the source it might be a good idea to grab the
latest version with git using the command:
- git clone git://github.com/gisle/libwww-perl.git lwp
+ git clone git://github.com/libwww-perl/libwww-perl.git lwp
You can also browse the git repository at:
- http://github.com/gisle/libwww-perl
+ https://github.com/libwww-perl/libwww-perl
COPYRIGHT
- © 1995-2009 Gisle Aas. All rights reserved.
+ © 1995-2010 Gisle Aas. All rights reserved.
© 1995 Martijn Koster. All rights reserved.
This library is free software; you can redistribute it and/or modify
-SSL SUPPORT
------------
+As of libwww-perl v6.02 you need to install the LWP::Protocol::https module
+from its own separate distribution to enable support for https://... URLs for
+LWP::UserAgent.
-The libwww-perl package has support for using SSL/TLSv1 with its HTTP
-client and server classes. This support makes it possible to access
-https schemed URLs with LWP. Because of the problematic status of
-encryption software in general and certain encryption algorithms in
-particular, in several countries, libwww-perl package doesn't include
-SSL functionality out-of-the-box.
-
-Encryption support is obtained through the use of Crypt::SSLeay or
-IO::Socket::SSL, which can both be found from CPAN. While libwww-perl
-has "plug-and-play" support for both of these modules (as of v5.45),
-the recommended module to use is Crypt::SSLeay. In addition to
-bringing SSL support to the LWP package, IO::Socket::SSL can be used
-as an object oriented interface to SSL encrypted network sockets.
-
-There is yet another SSL interface for perl called Net::SSLeay. It has
-a more complete SSL interface and can be used for web client
-programming among other things but doesn't directly support LWP.
-
-The underlying SSL support in all of these modules is based on OpenSSL
-<http://www.openssl.org/> (formerly SSLeay). For WWW-server side SSL
-support (e.g. CGI/FCGI scripts) in Apache see <http://www.modssl.org/>.
+This makes it possible for that distribution to state the required dependencies
+as non-optional. See <https://rt.cpan.org/Ticket/Display.html?id=66838> for
+further discussion why we ended up with this solution.
use LWP::MediaTypes qw(guess_media_type media_suffix);
use URI ();
use HTTP::Date ();
+use Encode;
+use Encode::Locale;
my $progname = $0;
$progname =~ s,.*/,,; # only basename left in progname
usage();
}
-my $url = URI->new(shift || usage());
-my $argfile = shift;
+my $url = URI->new(decode(locale => shift) || usage());
+my $argfile = encode(locale_fs => decode(locale => shift));
usage() if defined($argfile) && !length($argfile);
-my $VERSION = "5.835";
+my $VERSION = "6.00";
my $ua = LWP::UserAgent->new(
agent => "lwp-download/$VERSION ",
use strict;
use LWP::UserAgent ();
use Getopt::Long qw(GetOptions);
+use Encode;
+use Encode::Locale;
-my $VERSION = "5.827";
+my $VERSION = "6.00";
GetOptions(\my %opt,
'parse-head',
'keep-client-headers',
'method=s',
'agent=s',
+ 'request',
) || usage();
my $url = shift || usage();
--max-length <n>
--method <str>
--parse-head
+ --request
EOT
}
agent => $opt{agent} || "lwp-dump/$VERSION ",
);
-my $req = HTTP::Request->new($opt{method} || 'GET' => $url);
+my $req = HTTP::Request->new($opt{method} || 'GET' => decode(locale => $url));
my $res = $ua->simple_request($req);
$res->remove_header(grep /^Client-/, $res->header_field_names)
unless $opt{'keep-client-headers'} or
($res->header("Client-Warning") || "") eq "Internal response";
+if ($opt{request}) {
+ $res->request->dump;
+ print "\n";
+}
+
$res->dump(maxlength => $opt{'max-length'});
__END__
head section of HTML documents. This option enables this. This corresponds to
L<LWP::UserAgent/"parse_head">.
+=item B<--request>
+
+Also dump the request sent.
+
=back
=head1 SEE ALSO
=head1 DESCRIPTION
This program can be used to mirror a document from a WWW server. The
-document is only transfered if the remote copy is newer than the local
+document is only transferred if the remote copy is newer than the local
copy. If the local copy is newer nothing happens.
Use the C<-v> option to print the version number of this program.
use LWP::Simple qw(mirror is_success status_message $ua);
use Getopt::Std;
+use Encode;
+use Encode::Locale;
$progname = $0;
$progname =~ s,.*/,,; # use basename only
$progname =~ s/\.\w*$//; #strip extension if any
-$VERSION = "5.810";
+$VERSION = "6.05";
$opt_h = undef; # print usage
$opt_v = undef; # print version
EOT
}
-$url = shift or usage();
-$file = shift or usage();
+$url = decode(locale => shift) or usage();
+$file = encode(locale_fs => decode(locale => shift)) or usage();
usage() if $opt_h or @ARGV;
if (defined $opt_t) {
Print response headers. This option is always on for HEAD requests.
+=item -E
+
+Print response status chain with full response headers.
+
=item -d
Do B<not> print the content of the response.
$progname =~ s,.*[\\/],,; # use basename only
$progname =~ s/\.\w*$//; # strip extension, if any
-$VERSION = "5.834";
+$VERSION = "6.03";
require LWP;
use URI;
use URI::Heuristic qw(uf_uri);
+use Encode;
+use Encode::Locale;
use HTTP::Status qw(status_message);
use HTTP::Date qw(time2str str2time);
'C=s', # credentials for basic authorization
'H=s@', # extra headers, form "Header: value string"
#
- 'u', # display method, URL and headers of request
+ 'u', # display method and URL of request
'U', # display request headers also
's', # display status code
'S', # display whole chain of status codes
'e', # display response headers (default for HEAD)
+ 'E', # display whole chain of headers
'd', # don't display content
#
'h', # print usage
die "$progname: $method is not an allowed method\n";
}
+if ($options{'S'} || $options{'E'}) {
+ $options{'U'} = 1 if $options{'E'};
+ $options{'E'} = 1 if $options{'e'};
+ $options{'S'} = 1;
+ $options{'s'} = 1;
+ $options{'u'} = 1;
+}
+
if ($method eq "HEAD") {
$options{'s'} = 1;
$options{'e'} = 1 unless $options{'d'};
$options{'d'} = 1;
}
+$options{'u'} = 1 if $options{'U'};
+$options{'s'} = 1 if $options{'e'};
+
if (defined $options{'t'}) {
$options{'t'} =~ /^(\d+)([smh])?/;
die "$progname: Illegal timeout value!\n" unless defined $1;
}
$content = undef;
+$user_ct = undef;
if ($allowed_methods{$method} eq "C") {
# This request needs some content
unless (defined $options{'c'}) {
}
else {
die "$progname: Illegal Content-type format\n"
- unless $options{'c'} =~ m,^[\w\-]+/[\w\-.+]+(?:\s*;.*)?$,
+ unless $options{'c'} =~ m,^[\w\-]+/[\w\-.+]+(?:\s*;.*)?$,;
+ $user_ct++;
}
print STDERR "Please enter content ($options{'c'}) to be ${method}ed:\n"
if -t;
$request = HTTP::Request->new($method);
$request->header('If-Modified-Since', $options{'i'}) if defined $options{'i'};
for my $user_header (@{ $options{'H'} || [] }) {
- my ($header_name, $header_value) = split /:\s*/, $user_header, 2;
- $request->header($header_name, $header_value);
- $ua->agent($header_value) if lc($header_name) eq "user-agent"; # Ugh!
+ my ($header_name, $header_value) = split /\s*:\s*/, $user_header, 2;
+ $header_name =~ s/^\s+//;
+ if (lc($header_name) eq "user-agent") {
+ $header_value .= $ua->agent if $header_value =~ /\s\z/;
+ $ua->agent($header_value);
+ }
+ else {
+ $request->push_header($header_name, $header_value);
+ }
}
#$request->header('Accept', '*/*');
if ($options{'c'}) { # will always be set for request that wants content
- $request->header('Content-Type', $options{'c'});
+ my $header = ($user_ct ? 'header' : 'init_header');
+ $request->$header('Content-Type', $options{'c'});
$request->header('Content-Length', length $content); # Not really needed
$request->content($content);
}
$errors = 0;
+sub show {
+ my $r = shift;
+ my $last = shift;
+ print $method, " ", $r->request->uri->as_string, "\n" if $options{'u'};
+ print $r->request->headers_as_string, "\n" if $options{'U'};
+ print $r->status_line, "\n" if $options{'s'};
+ print $r->headers_as_string, "\n" if $options{'E'} or $last;
+}
+
# Ok, now we perform the requests, one URL at a time
while ($url = shift) {
# Create the URL object, but protect us against bad URLs
eval {
if ($url =~ /^\w+:/ || $options{'b'}) { # is there any scheme specification
- $url = URI->new($url, $options{'b'});
- $url = $url->abs($options{'b'}) if $options{'b'};
+ $url = URI->new(decode(locale => $url), decode(locale => $options{'b'}));
+ $url = $url->abs(decode(locale => $options{'b'})) if $options{'b'};
}
else {
$url = uf_uri($url);
next;
}
- $ua->proxy($url->scheme, $options{'p'}) if $options{'p'};
+ $ua->proxy($url->scheme, decode(locale => $options{'p'})) if $options{'p'};
# Send the request and get a response back from the server
$request->uri($url);
$response = $ua->request($request);
- if ($options{'u'} || $options{'U'}) {
- my $url = $response->request->uri->as_string;
- print "$method $url\n";
- print $response->request->headers_as_string, "\n" if $options{'U'};
- }
-
if ($options{'S'}) {
- for my $r ($response->redirects, $response) {
- my $method = $r->request->method;
- my $url = $r->request->uri->as_string;
- print "$method $url --> ", $r->status_line, "\n";
+ for my $r ($response->redirects) {
+ show($r);
}
}
- elsif ($options{'s'}) {
- print $response->status_line, "\n";
- }
-
- if ($options{'e'}) {
- # Display headers
- print $response->headers_as_string;
- print "\n"; # separate headers and content
- }
+ show($response, $options{'e'});
unless ($options{'d'}) {
if ($options{'o'} &&
-u Display method and URL before any response
-U Display request headers (implies -u)
-s Display response status code
- -S Display response status chain
- -e Display response headers
+ -S Display response status chain (implies -u)
+ -e Display response headers (implies -s)
+ -E Display whole chain of headers (implies -S and -U)
-d Do not display content
-o <format> Process HTML content in various ways
+++ /dev/null
-#!/usr/bin/perl -w
-
-=head1 NAME
-
-lwp-rget - Retrieve web documents recursively
-
-=head1 SYNOPSIS
-
- lwp-rget [--verbose] [--auth=USER:PASS] [--depth=N] [--hier] [--iis]
- [--keepext=mime/type[,mime/type]] [--limit=N] [--nospace]
- [--prefix=URL] [--referer=URL] [--sleep=N] [--tolower] <URL>
- lwp-rget --version
-
-=head1 DESCRIPTION
-
-This program will retrieve a document and store it in a local file. It
-will follow any links found in the document and store these documents
-as well, patching links so that they refer to these local copies.
-This process continues until there are no more unvisited links or the
-process is stopped by the one or more of the limits which can be
-controlled by the command line arguments.
-
-This program is useful if you want to make a local copy of a
-collection of documents or want to do web reading off-line.
-
-All documents are stored as plain files in the current directory. The
-file names chosen are derived from the last component of URL paths.
-
-The options are:
-
-=over 3
-
-=item --auth=USER:PASS<n>
-
-Set the authentication credentials to user "USER" and password "PASS" if
-any restricted parts of the web site are hit. If there are restricted
-parts of the web site and authentication credentials are not available,
-those pages will not be downloaded.
-
-=item --depth=I<n>
-
-Limit the recursive level. Embedded images are always loaded, even if
-they fall outside the I<--depth>. This means that one can use
-I<--depth=0> in order to fetch a single document together with all
-inline graphics.
-
-The default depth is 5.
-
-=item --hier
-
-Download files into a hierarchy that mimics the web site structure.
-The default is to put all files in the current directory.
-
-=item --referer=I<URI>
-
-Set the value of the Referer header for the initial request. The
-special value C<"NONE"> can be used to suppress the Referer header in
-any of subsequent requests. The Referer header will always be suppressed
-in all normal C<http> requests if the referring page was transmitted over
-C<https> as recommended in RFC 2616.
-
-=item --iis
-
-Sends an "Accept: */*" on all URL requests as a workaround for a bug in
-IIS 2.0. If no Accept MIME header is present, IIS 2.0 returns with a
-"406 No acceptable objects were found" error. Also converts any back
-slashes (\\) in URLs to forward slashes (/).
-
-=item --keepext=I<mime/type[,mime/type]>
-
-Keeps the current extension for the list MIME types. Useful when
-downloading text/plain documents that shouldn't all be translated to
-*.txt files.
-
-=item --limit=I<n>
-
-Limit the number of documents to get. The default limit is 50.
-
-=item --nospace
-
-Changes spaces in all URLs to underscore characters (_). Useful when
-downloading files from sites serving URLs with spaces in them. Does not
-remove spaces from fragments, e.g., "file.html#somewhere in here".
-
-=item --prefix=I<url_prefix>
-
-Limit the links to follow. Only URLs that start the prefix string are
-followed.
-
-The default prefix is set as the "directory" of the initial URL to
-follow. For instance if we start lwp-rget with the URL
-C<http://www.sn.no/foo/bar.html>, then prefix will be set to
-C<http://www.sn.no/foo/>.
-
-Use C<--prefix=''> if you don't want the fetching to be limited by any
-prefix.
-
-=item --sleep=I<n>
-
-Sleep I<n> seconds before retrieving each document. This options allows
-you to go slowly, not loading the server you visiting too much.
-
-=item --tolower
-
-Translates all links to lowercase. Useful when downloading files from
-IIS since it does not serve files in a case sensitive manner.
-
-=item --verbose
-
-Make more noise while running.
-
-=item --quiet
-
-Don't make any noise.
-
-=item --version
-
-Print program version number and quit.
-
-=item --help
-
-Print the usage message and quit.
-
-=back
-
-Before the program exits the name of the file, where the initial URL
-is stored, is printed on stdout. All used filenames are also printed
-on stderr as they are loaded. This printing can be suppressed with
-the I<--quiet> option.
-
-=head1 SEE ALSO
-
-L<lwp-request>, L<LWP>
-
-=head1 AUTHOR
-
-Gisle Aas <aas@sn.no>
-
-=cut
-
-use strict;
-
-use Getopt::Long qw(GetOptions);
-use URI::URL qw(url);
-use LWP::MediaTypes qw(media_suffix);
-use HTML::Entities ();
-
-use vars qw($VERSION);
-use vars qw($MAX_DEPTH $MAX_DOCS $PREFIX $REFERER $VERBOSE $QUIET $SLEEP $HIER $AUTH $IIS $TOLOWER $NOSPACE %KEEPEXT);
-
-my $progname = $0;
-$progname =~ s|.*/||; # only basename left
-$progname =~ s/\.\w*$//; #strip extension if any
-
-$VERSION = "5.827";
-
-#$Getopt::Long::debug = 1;
-#$Getopt::Long::ignorecase = 0;
-
-# Defaults
-$MAX_DEPTH = 5;
-$MAX_DOCS = 50;
-
-GetOptions('version' => \&print_version,
- 'help' => \&usage,
- 'depth=i' => \$MAX_DEPTH,
- 'limit=i' => \$MAX_DOCS,
- 'verbose!' => \$VERBOSE,
- 'quiet!' => \$QUIET,
- 'sleep=i' => \$SLEEP,
- 'prefix:s' => \$PREFIX,
- 'referer:s'=> \$REFERER,
- 'hier' => \$HIER,
- 'auth=s' => \$AUTH,
- 'iis' => \$IIS,
- 'tolower' => \$TOLOWER,
- 'nospace' => \$NOSPACE,
- 'keepext=s' => \$KEEPEXT{'OPT'},
- ) || usage();
-
-sub print_version {
- require LWP;
- my $DISTNAME = 'libwww-perl-' . LWP::Version();
- print <<"EOT";
-This is lwp-rget version $VERSION ($DISTNAME)
-
-Copyright 1996-1998, Gisle Aas.
-
-This program is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-EOT
- exit 0;
-}
-
-my $start_url = shift || usage();
-usage() if @ARGV;
-
-require LWP::UserAgent;
-my $ua = new LWP::UserAgent;
-$ua->agent("$progname/$VERSION ");
-$ua->env_proxy;
-
-unless (defined $PREFIX) {
- $PREFIX = url($start_url); # limit to URLs below this one
- eval {
- $PREFIX->eparams(undef);
- $PREFIX->equery(undef);
- };
-
- $_ = $PREFIX->epath;
- s|[^/]+$||;
- $PREFIX->epath($_);
- $PREFIX = $PREFIX->as_string;
-}
-
-%KEEPEXT = map { lc($_) => 1 } split(/\s*,\s*/, ($KEEPEXT{'OPT'}||0));
-
-my $SUPPRESS_REFERER;
-$SUPPRESS_REFERER++ if ($REFERER || "") eq "NONE";
-
-print <<"" if $VERBOSE;
-START = $start_url
-MAX_DEPTH = $MAX_DEPTH
-MAX_DOCS = $MAX_DOCS
-PREFIX = $PREFIX
-
-my $no_docs = 0;
-my %seen = (); # mapping from URL => local_file
-
-my $filename = fetch($start_url, undef, $REFERER);
-print "$filename\n" unless $QUIET;
-
-sub fetch
-{
- my($url, $type, $referer, $depth) = @_;
-
- # Fix http://sitename.com/../blah/blah.html to
- # http://sitename.com/blah/blah.html
- $url = $url->as_string if (ref($url));
- while ($url =~ s#(https?://[^/]+/)\.\.\/#$1#) {}
-
- # Fix backslashes (\) in URL if $IIS defined
- $url = fix_backslashes($url) if (defined $IIS);
-
- $url = url($url);
- $type ||= 'a';
- # Might be the background attribute
- $type = 'img' if ($type eq 'body' || $type eq 'td');
- $depth ||= 0;
-
- # Print the URL before we start checking...
- my $out = (" " x $depth) . $url . " ";
- $out .= "." x (60 - length($out));
- print STDERR $out . " " if $VERBOSE;
-
- # Can't get mailto things
- if ($url->scheme eq 'mailto') {
- print STDERR "*skipping mailto*\n" if $VERBOSE;
- return $url->as_string;
- }
-
- # The $plain_url is a URL without the fragment part
- my $plain_url = $url->clone;
- $plain_url->frag(undef);
-
- # Check PREFIX, but not for <IMG ...> links
- if ($type ne 'img' and $url->as_string !~ /^\Q$PREFIX/o) {
- print STDERR "*outsider*\n" if $VERBOSE;
- return $url->as_string;
- }
-
- # Translate URL to lowercase if $TOLOWER defined
- $plain_url = to_lower($plain_url) if (defined $TOLOWER);
-
- # If we already have it, then there is nothing to be done
- my $seen = $seen{$plain_url->as_string};
- if ($seen) {
- my $frag = $url->frag;
- $seen .= "#$frag" if defined($frag);
- $seen = protect_frag_spaces($seen);
- print STDERR "$seen (again)\n" if $VERBOSE;
- return $seen;
- }
-
- # Too much or too deep
- if ($depth > $MAX_DEPTH and $type ne 'img') {
- print STDERR "*too deep*\n" if $VERBOSE;
- return $url;
- }
- if ($no_docs > $MAX_DOCS) {
- print STDERR "*too many*\n" if $VERBOSE;
- return $url;
- }
-
- # Fetch document
- $no_docs++;
- sleep($SLEEP) if $SLEEP;
- my $req = HTTP::Request->new(GET => $url);
- # See: http://ftp.sunet.se/pub/NT/mirror-microsoft/kb/Q163/7/74.TXT
- $req->header ('Accept', '*/*') if (defined $IIS); # GIF/JPG from IIS 2.0
- $req->authorization_basic(split (/:/, $AUTH)) if (defined $AUTH);
- if ($referer && !$SUPPRESS_REFERER) {
- if ($req->uri->scheme eq 'http') {
- # RFC 2616, section 15.1.3
- $referer = url($referer) unless ref($referer);
- undef $referer if ($referer->scheme || '') eq 'https';
- }
- $req->referer($referer) if $referer;
- }
- my $res = $ua->request($req);
-
- # Check outcome
- if ($res->is_success) {
- my $doc = $res->content;
- my $ct = $res->content_type;
- my $name = find_name($res->request->uri, $ct);
- print STDERR "$name\n" unless $QUIET;
- $seen{$plain_url->as_string} = $name;
-
- # If the file is HTML, then we look for internal links
- if ($ct eq "text/html") {
- # Save an unprosessed version of the HTML document. This
- # both reserves the name used, and it also ensures that we
- # don't loose everything if this program is killed before
- # we finish.
- save($name, $doc);
- my $base = $res->base;
-
- # Follow and substitute links...
- $doc =~
-s/
- (
- <(img|a|body|area|frame|td)\b # some interesting tag
- [^>]+ # still inside tag (not strictly correct)
- \b(?:src|href|background) # some link attribute
- \s*=\s* # =
- )
- (?: # scope of OR-ing
- (")([^"]*)" | # value in double quotes OR
- (')([^']*)' | # value in single quotes OR
- ([^\s>]+) # quoteless value
- )
-/
- new_link($1, lc($2), $3||$5, HTML::Entities::decode($4||$6||$7),
- $base, $name, "$url", $depth+1)
-/giex;
- # XXX
- # The regular expression above is not strictly correct.
- # It is not really possible to parse HTML with a single
- # regular expression, but it is faster. Tags that might
- # confuse us include:
- # <a alt="href" href=link.html>
- # <a alt=">" href="link.html">
- #
- }
- save($name, $doc);
- return $name;
- }
- else {
- print STDERR $res->code . " " . $res->message . "\n" if $VERBOSE;
- $seen{$plain_url->as_string} = $url->as_string;
- return $url->as_string;
- }
-}
-
-sub new_link
-{
- my($pre, $type, $quote, $url, $base, $localbase, $referer, $depth) = @_;
-
- $url = protect_frag_spaces($url);
-
- $url = fetch(url($url, $base)->abs, $type, $referer, $depth);
- $url = url("file:$url", "file:$localbase")->rel
- unless $url =~ /^[.+\-\w]+:/;
-
- $url = unprotect_frag_spaces($url);
-
- return $pre . $quote . $url . $quote;
-}
-
-
-sub protect_frag_spaces
-{
- my ($url) = @_;
-
- $url = $url->as_string if (ref($url));
-
- if ($url =~ m/^([^#]*#)(.+)$/)
- {
- my ($base, $frag) = ($1, $2);
- $frag =~ s/ /%20/g;
- $url = $base . $frag;
- }
-
- return $url;
-}
-
-
-sub unprotect_frag_spaces
-{
- my ($url) = @_;
-
- $url = $url->as_string if (ref($url));
-
- if ($url =~ m/^([^#]*#)(.+)$/)
- {
- my ($base, $frag) = ($1, $2);
- $frag =~ s/%20/ /g;
- $url = $base . $frag;
- }
-
- return $url;
-}
-
-
-sub fix_backslashes
-{
- my ($url) = @_;
- my ($base, $frag);
-
- $url = $url->as_string if (ref($url));
-
- if ($url =~ m/([^#]+)(#.*)/)
- {
- ($base, $frag) = ($1, $2);
- }
- else
- {
- $base = $url;
- $frag = "";
- }
-
- $base =~ tr/\\/\//;
- $base =~ s/%5[cC]/\//g; # URL-encoded back slash is %5C
-
- return $base . $frag;
-}
-
-
-sub to_lower
-{
- my ($url) = @_;
- my $was_object = 0;
-
- if (ref($url))
- {
- $url = $url->as_string;
- $was_object = 1;
- }
-
- if ($url =~ m/([^#]+)(#.*)/)
- {
- $url = lc($1) . $2;
- }
- else
- {
- $url = lc($url);
- }
-
- if ($was_object == 1)
- {
- return url($url);
- }
- else
- {
- return $url;
- }
-}
-
-
-sub translate_spaces
-{
- my ($url) = @_;
- my ($base, $frag);
-
- $url = $url->as_string if (ref($url));
-
- if ($url =~ m/([^#]+)(#.*)/)
- {
- ($base, $frag) = ($1, $2);
- }
- else
- {
- $base = $url;
- $frag = "";
- }
-
- $base =~ s/^ *//; # Remove initial spaces from base
- $base =~ s/ *$//; # Remove trailing spaces from base
-
- $base =~ tr/ /_/;
- $base =~ s/%20/_/g; # URL-encoded space is %20
-
- return $base . $frag;
-}
-
-
-sub mkdirp
-{
- my($directory, $mode) = @_;
- my @dirs = split(/\//, $directory);
- my $path = shift(@dirs); # build it as we go
- my $result = 1; # assume it will work
-
- unless (-d $path) {
- $result &&= mkdir($path, $mode);
- }
-
- foreach (@dirs) {
- $path .= "/$_";
- if ( ! -d $path) {
- $result &&= mkdir($path, $mode);
- }
- }
-
- return $result;
-}
-
-
-sub find_name
-{
- my($url, $type) = @_;
- #print "find_name($url, $type)\n";
-
- # Translate spaces in URL to underscores (_) if $NOSPACE defined
- $url = translate_spaces($url) if (defined $NOSPACE);
-
- # Translate URL to lowercase if $TOLOWER defined
- $url = to_lower($url) if (defined $TOLOWER);
-
- $url = url($url) unless ref($url);
-
- my $path = $url->path;
-
- # trim path until only the basename is left
- $path =~ s|(.*/)||;
- my $dirname = ".$1";
- if (!$HIER) {
- $dirname = "";
- }
- elsif (! -d $dirname) {
- mkdirp($dirname, 0775);
- }
-
- my $extra = ""; # something to make the name unique
- my $suffix;
-
- if ($KEEPEXT{lc($type)}) {
- $suffix = ($path =~ m/\.(.*)/) ? $1 : "";
- }
- else {
- $suffix = media_suffix($type);
- }
-
- $path =~ s|\..*||; # trim suffix
- $path = "index" unless length $path;
-
- while (1) {
- # Construct a new file name
- my $file = $dirname . $path . $extra;
- $file .= ".$suffix" if $suffix;
- # Check if it is unique
- return $file unless -f $file;
-
- # Try something extra
- unless ($extra) {
- $extra = "001";
- next;
- }
- $extra++;
- }
-}
-
-
-sub save
-{
- my $name = shift;
- #print "save($name,...)\n";
- open(FILE, ">$name") || die "Can't save $name: $!";
- binmode FILE;
- print FILE $_[0];
- close(FILE);
-}
-
-
-sub usage
-{
- print <<""; exit 1;
-Usage: $progname [options] <URL>
-Allowed options are:
- --auth=USER:PASS Set authentication credentials for web site
- --depth=N Maximum depth to traverse (default is $MAX_DEPTH)
- --hier Download into hierarchy (not all files into cwd)
- --referer=URI Set initial referer header (or "NONE")
- --iis Workaround IIS 2.0 bug by sending "Accept: */*" MIME
- header; translates backslashes (\\) to forward slashes (/)
- --keepext=type Keep file extension for MIME types (comma-separated list)
- --limit=N A limit on the number documents to get (default is $MAX_DOCS)
- --nospace Translate spaces URLs (not #fragments) to underscores (_)
- --version Print version number and quit
- --verbose More output
- --quiet No output
- --sleep=SECS Sleep between gets, ie. go slowly
- --prefix=PREFIX Limit URLs to follow to those which begin with PREFIX
- --tolower Translate all URLs to lowercase (useful with IIS servers)
-
-}
+++ /dev/null
-package Bundle::LWP;
-
-$VERSION = "5.835";
-
-1;
-
-__END__
-
-=head1 NAME
-
-Bundle::LWP - install all libwww-perl related modules
-
-=head1 SYNOPSIS
-
- perl -MCPAN -e 'install Bundle::LWP'
-
-=head1 CONTENTS
-
-MIME::Base64 - Used in authentication headers
-
-Digest::MD5 - Needed to do Digest authentication
-
-URI 1.10 - There are URIs everywhere
-
-Net::FTP 2.58 - If you want ftp://-support
-
-HTML::Tagset - Needed by HTML::Parser
-
-HTML::Parser - Needed by HTML::HeadParser
-
-HTML::HeadParser - To get the correct $res->base
-
-LWP - The reason why you need the modules above
-
-=head1 DESCRIPTION
-
-This bundle defines all prerequisite modules for libwww-perl. Bundles
-have special meaning for the CPAN module. When you install the bundle
-module all modules mentioned in L</CONTENTS> will be installed
-instead.
-
-=head1 SEE ALSO
-
-L<CPAN/Bundles>
+++ /dev/null
-package File::Listing;
-
-sub Version { $VERSION; }
-$VERSION = "5.837";
-
-require Exporter;
-@ISA = qw(Exporter);
-@EXPORT = qw(parse_dir);
-
-use strict;
-
-use Carp ();
-use HTTP::Date qw(str2time);
-
-
-
-sub parse_dir ($;$$$)
-{
- my($dir, $tz, $fstype, $error) = @_;
-
- $fstype ||= 'unix';
- $fstype = "File::Listing::" . lc $fstype;
-
- my @args = $_[0];
- push(@args, $tz) if(@_ >= 2);
- push(@args, $error) if(@_ >= 4);
-
- $fstype->parse(@args);
-}
-
-
-sub line { Carp::croak("Not implemented yet"); }
-sub init { } # Dummy sub
-
-
-sub file_mode ($)
-{
- # This routine was originally borrowed from Graham Barr's
- # Net::FTP package.
-
- local $_ = shift;
- my $mode = 0;
- my($type,$ch);
-
- s/^(.)// and $type = $1;
-
- while (/(.)/g) {
- $mode <<= 1;
- $mode |= 1 if $1 ne "-" &&
- $1 ne 'S' &&
- $1 ne 't' &&
- $1 ne 'T';
- }
-
- $type eq "d" and $mode |= 0040000 or # Directory
- $type eq "l" and $mode |= 0120000 or # Symbolic Link
- $mode |= 0100000; # Regular File
-
- $mode |= 0004000 if /^...s....../i;
- $mode |= 0002000 if /^......s.../i;
- $mode |= 0001000 if /^.........t/i;
-
- $mode;
-}
-
-
-sub parse
-{
- my($pkg, $dir, $tz, $error) = @_;
-
- # First let's try to determine what kind of dir parameter we have
- # received. We allow both listings, reference to arrays and
- # file handles to read from.
-
- if (ref($dir) eq 'ARRAY') {
- # Already splitted up
- }
- elsif (ref($dir) eq 'GLOB') {
- # A file handle
- }
- elsif (ref($dir)) {
- Carp::croak("Illegal argument to parse_dir()");
- }
- elsif ($dir =~ /^\*\w+(::\w+)+$/) {
- # This scalar looks like a file handle, so we assume it is
- }
- else {
- # A normal scalar listing
- $dir = [ split(/\n/, $dir) ];
- }
-
- $pkg->init();
-
- my @files = ();
- if (ref($dir) eq 'ARRAY') {
- for (@$dir) {
- push(@files, $pkg->line($_, $tz, $error));
- }
- }
- else {
- local($_);
- while (<$dir>) {
- chomp;
- push(@files, $pkg->line($_, $tz, $error));
- }
- }
- wantarray ? @files : \@files;
-}
-
-
-
-package File::Listing::unix;
-
-use HTTP::Date qw(str2time);
-
-# A place to remember current directory from last line parsed.
-use vars qw($curdir @ISA);
-
-@ISA = qw(File::Listing);
-
-
-
-sub init
-{
- $curdir = '';
-}
-
-
-sub line
-{
- shift; # package name
- local($_) = shift;
- my($tz, $error) = @_;
-
- s/\015//g;
- #study;
-
- my ($kind, $size, $date, $name);
- if (($kind, $size, $date, $name) =
- /^([\-FlrwxsStTdD]{10}) # Type and permission bits
- .* # Graps
- \D(\d+) # File size
- \s+ # Some space
- (\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 )
-
- {
- return if $name eq '.' || $name eq '..';
- $name = "$curdir/$name" if length $curdir;
- my $type = '?';
- if ($kind =~ /^l/ && $name =~ /(.*) -> (.*)/ ) {
- $name = $1;
- $type = "l $2";
- }
- elsif ($kind =~ /^[\-F]/) { # (hopefully) a regular file
- $type = 'f';
- }
- elsif ($kind =~ /^[dD]/) {
- $type = 'd';
- $size = undef; # Don't believe the reported size
- }
- return [$name, $type, $size, str2time($date, $tz),
- File::Listing::file_mode($kind)];
-
- }
- elsif (/^(.+):$/ && !/^[dcbsp].*\s.*\s.*:$/ ) {
- my $dir = $1;
- return () if $dir eq '.';
- $curdir = $dir;
- return ();
- }
- elsif (/^[Tt]otal\s+(\d+)$/ || /^\s*$/) {
- return ();
- }
- elsif (/not found/ || # OSF1, HPUX, and SunOS return
- # "$file not found"
- /No such file/ || # IRIX returns
- # "UX:ls: ERROR: Cannot access $file: No such file or directory"
- # Solaris returns
- # "$file: No such file or directory"
- /cannot find/ # Windows NT returns
- # "The system cannot find the path specified."
- ) {
- return () unless defined $error;
- &$error($_) if ref($error) eq 'CODE';
- warn "Error: $_\n" if $error eq 'warn';
- return ();
- }
- elsif ($_ eq '') { # AIX, and Linux return nothing
- return () unless defined $error;
- &$error("No such file or directory") if ref($error) eq 'CODE';
- warn "Warning: No such file or directory\n" if $error eq 'warn';
- return ();
- }
- else {
- # parse failed, check if the dosftp parse understands it
- File::Listing::dosftp->init();
- return(File::Listing::dosftp->line($_,$tz,$error));
- }
-
-}
-
-
-
-package File::Listing::dosftp;
-
-use HTTP::Date qw(str2time);
-
-# A place to remember current directory from last line parsed.
-use vars qw($curdir @ISA);
-
-@ISA = qw(File::Listing);
-
-
-
-sub init
-{
- $curdir = '';
-}
-
-
-sub line
-{
- shift; # package name
- local($_) = shift;
- my($tz, $error) = @_;
-
- s/\015//g;
-
- 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) =
- /^(\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
- \s+ # Some more space
- (.+)$ # File name
- /x )
- {
- return if $name eq '.' || $name eq '..';
- $name = "$curdir/$name" if length $curdir;
- my $type = '?';
- if ($size_or_dir eq '<DIR>') {
- $type = "d";
- $size = ""; # directories have no size in the pc listing
- }
- else {
- $type = 'f';
- $size = $size_or_dir;
- }
- return [$name, $type, $size, str2time($date, $tz), undef];
- }
- else {
- return () unless defined $error;
- &$error($_) if ref($error) eq 'CODE';
- warn "Can't parse: $_\n" if $error eq 'warn';
- return ();
- }
-
-}
-
-
-
-package File::Listing::vms;
-@File::Listing::vms::ISA = qw(File::Listing);
-
-package File::Listing::netware;
-@File::Listing::netware::ISA = qw(File::Listing);
-
-
-
-package File::Listing::apache;
-
-use vars qw(@ISA);
-
-@ISA = qw(File::Listing);
-
-
-sub init { }
-
-
-sub line {
- shift; # package name
- local($_) = shift;
- my($tz, $error) = @_; # ignored for now...
-
- if (m!<A\s+HREF=\"([^\"]+)\">.*</A>.*?(\d+)-([a-zA-Z]+|\d+)-(\d+)\s+(\d+):(\d+)\s+(?:([\d\.]+[kMG]?|-))!i) {
- my($filename, $filesize) = ($1, $7);
- my($d,$m,$y, $H,$M) = ($2,$3,$4,$5,$6);
- if ($m =~ /^\d+$/) {
- ($d,$y) = ($y,$d) # iso date
- }
- else {
- $m = _monthabbrev_number($m);
- }
-
- $filesize = 0 if $filesize eq '-';
- if ($filesize =~ s/k$//i) {
- $filesize *= 1024;
- }
- elsif ($filesize =~ s/M$//) {
- $filesize *= 1024*1024;
- }
- elsif ($filesize =~ s/G$//) {
- $filesize *= 1024*1024*1024;
- }
- $filesize = int $filesize;
-
- require Time::Local;
- my $filetime = Time::Local::timelocal(0,$M,$H,$d,$m-1,_guess_year($y)-1900);
- my $filetype = ($filename =~ s|/$|| ? "d" : "f");
- return [$filename, $filetype, $filesize, $filetime, undef];
- }
-
- return ();
-}
-
-
-sub _guess_year {
- my $y = shift;
- if ($y >= 90) {
- $y = 1900+$y;
- }
- elsif ($y < 100) {
- $y = 2000+$y;
- }
- $y;
-}
-
-
-sub _monthabbrev_number {
- my $mon = shift;
- +{'Jan' => 1,
- 'Feb' => 2,
- 'Mar' => 3,
- 'Apr' => 4,
- 'May' => 5,
- 'Jun' => 6,
- 'Jul' => 7,
- 'Aug' => 8,
- 'Sep' => 9,
- 'Oct' => 10,
- 'Nov' => 11,
- 'Dec' => 12,
- }->{$mon};
-}
-
-
-1;
-
-__END__
-
-=head1 NAME
-
-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
- #...
- }
-
- # directory listing can also be read from a file
- open(LISTING, "zcat ls-lR.gz|");
- $dir = parse_dir(\*LISTING, '+0000');
-
-=head1 DESCRIPTION
-
-This module exports a single function called parse_dir(), which can be
-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
-glob representing a filehandle to read the directory listing from.
-
-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. 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
-the perl warn() function will be called. If a code reference is
-passed, then this routine will be called and the return value from it
-will be incorporated in the listing. The default is 'ignore'.
-
-Only the first parameter is mandatory.
-
-The return value from parse_dir() is a list of directory entries. In
-a scalar context the return value is a reference to the list. The
-directory entries are represented by an array consisting of [
-$filename, $filetype, $filesize, $filetime, $filemode ]. The
-$filetype value is one of the letters 'f', 'd', 'l' or '?'. The
-$filetime value is the seconds since Jan 1, 1970. The
-$filemode is a bitmask like the mode returned by stat().
-
-=head1 CREDITS
-
-Based on lsparse.pl (from Lee McLoughlin's ftp mirror package) and
-Net::FTP's parse_dir (Graham Barr).
+++ /dev/null
-package HTML::Form;
-
-use strict;
-use URI;
-use Carp ();
-
-use vars qw($VERSION $Encode_available);
-$VERSION = "5.829";
-
-eval { require Encode };
-$Encode_available = !$@;
-
-my %form_tags = map {$_ => 1} qw(input textarea button select option);
-
-my %type2class = (
- text => "TextInput",
- password => "TextInput",
- hidden => "TextInput",
- textarea => "TextInput",
-
- "reset" => "IgnoreInput",
-
- radio => "ListInput",
- checkbox => "ListInput",
- option => "ListInput",
-
- button => "SubmitInput",
- submit => "SubmitInput",
- image => "ImageInput",
- file => "FileInput",
-
- keygen => "KeygenInput",
-);
-
-=head1 NAME
-
-HTML::Form - Class that represents an HTML form element
-
-=head1 SYNOPSIS
-
- use HTML::Form;
- $form = HTML::Form->parse($html, $base_uri);
- $form->value(query => "Perl");
-
- use LWP::UserAgent;
- $ua = LWP::UserAgent->new;
- $response = $ua->request($form->click);
-
-=head1 DESCRIPTION
-
-Objects of the C<HTML::Form> class represents a single HTML
-C<E<lt>formE<gt> ... E<lt>/formE<gt>> instance. A form consists of a
-sequence of inputs that usually have names, and which can take on
-various values. The state of a form can be tweaked and it can then be
-asked to provide C<HTTP::Request> objects that can be passed to the
-request() method of C<LWP::UserAgent>.
-
-The following methods are available:
-
-=over 4
-
-=item @forms = HTML::Form->parse( $html_document, $base_uri )
-
-=item @forms = HTML::Form->parse( $html_document, base => $base_uri, %opt )
-
-=item @forms = HTML::Form->parse( $response, %opt )
-
-The parse() class method will parse an HTML document and build up
-C<HTML::Form> objects for each <form> element found. If called in scalar
-context only returns the first <form>. Returns an empty list if there
-are no forms to be found.
-
-The required arguments is the HTML document to parse ($html_document) and the
-URI used to retrieve the document ($base_uri). The base URI is needed to resolve
-relative action URIs. The provided HTML document should be a Unicode string
-(or US-ASCII).
-
-By default HTML::Form assumes that the original document was UTF-8 encoded and
-thus encode forms that don't specify an explict I<accept-charset> as UTF-8.
-The charset assumed can be overridden by providing the C<charset> option to
-parse(). It's a good idea to be explict about this parameter as well, thus
-the recommended simplest invocation becomes:
-
- my @forms = HTML::Form->parse(
- Encode::decode($encoding, $html_document_bytes),
- base => $base_uri,
- charset => $encoding,
- );
-
-If the document was retrieved with LWP then the response object provide methods
-to obtain a proper value for C<base> and C<charset>:
-
- my $ua = LWP::UserAgent->new;
- my $response = $ua->get("http://www.example.com/form.html");
- my @forms = HTML::Form->parse($response->decoded_content,
- base => $response->base,
- charset => $response->content_charset,
- );
-
-In fact, the parse() method can parse from an C<HTTP::Response> object
-directly, so the example above can be more conveniently written as:
-
- my $ua = LWP::UserAgent->new;
- my $response = $ua->get("http://www.example.com/form.html");
- my @forms = HTML::Form->parse($response);
-
-Note that any object that implements a decoded_content(), base() and
-content_charset() method with similar behaviour as C<HTTP::Response> will do.
-
-Additional options might be passed in to control how the parse method
-behaves. The following are all the options currently recognized:
-
-=over
-
-=item C<< base => $uri >>
-
-This is the URI used to retrive the original document. This option is not optional ;-)
-
-=item C<< charset => $str >>
-
-Specify what charset the original document was encoded in. This is used as
-the default for accept_charset. If not provided this defaults to "UTF-8".
-
-=item C<< verbose => $bool >>
-
-Warn (print messages to STDERR) about any bad HTML form constructs found.
-You can trap these with $SIG{__WARN__}.
-
-=item C<< strict => $bool >>
-
-Initialize any form objects with the given strict attribute.
-
-=back
-
-=cut
-
-sub parse
-{
- my $class = shift;
- my $html = shift;
- unshift(@_, "base") if @_ == 1;
- my %opt = @_;
-
- require HTML::TokeParser;
- my $p = HTML::TokeParser->new(ref($html) ? $html->decoded_content(ref => 1) : \$html);
- die "Failed to create HTML::TokeParser object" unless $p;
-
- my $base_uri = delete $opt{base};
- my $charset = delete $opt{charset};
- my $strict = delete $opt{strict};
- my $verbose = delete $opt{verbose};
-
- if ($^W) {
- Carp::carp("Unrecognized option $_ in HTML::Form->parse") for sort keys %opt;
- }
-
- unless (defined $base_uri) {
- if (ref($html)) {
- $base_uri = $html->base;
- }
- else {
- Carp::croak("HTML::Form::parse: No \$base_uri provided");
- }
- }
- unless (defined $charset) {
- if (ref($html) and $html->can("content_charset")) {
- $charset = $html->content_charset;
- }
- unless ($charset) {
- $charset = "UTF-8";
- }
- }
-
- 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") {
- my $action = delete $attr->{'action'};
- $action = "" unless defined $action;
- $action = URI->new_abs($action, $base_uri);
- $f = $class->new($attr->{'method'},
- $action,
- $attr->{'enctype'});
- $f->accept_charset($attr->{'accept-charset'}) if $attr->{'accept-charset'};
- $f->{default_charset} = $charset;
- $f->{attr} = $attr;
- $f->strict(1) if $strict;
- %openselect = ();
- push(@forms, $f);
- my(%labels, $current_label);
- while (my $t = $p->get_tag) {
- my($tag, $attr) = @$t;
- last if $tag eq "/form";
-
- # if we are inside a label tag, then keep
- # appending any text to the current label
- if(defined $current_label) {
- $current_label = join " ",
- grep { defined and length }
- $current_label,
- $p->get_phrase;
- }
-
- if ($tag eq "input") {
- $attr->{value_name} =
- exists $attr->{id} && exists $labels{$attr->{id}} ? $labels{$attr->{id}} :
- defined $current_label ? $current_label :
- $p->get_phrase;
- }
-
- if ($tag eq "label") {
- $current_label = $p->get_phrase;
- $labels{ $attr->{for} } = $current_label
- if exists $attr->{for};
- }
- elsif ($tag eq "/label") {
- $current_label = undef;
- }
- elsif ($tag eq "input") {
- my $type = delete $attr->{type} || "text";
- $f->push_input($type, $attr, $verbose);
- }
- elsif ($tag eq "button") {
- my $type = delete $attr->{type} || "submit";
- $f->push_input($type, $attr, $verbose);
- }
- elsif ($tag eq "textarea") {
- $attr->{textarea_value} = $attr->{value}
- if exists $attr->{value};
- my $text = $p->get_text("/textarea");
- $attr->{value} = $text;
- $f->push_input("textarea", $attr, $verbose);
- }
- elsif ($tag eq "select") {
- # rename attributes reserved to come for the option tag
- for ("value", "value_name") {
- $attr->{"select_$_"} = delete $attr->{$_}
- if exists $attr->{$_};
- }
- # count this new select option separately
- my $name = $attr->{name};
- $name = "" unless defined $name;
- $openselect{$name}++;
-
- while ($t = $p->get_tag) {
- my $tag = shift @$t;
- last if $tag eq "/select";
- next if $tag =~ m,/?optgroup,;
- next if $tag eq "/option";
- if ($tag eq "option") {
- my %a = %{$t->[0]};
- # rename keys so they don't clash with %attr
- for (keys %a) {
- next if $_ eq "value";
- $a{"option_$_"} = delete $a{$_};
- }
- while (my($k,$v) = each %$attr) {
- $a{$k} = $v;
- }
- $a{value_name} = $p->get_trimmed_text;
- $a{value} = delete $a{value_name}
- unless defined $a{value};
- $a{idx} = $openselect{$name};
- $f->push_input("option", \%a, $verbose);
- }
- else {
- warn("Bad <select> tag '$tag' in $base_uri\n") if $verbose;
- if ($tag eq "/form" ||
- $tag eq "input" ||
- $tag eq "textarea" ||
- $tag eq "select" ||
- $tag eq "keygen")
- {
- # MSIE implictly terminate the <select> here, so we
- # try to do the same. Actually the MSIE behaviour
- # appears really strange: <input> and <textarea>
- # do implictly close, but not <select>, <keygen> or
- # </form>.
- my $type = ($tag =~ s,^/,,) ? "E" : "S";
- $p->unget_token([$type, $tag, @$t]);
- last;
- }
- }
- }
- }
- elsif ($tag eq "keygen") {
- $f->push_input("keygen", $attr, $verbose);
- }
- }
- }
- elsif ($form_tags{$tag}) {
- warn("<$tag> outside <form> in $base_uri\n") if $verbose;
- }
- }
- for (@forms) {
- $_->fixup;
- }
-
- wantarray ? @forms : $forms[0];
-}
-
-sub new {
- my $class = shift;
- my $self = bless {}, $class;
- $self->{method} = uc(shift || "GET");
- $self->{action} = shift || Carp::croak("No action defined");
- $self->{enctype} = lc(shift || "application/x-www-form-urlencoded");
- $self->{accept_charset} = "UNKNOWN";
- $self->{default_charset} = "UTF-8";
- $self->{inputs} = [@_];
- $self;
-}
-
-
-sub push_input
-{
- my($self, $type, $attr, $verbose) = @_;
- $type = lc $type;
- my $class = $type2class{$type};
- unless ($class) {
- Carp::carp("Unknown input type '$type'") if $verbose;
- $class = "TextInput";
- }
- $class = "HTML::Form::$class";
- my @extra;
- push(@extra, readonly => 1) if $type eq "hidden";
- push(@extra, strict => 1) if $self->{strict};
- if ($type eq "file" && exists $attr->{value}) {
- # it's not safe to trust the value set by the server
- # the user always need to explictly set the names of files to upload
- $attr->{orig_value} = delete $attr->{value};
- }
- delete $attr->{type}; # don't confuse the type argument
- my $input = $class->new(type => $type, %$attr, @extra);
- $input->add_to_form($self);
-}
-
-
-=item $method = $form->method
-
-=item $form->method( $new_method )
-
-This method is gets/sets the I<method> name used for the
-C<HTTP::Request> generated. It is a string like "GET" or "POST".
-
-=item $action = $form->action
-
-=item $form->action( $new_action )
-
-This method gets/sets the URI which we want to apply the request
-I<method> to.
-
-=item $enctype = $form->enctype
-
-=item $form->enctype( $new_enctype )
-
-This method gets/sets the encoding type for the form data. It is a
-string like "application/x-www-form-urlencoded" or "multipart/form-data".
-
-=item $accept = $form->accept_charset
-
-=item $form->accept_charset( $new_accept )
-
-This method gets/sets the list of charset encodings that the server processing
-the form accepts. Current implementation supports only one-element lists.
-Default value is "UNKNOWN" which we interpret as a request to use document
-charset as specified by the 'charset' parameter of the parse() method. To
-encode character strings you should have modern perl with Encode module. On
-older perls the setting of this attribute has no effect.
-
-=cut
-
-BEGIN {
- # Set up some accesor
- for (qw(method action enctype accept_charset)) {
- my $m = $_;
- no strict 'refs';
- *{$m} = sub {
- my $self = shift;
- my $old = $self->{$m};
- $self->{$m} = shift if @_;
- $old;
- };
- }
- *uri = \&action; # alias
-}
-
-=item $value = $form->attr( $name )
-
-=item $form->attr( $name, $new_value )
-
-This method give access to the original HTML attributes of the <form> tag.
-The $name should always be passed in lower case.
-
-Example:
-
- @f = HTML::Form->parse( $html, $foo );
- @f = grep $_->attr("id") eq "foo", @f;
- die "No form named 'foo' found" unless @f;
- $foo = shift @f;
-
-=cut
-
-sub attr {
- my $self = shift;
- my $name = shift;
- return undef unless defined $name;
-
- my $old = $self->{attr}{$name};
- $self->{attr}{$name} = shift if @_;
- return $old;
-}
-
-=item $bool = $form->strict
-
-=item $form->strict( $bool )
-
-Gets/sets the strict attribute of a form. If the strict is turned on
-the methods that change values of the form will croak if you try to
-set illegal values or modify readonly fields. The default is not to be strict.
-
-=cut
-
-sub strict {
- my $self = shift;
- my $old = $self->{strict};
- if (@_) {
- $self->{strict} = shift;
- for my $input (@{$self->{inputs}}) {
- $input->strict($self->{strict});
- }
- }
- return $old;
-}
-
-
-=item @inputs = $form->inputs
-
-This method returns the list of inputs in the form. If called in
-scalar context it returns the number of inputs contained in the form.
-See L</INPUTS> for what methods are available for the input objects
-returned.
-
-=cut
-
-sub inputs
-{
- my $self = shift;
- @{$self->{'inputs'}};
-}
-
-
-=item $input = $form->find_input( $selector )
-
-=item $input = $form->find_input( $selector, $type )
-
-=item $input = $form->find_input( $selector, $type, $index )
-
-This method is used to locate specific inputs within the form. All
-inputs that match the arguments given are returned. In scalar context
-only the first is returned, or C<undef> if none match.
-
-If $selector is specified, then the input's name, id, class attribute must
-match. A selector prefixed with '#' must match the id attribute of the input.
-A selector prefixed with '.' matches the class attribute. A selector prefixed
-with '^' or with no prefix matches the name attribute.
-
-If $type is specified, then the input must have the specified type.
-The following type names are used: "text", "password", "hidden",
-"textarea", "file", "image", "submit", "radio", "checkbox" and "option".
-
-The $index is the sequence number of the input matched where 1 is the
-first. If combined with $name and/or $type then it select the I<n>th
-input with the given name and/or type.
-
-=cut
-
-sub find_input
-{
- my($self, $name, $type, $no) = @_;
- if (wantarray) {
- my @res;
- my $c;
- for (@{$self->{'inputs'}}) {
- next if defined($name) && !$_->selected($name);
- next if $type && $type ne $_->{type};
- $c++;
- next if $no && $no != $c;
- push(@res, $_);
- }
- return @res;
-
- }
- else {
- $no ||= 1;
- for (@{$self->{'inputs'}}) {
- next if defined($name) && !$_->selected($name);
- next if $type && $type ne $_->{type};
- next if --$no;
- return $_;
- }
- return undef;
- }
-}
-
-sub fixup
-{
- my $self = shift;
- for (@{$self->{'inputs'}}) {
- $_->fixup;
- }
-}
-
-
-=item $value = $form->value( $selector )
-
-=item $form->value( $selector, $new_value )
-
-The value() method can be used to get/set the value of some input. If
-strict is enabled and no input has the indicated name, then this method will croak.
-
-If multiple inputs have the same name, only the first one will be
-affected.
-
-The call:
-
- $form->value('foo')
-
-is basically a short-hand for:
-
- $form->find_input('foo')->value;
-
-=cut
-
-sub value
-{
- my $self = shift;
- my $key = shift;
- my $input = $self->find_input($key);
- unless ($input) {
- Carp::croak("No such field '$key'") if $self->{strict};
- return undef unless @_;
- $input = $self->push_input("text", { name => $key, value => "" });
- }
- local $Carp::CarpLevel = 1;
- $input->value(@_);
-}
-
-=item @names = $form->param
-
-=item @values = $form->param( $name )
-
-=item $form->param( $name, $value, ... )
-
-=item $form->param( $name, \@values )
-
-Alternative interface to examining and setting the values of the form.
-
-If called without arguments then it returns the names of all the
-inputs in the form. The names will not repeat even if multiple inputs
-have the same name. In scalar context the number of different names
-is returned.
-
-If called with a single argument then it returns the value or values
-of inputs with the given name. If called in scalar context only the
-first value is returned. If no input exists with the given name, then
-C<undef> is returned.
-
-If called with 2 or more arguments then it will set values of the
-named inputs. This form will croak if no inputs have the given name
-or if any of the values provided does not fit. Values can also be
-provided as a reference to an array. This form will allow unsetting
-all values with the given name as well.
-
-This interface resembles that of the param() function of the CGI
-module.
-
-=cut
-
-sub param {
- my $self = shift;
- if (@_) {
- my $name = shift;
- my @inputs;
- for ($self->inputs) {
- my $n = $_->name;
- next if !defined($n) || $n ne $name;
- push(@inputs, $_);
- }
-
- if (@_) {
- # set
- die "No '$name' parameter exists" unless @inputs;
- my @v = @_;
- @v = @{$v[0]} if @v == 1 && ref($v[0]);
- while (@v) {
- my $v = shift @v;
- my $err;
- for my $i (0 .. @inputs-1) {
- eval {
- $inputs[$i]->value($v);
- };
- unless ($@) {
- undef($err);
- splice(@inputs, $i, 1);
- last;
- }
- $err ||= $@;
- }
- die $err if $err;
- }
-
- # the rest of the input should be cleared
- for (@inputs) {
- $_->value(undef);
- }
- }
- else {
- # get
- my @v;
- for (@inputs) {
- if (defined(my $v = $_->value)) {
- push(@v, $v);
- }
- }
- return wantarray ? @v : $v[0];
- }
- }
- else {
- # list parameter names
- my @n;
- my %seen;
- for ($self->inputs) {
- my $n = $_->name;
- next if !defined($n) || $seen{$n}++;
- push(@n, $n);
- }
- return @n;
- }
-}
-
-
-=item $form->try_others( \&callback )
-
-This method will iterate over all permutations of unvisited enumerated
-values (<select>, <radio>, <checkbox>) and invoke the callback for
-each. The callback is passed the $form as argument. The return value
-from the callback is ignored and the try_others() method itself does
-not return anything.
-
-=cut
-
-sub try_others
-{
- my($self, $cb) = @_;
- my @try;
- for (@{$self->{'inputs'}}) {
- my @not_tried_yet = $_->other_possible_values;
- next unless @not_tried_yet;
- push(@try, [\@not_tried_yet, $_]);
- }
- return unless @try;
- $self->_try($cb, \@try, 0);
-}
-
-sub _try
-{
- my($self, $cb, $try, $i) = @_;
- for (@{$try->[$i][0]}) {
- $try->[$i][1]->value($_);
- &$cb($self);
- $self->_try($cb, $try, $i+1) if $i+1 < @$try;
- }
-}
-
-
-=item $request = $form->make_request
-
-Will return an C<HTTP::Request> object that reflects the current setting
-of the form. You might want to use the click() method instead.
-
-=cut
-
-sub make_request
-{
- my $self = shift;
- my $method = uc $self->{'method'};
- my $uri = $self->{'action'};
- my $enctype = $self->{'enctype'};
- my @form = $self->form;
-
- my $charset = $self->accept_charset eq "UNKNOWN" ? $self->{default_charset} : $self->accept_charset;
- if ($Encode_available) {
- foreach my $fi (@form) {
- $fi = Encode::encode($charset, $fi) unless ref($fi);
- }
- }
-
- if ($method eq "GET") {
- require HTTP::Request;
- $uri = URI->new($uri, "http");
- $uri->query_form(@form);
- return HTTP::Request->new(GET => $uri);
- }
- elsif ($method eq "POST") {
- require HTTP::Request::Common;
- return HTTP::Request::Common::POST($uri, \@form,
- Content_Type => $enctype);
- }
- else {
- Carp::croak("Unknown method '$method'");
- }
-}
-
-
-=item $request = $form->click
-
-=item $request = $form->click( $selector )
-
-=item $request = $form->click( $x, $y )
-
-=item $request = $form->click( $selector, $x, $y )
-
-Will "click" on the first clickable input (which will be of type
-C<submit> or C<image>). The result of clicking is an C<HTTP::Request>
-object that can then be passed to C<LWP::UserAgent> if you want to
-obtain the server response.
-
-If a $selector is specified, we will click on the first clickable input
-matching the selector, and the method will croak if no matching clickable
-input is found. If $selector is I<not> specified, then it
-is ok if the form contains no clickable inputs. In this case the
-click() method returns the same request as the make_request() method
-would do. See description of the find_input() method above for how
-the $selector is specified.
-
-If there are multiple clickable inputs with the same name, then there
-is no way to get the click() method of the C<HTML::Form> to click on
-any but the first. If you need this you would have to locate the
-input with find_input() and invoke the click() method on the given
-input yourself.
-
-A click coordinate pair can also be provided, but this only makes a
-difference if you clicked on an image. The default coordinate is
-(1,1). The upper-left corner of the image is (0,0), but some badly
-coded CGI scripts are known to not recognize this. Therefore (1,1) was
-selected as a safer default.
-
-=cut
-
-sub click
-{
- my $self = shift;
- my $name;
- $name = shift if (@_ % 2) == 1; # odd number of arguments
-
- # try to find first submit button to activate
- for (@{$self->{'inputs'}}) {
- next unless $_->can("click");
- next if $name && !$_->selected($name);
- next if $_->disabled;
- return $_->click($self, @_);
- }
- Carp::croak("No clickable input with name $name") if $name;
- $self->make_request;
-}
-
-
-=item @kw = $form->form
-
-Returns the current setting as a sequence of key/value pairs. Note
-that keys might be repeated, which means that some values might be
-lost if the return values are assigned to a hash.
-
-In scalar context this method returns the number of key/value pairs
-generated.
-
-=cut
-
-sub form
-{
- my $self = shift;
- map { $_->form_name_value($self) } @{$self->{'inputs'}};
-}
-
-
-=item $form->dump
-
-Returns a textual representation of current state of the form. Mainly
-useful for debugging. If called in void context, then the dump is
-printed on STDERR.
-
-=cut
-
-sub dump
-{
- my $self = shift;
- my $method = $self->{'method'};
- my $uri = $self->{'action'};
- my $enctype = $self->{'enctype'};
- my $dump = "$method $uri";
- $dump .= " ($enctype)"
- if $enctype ne "application/x-www-form-urlencoded";
- $dump .= " [$self->{attr}{name}]"
- if exists $self->{attr}{name};
- $dump .= "\n";
- for ($self->inputs) {
- $dump .= " " . $_->dump . "\n";
- }
- print STDERR $dump unless defined wantarray;
- $dump;
-}
-
-
-#---------------------------------------------------
-package HTML::Form::Input;
-
-=back
-
-=head1 INPUTS
-
-An C<HTML::Form> objects contains a sequence of I<inputs>. References to
-the inputs can be obtained with the $form->inputs or $form->find_input
-methods.
-
-Note that there is I<not> a one-to-one correspondence between input
-I<objects> and E<lt>inputE<gt> I<elements> in the HTML document. An
-input object basically represents a name/value pair, so when multiple
-HTML elements contribute to the same name/value pair in the submitted
-form they are combined.
-
-The input elements that are mapped one-to-one are "text", "textarea",
-"password", "hidden", "file", "image", "submit" and "checkbox". For
-the "radio" and "option" inputs the story is not as simple: All
-E<lt>input type="radio"E<gt> elements with the same name will
-contribute to the same input radio object. The number of radio input
-objects will be the same as the number of distinct names used for the
-E<lt>input type="radio"E<gt> elements. For a E<lt>selectE<gt> element
-without the C<multiple> attribute there will be one input object of
-type of "option". For a E<lt>select multipleE<gt> element there will
-be one input object for each contained E<lt>optionE<gt> element. Each
-one of these option objects will have the same name.
-
-The following methods are available for the I<input> objects:
-
-=over 4
-
-=cut
-
-sub new
-{
- my $class = shift;
- my $self = bless {@_}, $class;
- $self;
-}
-
-sub add_to_form
-{
- my($self, $form) = @_;
- push(@{$form->{'inputs'}}, $self);
- $self;
-}
-
-sub strict {
- my $self = shift;
- my $old = $self->{strict};
- if (@_) {
- $self->{strict} = shift;
- }
- $old;
-}
-
-sub fixup {}
-
-
-=item $input->type
-
-Returns the type of this input. The type is one of the following
-strings: "text", "password", "hidden", "textarea", "file", "image", "submit",
-"radio", "checkbox" or "option".
-
-=cut
-
-sub type
-{
- shift->{type};
-}
-
-=item $name = $input->name
-
-=item $input->name( $new_name )
-
-This method can be used to get/set the current name of the input.
-
-=item $input->id
-
-=item $input->class
-
-These methods can be used to get/set the current id or class attribute for the input.
-
-=item $input->selected( $selector )
-
-Returns TRUE if the given selector matched the input. See the description of
-the find_input() method above for a description of the selector syntax.
-
-=item $value = $input->value
-
-=item $input->value( $new_value )
-
-This method can be used to get/set the current value of an
-input.
-
-If strict is enabled and the input only can take an enumerated list of values,
-then it is an error to try to set it to something else and the method will
-croak if you try.
-
-You will also be able to set the value of read-only inputs, but a
-warning will be generated if running under C<perl -w>.
-
-=cut
-
-sub name
-{
- my $self = shift;
- my $old = $self->{name};
- $self->{name} = shift if @_;
- $old;
-}
-
-sub id
-{
- my $self = shift;
- my $old = $self->{id};
- $self->{id} = shift if @_;
- $old;
-}
-
-sub class
-{
- my $self = shift;
- my $old = $self->{class};
- $self->{class} = shift if @_;
- $old;
-}
-
-sub selected {
- my($self, $sel) = @_;
- return undef unless defined $sel;
- my $attr =
- $sel =~ s/^\^// ? "name" :
- $sel =~ s/^#// ? "id" :
- $sel =~ s/^\.// ? "class" :
- "name";
- return 0 unless defined $self->{$attr};
- return $self->{$attr} eq $sel;
-}
-
-sub value
-{
- my $self = shift;
- my $old = $self->{value};
- $self->{value} = shift if @_;
- $old;
-}
-
-=item $input->possible_values
-
-Returns a list of all values that an input can take. For inputs that
-do not have discrete values, this returns an empty list.
-
-=cut
-
-sub possible_values
-{
- return;
-}
-
-=item $input->other_possible_values
-
-Returns a list of all values not tried yet.
-
-=cut
-
-sub other_possible_values
-{
- return;
-}
-
-=item $input->value_names
-
-For some inputs the values can have names that are different from the
-values themselves. The number of names returned by this method will
-match the number of values reported by $input->possible_values.
-
-When setting values using the value() method it is also possible to
-use the value names in place of the value itself.
-
-=cut
-
-sub value_names {
- return
-}
-
-=item $bool = $input->readonly
-
-=item $input->readonly( $bool )
-
-This method is used to get/set the value of the readonly attribute.
-You are allowed to modify the value of readonly inputs, but setting
-the value will generate some noise when warnings are enabled. Hidden
-fields always start out readonly.
-
-=cut
-
-sub readonly {
- my $self = shift;
- my $old = $self->{readonly};
- $self->{readonly} = shift if @_;
- $old;
-}
-
-=item $bool = $input->disabled
-
-=item $input->disabled( $bool )
-
-This method is used to get/set the value of the disabled attribute.
-Disabled inputs do not contribute any key/value pairs for the form
-value.
-
-=cut
-
-sub disabled {
- my $self = shift;
- my $old = $self->{disabled};
- $self->{disabled} = shift if @_;
- $old;
-}
-
-=item $input->form_name_value
-
-Returns a (possible empty) list of key/value pairs that should be
-incorporated in the form value from this input.
-
-=cut
-
-sub form_name_value
-{
- my $self = shift;
- my $name = $self->{'name'};
- return unless defined $name;
- return if $self->disabled;
- my $value = $self->value;
- return unless defined $value;
- return ($name => $value);
-}
-
-sub dump
-{
- my $self = shift;
- my $name = $self->name;
- $name = "<NONAME>" unless defined $name;
- my $value = $self->value;
- $value = "<UNDEF>" unless defined $value;
- my $dump = "$name=$value";
-
- my $type = $self->type;
-
- $type .= " disabled" if $self->disabled;
- $type .= " readonly" if $self->readonly;
- return sprintf "%-30s %s", $dump, "($type)" unless $self->{menu};
-
- my @menu;
- my $i = 0;
- for (@{$self->{menu}}) {
- my $opt = $_->{value};
- $opt = "<UNDEF>" unless defined $opt;
- $opt .= "/$_->{name}"
- if defined $_->{name} && length $_->{name} && $_->{name} ne $opt;
- substr($opt,0,0) = "-" if $_->{disabled};
- if (exists $self->{current} && $self->{current} == $i) {
- substr($opt,0,0) = "!" unless $_->{seen};
- substr($opt,0,0) = "*";
- }
- else {
- substr($opt,0,0) = ":" if $_->{seen};
- }
- push(@menu, $opt);
- $i++;
- }
-
- return sprintf "%-30s %-10s %s", $dump, "($type)", "[" . join("|", @menu) . "]";
-}
-
-
-#---------------------------------------------------
-package HTML::Form::TextInput;
-@HTML::Form::TextInput::ISA=qw(HTML::Form::Input);
-
-#input/text
-#input/password
-#input/hidden
-#textarea
-
-sub value
-{
- my $self = shift;
- my $old = $self->{value};
- $old = "" unless defined $old;
- if (@_) {
- Carp::croak("Input '$self->{name}' is readonly")
- if $self->{strict} && $self->{readonly};
- my $new = shift;
- my $n = exists $self->{maxlength} ? $self->{maxlength} : undef;
- Carp::croak("Input '$self->{name}' has maxlength '$n'")
- if $self->{strict} && defined($n) && defined($new) && length($new) > $n;
- $self->{value} = $new;
- }
- $old;
-}
-
-#---------------------------------------------------
-package HTML::Form::IgnoreInput;
-@HTML::Form::IgnoreInput::ISA=qw(HTML::Form::Input);
-
-#input/button
-#input/reset
-
-sub value { return }
-
-
-#---------------------------------------------------
-package HTML::Form::ListInput;
-@HTML::Form::ListInput::ISA=qw(HTML::Form::Input);
-
-#select/option (val1, val2, ....)
-#input/radio (undef, val1, val2,...)
-#input/checkbox (undef, value)
-#select-multiple/option (undef, value)
-
-sub new
-{
- my $class = shift;
- my $self = $class->SUPER::new(@_);
-
- my $value = delete $self->{value};
- my $value_name = delete $self->{value_name};
- my $type = $self->{type};
-
- if ($type eq "checkbox") {
- $value = "on" unless defined $value;
- $self->{menu} = [
- { value => undef, name => "off", },
- { value => $value, name => $value_name, },
- ];
- $self->{current} = (delete $self->{checked}) ? 1 : 0;
- ;
- }
- else {
- $self->{option_disabled}++
- if $type eq "radio" && delete $self->{disabled};
- $self->{menu} = [
- {value => $value, name => $value_name},
- ];
- my $checked = $self->{checked} || $self->{option_selected};
- delete $self->{checked};
- delete $self->{option_selected};
- if (exists $self->{multiple}) {
- unshift(@{$self->{menu}}, { value => undef, name => "off"});
- $self->{current} = $checked ? 1 : 0;
- }
- else {
- $self->{current} = 0 if $checked;
- }
- }
- $self;
-}
-
-sub add_to_form
-{
- my($self, $form) = @_;
- my $type = $self->type;
-
- return $self->SUPER::add_to_form($form)
- if $type eq "checkbox";
-
- if ($type eq "option" && exists $self->{multiple}) {
- $self->{disabled} ||= delete $self->{option_disabled};
- return $self->SUPER::add_to_form($form);
- }
-
- die "Assert" if @{$self->{menu}} != 1;
- my $m = $self->{menu}[0];
- $m->{disabled}++ if delete $self->{option_disabled};
-
- my $prev = $form->find_input($self->{name}, $self->{type}, $self->{idx});
- return $self->SUPER::add_to_form($form) unless $prev;
-
- # merge menues
- $prev->{current} = @{$prev->{menu}} if exists $self->{current};
- push(@{$prev->{menu}}, $m);
-}
-
-sub fixup
-{
- my $self = shift;
- if ($self->{type} eq "option" && !(exists $self->{current})) {
- $self->{current} = 0;
- }
- $self->{menu}[$self->{current}]{seen}++ if exists $self->{current};
-}
-
-sub disabled
-{
- my $self = shift;
- my $type = $self->type;
-
- my $old = $self->{disabled} || _menu_all_disabled(@{$self->{menu}});
- if (@_) {
- my $v = shift;
- $self->{disabled} = $v;
- for (@{$self->{menu}}) {
- $_->{disabled} = $v;
- }
- }
- return $old;
-}
-
-sub _menu_all_disabled {
- for (@_) {
- return 0 unless $_->{disabled};
- }
- return 1;
-}
-
-sub value
-{
- my $self = shift;
- my $old;
- $old = $self->{menu}[$self->{current}]{value} if exists $self->{current};
- $old = $self->{value} if exists $self->{value};
- if (@_) {
- my $i = 0;
- my $val = shift;
- my $cur;
- my $disabled;
- for (@{$self->{menu}}) {
- if ((defined($val) && defined($_->{value}) && $val eq $_->{value}) ||
- (!defined($val) && !defined($_->{value}))
- )
- {
- $cur = $i;
- $disabled = $_->{disabled};
- last unless $disabled;
- }
- $i++;
- }
- if (!(defined $cur) || $disabled) {
- if (defined $val) {
- # try to search among the alternative names as well
- my $i = 0;
- my $cur_ignorecase;
- my $lc_val = lc($val);
- for (@{$self->{menu}}) {
- if (defined $_->{name}) {
- if ($val eq $_->{name}) {
- $disabled = $_->{disabled};
- $cur = $i;
- last unless $disabled;
- }
- if (!defined($cur_ignorecase) && $lc_val eq lc($_->{name})) {
- $cur_ignorecase = $i;
- }
- }
- $i++;
- }
- unless (defined $cur) {
- $cur = $cur_ignorecase;
- if (defined $cur) {
- $disabled = $self->{menu}[$cur]{disabled};
- }
- elsif ($self->{strict}) {
- my $n = $self->name;
- Carp::croak("Illegal value '$val' for field '$n'");
- }
- }
- }
- elsif ($self->{strict}) {
- my $n = $self->name;
- Carp::croak("The '$n' field can't be unchecked");
- }
- }
- if ($self->{strict} && $disabled) {
- my $n = $self->name;
- Carp::croak("The value '$val' has been disabled for field '$n'");
- }
- if (defined $cur) {
- $self->{current} = $cur;
- $self->{menu}[$cur]{seen}++;
- delete $self->{value};
- }
- else {
- $self->{value} = $val;
- delete $self->{current};
- }
- }
- $old;
-}
-
-=item $input->check
-
-Some input types represent toggles that can be turned on/off. This
-includes "checkbox" and "option" inputs. Calling this method turns
-this input on without having to know the value name. If the input is
-already on, then nothing happens.
-
-This has the same effect as:
-
- $input->value($input->possible_values[1]);
-
-The input can be turned off with:
-
- $input->value(undef);
-
-=cut
-
-sub check
-{
- my $self = shift;
- $self->{current} = 1;
- $self->{menu}[1]{seen}++;
-}
-
-sub possible_values
-{
- my $self = shift;
- map $_->{value}, grep !$_->{disabled}, @{$self->{menu}};
-}
-
-sub other_possible_values
-{
- my $self = shift;
- map $_->{value}, grep !$_->{seen} && !$_->{disabled}, @{$self->{menu}};
-}
-
-sub value_names {
- my $self = shift;
- my @names;
- for (@{$self->{menu}}) {
- my $n = $_->{name};
- $n = $_->{value} unless defined $n;
- push(@names, $n);
- }
- @names;
-}
-
-
-#---------------------------------------------------
-package HTML::Form::SubmitInput;
-@HTML::Form::SubmitInput::ISA=qw(HTML::Form::Input);
-
-#input/image
-#input/submit
-
-=item $input->click($form, $x, $y)
-
-Some input types (currently "submit" buttons and "images") can be
-clicked to submit the form. The click() method returns the
-corresponding C<HTTP::Request> object.
-
-=cut
-
-sub click
-{
- my($self,$form,$x,$y) = @_;
- for ($x, $y) { $_ = 1 unless defined; }
- local($self->{clicked}) = [$x,$y];
- return $form->make_request;
-}
-
-sub form_name_value
-{
- my $self = shift;
- return unless $self->{clicked};
- return $self->SUPER::form_name_value(@_);
-}
-
-
-#---------------------------------------------------
-package HTML::Form::ImageInput;
-@HTML::Form::ImageInput::ISA=qw(HTML::Form::SubmitInput);
-
-sub form_name_value
-{
- my $self = shift;
- my $clicked = $self->{clicked};
- return unless $clicked;
- return if $self->{disabled};
- my $name = $self->{name};
- $name = (defined($name) && length($name)) ? "$name." : "";
- return ("${name}x" => $clicked->[0],
- "${name}y" => $clicked->[1]
- );
-}
-
-#---------------------------------------------------
-package HTML::Form::FileInput;
-@HTML::Form::FileInput::ISA=qw(HTML::Form::TextInput);
-
-=back
-
-If the input is of type C<file>, then it has these additional methods:
-
-=over 4
-
-=item $input->file
-
-This is just an alias for the value() method. It sets the filename to
-read data from.
-
-For security reasons this field will never be initialized from the parsing
-of a form. This prevents the server from triggering stealth uploads of
-arbitrary files from the client machine.
-
-=cut
-
-sub file {
- my $self = shift;
- $self->value(@_);
-}
-
-=item $filename = $input->filename
-
-=item $input->filename( $new_filename )
-
-This get/sets the filename reported to the server during file upload.
-This attribute defaults to the value reported by the file() method.
-
-=cut
-
-sub filename {
- my $self = shift;
- my $old = $self->{filename};
- $self->{filename} = shift if @_;
- $old = $self->file unless defined $old;
- $old;
-}
-
-=item $content = $input->content
-
-=item $input->content( $new_content )
-
-This get/sets the file content provided to the server during file
-upload. This method can be used if you do not want the content to be
-read from an actual file.
-
-=cut
-
-sub content {
- my $self = shift;
- my $old = $self->{content};
- $self->{content} = shift if @_;
- $old;
-}
-
-=item @headers = $input->headers
-
-=item input->headers($key => $value, .... )
-
-This get/set additional header fields describing the file uploaded.
-This can for instance be used to set the C<Content-Type> reported for
-the file.
-
-=cut
-
-sub headers {
- my $self = shift;
- my $old = $self->{headers} || [];
- $self->{headers} = [@_] if @_;
- @$old;
-}
-
-sub form_name_value {
- my($self, $form) = @_;
- return $self->SUPER::form_name_value($form)
- if $form->method ne "POST" ||
- $form->enctype ne "multipart/form-data";
-
- my $name = $self->name;
- return unless defined $name;
- return if $self->{disabled};
-
- my $file = $self->file;
- my $filename = $self->filename;
- my @headers = $self->headers;
- my $content = $self->content;
- if (defined $content) {
- $filename = $file unless defined $filename;
- $file = undef;
- unshift(@headers, "Content" => $content);
- }
- elsif (!defined($file) || length($file) == 0) {
- return;
- }
-
- # legacy (this used to be the way to do it)
- if (ref($file) eq "ARRAY") {
- my $f = shift @$file;
- my $fn = shift @$file;
- push(@headers, @$file);
- $file = $f;
- $filename = $fn unless defined $filename;
- }
-
- return ($name => [$file, $filename, @headers]);
-}
-
-package HTML::Form::KeygenInput;
-@HTML::Form::KeygenInput::ISA=qw(HTML::Form::Input);
-
-sub challenge {
- my $self = shift;
- return $self->{challenge};
-}
-
-sub keytype {
- my $self = shift;
- return lc($self->{keytype} || 'rsa');
-}
-
-1;
-
-__END__
-
-=back
-
-=head1 SEE ALSO
-
-L<LWP>, L<LWP::UserAgent>, L<HTML::Parser>
-
-=head1 COPYRIGHT
-
-Copyright 1998-2008 Gisle Aas.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=cut
+++ /dev/null
-package HTTP::Config;
-
-use strict;
-use URI;
-use vars qw($VERSION);
-
-$VERSION = "5.835";
-
-sub new {
- my $class = shift;
- return bless [], $class;
-}
-
-sub entries {
- my $self = shift;
- @$self;
-}
-
-sub empty {
- my $self = shift;
- not @$self;
-}
-
-sub add {
- if (@_ == 2) {
- my $self = shift;
- push(@$self, shift);
- return;
- }
- my($self, %spec) = @_;
- push(@$self, \%spec);
- return;
-}
-
-sub find2 {
- my($self, %spec) = @_;
- my @found;
- my @rest;
- ITEM:
- for my $item (@$self) {
- for my $k (keys %spec) {
- if (!exists $item->{$k} || $spec{$k} ne $item->{$k}) {
- push(@rest, $item);
- next ITEM;
- }
- }
- push(@found, $item);
- }
- return \@found unless wantarray;
- return \@found, \@rest;
-}
-
-sub find {
- my $self = shift;
- my $f = $self->find2(@_);
- return @$f if wantarray;
- return $f->[0];
-}
-
-sub remove {
- my($self, %spec) = @_;
- my($removed, $rest) = $self->find2(%spec);
- @$self = @$rest if @$removed;
- return @$removed;
-}
-
-my %MATCH = (
- m_scheme => sub {
- my($v, $uri) = @_;
- return $uri->_scheme eq $v; # URI known to be canonical
- },
- m_secure => sub {
- my($v, $uri) = @_;
- my $secure = $uri->can("secure") ? $uri->secure : $uri->_scheme eq "https";
- return $secure == !!$v;
- },
- m_host_port => sub {
- my($v, $uri) = @_;
- return unless $uri->can("host_port");
- return $uri->host_port eq $v, 7;
- },
- m_host => sub {
- my($v, $uri) = @_;
- return unless $uri->can("host");
- return $uri->host eq $v, 6;
- },
- m_port => sub {
- my($v, $uri) = @_;
- return unless $uri->can("port");
- return $uri->port eq $v;
- },
- m_domain => sub {
- my($v, $uri) = @_;
- return unless $uri->can("host");
- my $h = $uri->host;
- $h = "$h.local" unless $h =~ /\./;
- $v = ".$v" unless $v =~ /^\./;
- return length($v), 5 if substr($h, -length($v)) eq $v;
- return 0;
- },
- m_path => sub {
- my($v, $uri) = @_;
- return unless $uri->can("path");
- return $uri->path eq $v, 4;
- },
- m_path_prefix => sub {
- my($v, $uri) = @_;
- return unless $uri->can("path");
- my $path = $uri->path;
- my $len = length($v);
- return $len, 3 if $path eq $v;
- return 0 if length($path) <= $len;
- $v .= "/" unless $v =~ m,/\z,,;
- return $len, 3 if substr($path, 0, length($v)) eq $v;
- return 0;
- },
- m_path_match => sub {
- my($v, $uri) = @_;
- return unless $uri->can("path");
- return $uri->path =~ $v;
- },
- m_uri__ => sub {
- my($v, $k, $uri) = @_;
- return unless $uri->can($k);
- return 1 unless defined $v;
- return $uri->$k eq $v;
- },
- m_method => sub {
- my($v, $uri, $request) = @_;
- return $request && $request->method eq $v;
- },
- m_proxy => sub {
- my($v, $uri, $request) = @_;
- return $request && ($request->{proxy} || "") eq $v;
- },
- m_code => sub {
- my($v, $uri, $request, $response) = @_;
- $v =~ s/xx\z//;
- return unless $response;
- return length($v), 2 if substr($response->code, 0, length($v)) eq $v;
- },
- m_media_type => sub { # for request too??
- my($v, $uri, $request, $response) = @_;
- return unless $response;
- return 1, 1 if $v eq "*/*";
- my $ct = $response->content_type;
- return 2, 1 if $v =~ s,/\*\z,, && $ct =~ m,^\Q$v\E/,;
- return 3, 1 if $v eq "html" && $response->content_is_html;
- return 4, 1 if $v eq "xhtml" && $response->content_is_xhtml;
- return 10, 1 if $v eq $ct;
- return 0;
- },
- m_header__ => sub {
- my($v, $k, $uri, $request, $response) = @_;
- return unless $request;
- return 1 if $request->header($k) eq $v;
- return 1 if $response && $response->header($k) eq $v;
- return 0;
- },
- m_response_attr__ => sub {
- my($v, $k, $uri, $request, $response) = @_;
- return unless $response;
- return 1 if !defined($v) && exists $response->{$k};
- return 0 unless exists $response->{$k};
- return 1 if $response->{$k} eq $v;
- return 0;
- },
-);
-
-sub matching {
- my $self = shift;
- if (@_ == 1) {
- if ($_[0]->can("request")) {
- unshift(@_, $_[0]->request);
- unshift(@_, undef) unless defined $_[0];
- }
- unshift(@_, $_[0]->uri_canonical) if $_[0] && $_[0]->can("uri_canonical");
- }
- my($uri, $request, $response) = @_;
- $uri = URI->new($uri) unless ref($uri);
-
- my @m;
- ITEM:
- for my $item (@$self) {
- my $order;
- for my $ikey (keys %$item) {
- my $mkey = $ikey;
- my $k;
- $k = $1 if $mkey =~ s/__(.*)/__/;
- if (my $m = $MATCH{$mkey}) {
- #print "$ikey $mkey\n";
- my($c, $o);
- my @arg = (
- defined($k) ? $k : (),
- $uri, $request, $response
- );
- my $v = $item->{$ikey};
- $v = [$v] unless ref($v) eq "ARRAY";
- for (@$v) {
- ($c, $o) = $m->($_, @arg);
- #print " - $_ ==> $c $o\n";
- last if $c;
- }
- next ITEM unless $c;
- $order->[$o || 0] += $c;
- }
- }
- $order->[7] ||= 0;
- $item->{_order} = join(".", reverse map sprintf("%03d", $_ || 0), @$order);
- push(@m, $item);
- }
- @m = sort { $b->{_order} cmp $a->{_order} } @m;
- delete $_->{_order} for @m;
- return @m if wantarray;
- return $m[0];
-}
-
-sub add_item {
- my $self = shift;
- my $item = shift;
- return $self->add(item => $item, @_);
-}
-
-sub remove_items {
- my $self = shift;
- return map $_->{item}, $self->remove(@_);
-}
-
-sub matching_items {
- my $self = shift;
- return map $_->{item}, $self->matching(@_);
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-HTTP::Config - Configuration for request and response objects
-
-=head1 SYNOPSIS
-
- use HTTP::Config;
- my $c = HTTP::Config->new;
- $c->add(m_domain => ".example.com", m_scheme => "http", verbose => 1);
-
- use HTTP::Request;
- my $request = HTTP::Request->new(GET => "http://www.example.com");
-
- if (my @m = $c->matching($request)) {
- print "Yadayada\n" if $m[0]->{verbose};
- }
-
-=head1 DESCRIPTION
-
-An C<HTTP::Config> object is a list of entries that
-can be matched against request or request/response pairs. Its
-purpose is to hold configuration data that can be looked up given a
-request or response object.
-
-Each configuration entry is a hash. Some keys specify matching to
-occur against attributes of request/response objects. Other keys can
-be used to hold user data.
-
-The following methods are provided:
-
-=over 4
-
-=item $conf = HTTP::Config->new
-
-Constructs a new empty C<HTTP::Config> object and returns it.
-
-=item $conf->entries
-
-Returns the list of entries in the configuration object.
-In scalar context returns the number of entries.
-
-=item $conf->empty
-
-Return true if there are no entries in the configuration object.
-This is just a shorthand for C<< not $conf->entries >>.
-
-=item $conf->add( %matchspec, %other )
-
-=item $conf->add( \%entry )
-
-Adds a new entry to the configuration.
-You can either pass separate key/value pairs or a hash reference.
-
-=item $conf->remove( %spec )
-
-Removes (and returns) the entries that have matches for all the key/value pairs in %spec.
-If %spec is empty this will match all entries; so it will empty the configuation object.
-
-=item $conf->matching( $uri, $request, $response )
-
-=item $conf->matching( $uri )
-
-=item $conf->matching( $request )
-
-=item $conf->matching( $response )
-
-Returns the entries that match the given $uri, $request and $response triplet.
-
-If called with a single $request object then the $uri is obtained by calling its 'uri_canonical' method.
-If called with a single $response object, then the request object is obtained by calling its 'request' method;
-and then the $uri is obtained as if a single $request was provided.
-
-The entries are returned with the most specific matches first.
-In scalar context returns the most specific match or C<undef> in none match.
-
-=item $conf->add_item( $item, %matchspec )
-
-=item $conf->remove_items( %spec )
-
-=item $conf->matching_items( $uri, $request, $response )
-
-Wrappers that hides the entries themselves.
-
-=back
-
-=head2 Matching
-
-The following keys on a configuration entry specify matching. For all
-of these you can provide an array of values instead of a single value.
-The entry matches if at least one of the values in the array matches.
-
-Entries that require match against a response object attribute will never match
-unless a response object was provided.
-
-=over
-
-=item m_scheme => $scheme
-
-Matches if the URI uses the specified scheme; e.g. "http".
-
-=item m_secure => $bool
-
-If $bool is TRUE; matches if the URI uses a secure scheme. If $bool
-is FALSE; matches if the URI does not use a secure scheme. An example
-of a secure scheme is "https".
-
-=item m_host_port => "$hostname:$port"
-
-Matches if the URI's host_port method return the specified value.
-
-=item m_host => $hostname
-
-Matches if the URI's host method returns the specified value.
-
-=item m_port => $port
-
-Matches if the URI's port method returns the specified value.
-
-=item m_domain => ".$domain"
-
-Matches if the URI's host method return a value that within the given
-domain. The hostname "www.example.com" will for instance match the
-domain ".com".
-
-=item m_path => $path
-
-Matches if the URI's path method returns the specified value.
-
-=item m_path_prefix => $path
-
-Matches if the URI's path is the specified path or has the specified
-path as prefix.
-
-=item m_path_match => $Regexp
-
-Matches if the regular expression matches the URI's path. Eg. qr/\.html$/.
-
-=item m_method => $method
-
-Matches if the request method matches the specified value. Eg. "GET" or "POST".
-
-=item m_code => $digit
-
-=item m_code => $status_code
-
-Matches if the response status code matches. If a single digit is
-specified; matches for all response status codes beginning with that digit.
-
-=item m_proxy => $url
-
-Matches if the request is to be sent to the given Proxy server.
-
-=item m_media_type => "*/*"
-
-=item m_media_type => "text/*"
-
-=item m_media_type => "html"
-
-=item m_media_type => "xhtml"
-
-=item m_media_type => "text/html"
-
-Matches if the response media type matches.
-
-With a value of "html" matches if $response->content_is_html returns TRUE.
-With a value of "xhtml" matches if $response->content_is_xhtml returns TRUE.
-
-=item m_uri__I<$method> => undef
-
-Matches if the URI object provides the method.
-
-=item m_uri__I<$method> => $string
-
-Matches if the URI's $method method returns the given value.
-
-=item m_header__I<$field> => $string
-
-Matches if either the request or the response have a header $field with the given value.
-
-=item m_response_attr__I<$key> => undef
-
-=item m_response_attr__I<$key> => $string
-
-Matches if the response object has that key, or the entry has the given value.
-
-=back
-
-=head1 SEE ALSO
-
-L<URI>, L<HTTP::Request>, L<HTTP::Response>
-
-=head1 COPYRIGHT
-
-Copyright 2008, Gisle Aas
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=cut
+++ /dev/null
-package HTTP::Cookies;
-
-use strict;
-use HTTP::Date qw(str2time parse_date time2str);
-use HTTP::Headers::Util qw(_split_header_words join_header_words);
-
-use vars qw($VERSION $EPOCH_OFFSET);
-$VERSION = "5.837";
-
-# Legacy: because "use "HTTP::Cookies" used be the ONLY way
-# to load the class HTTP::Cookies::Netscape.
-require HTTP::Cookies::Netscape;
-
-$EPOCH_OFFSET = 0; # difference from Unix epoch
-if ($^O eq "MacOS") {
- require Time::Local;
- $EPOCH_OFFSET = Time::Local::timelocal(0,0,0,1,0,70);
-}
-
-# A HTTP::Cookies object is a hash. The main attribute is the
-# COOKIES 3 level hash: $self->{COOKIES}{$domain}{$path}{$key}.
-
-sub new
-{
- my $class = shift;
- my $self = bless {
- COOKIES => {},
- }, $class;
- my %cnf = @_;
- for (keys %cnf) {
- $self->{lc($_)} = $cnf{$_};
- }
- $self->load;
- $self;
-}
-
-
-sub add_cookie_header
-{
- my $self = shift;
- my $request = shift || return;
- my $url = $request->uri;
- my $scheme = $url->scheme;
- unless ($scheme =~ /^https?\z/) {
- return;
- }
-
- my $domain = _host($request, $url);
- $domain = "$domain.local" unless $domain =~ /\./;
- my $secure_request = ($scheme eq "https");
- my $req_path = _url_path($url);
- my $req_port = $url->port;
- my $now = time();
- _normalize_path($req_path) if $req_path =~ /%/;
-
- my @cval; # cookie values for the "Cookie" header
- my $set_ver;
- my $netscape_only = 0; # An exact domain match applies to any cookie
-
- while ($domain =~ /\./) {
- # Checking $domain for cookies"
- my $cookies = $self->{COOKIES}{$domain};
- next unless $cookies;
- if ($self->{delayload} && defined($cookies->{'//+delayload'})) {
- my $cookie_data = $cookies->{'//+delayload'}{'cookie'};
- delete $self->{COOKIES}{$domain};
- $self->load_cookie($cookie_data->[1]);
- $cookies = $self->{COOKIES}{$domain};
- next unless $cookies; # should not really happen
- }
-
- # Want to add cookies corresponding to the most specific paths
- # first (i.e. longest path first)
- my $path;
- for $path (sort {length($b) <=> length($a) } keys %$cookies) {
- if (index($req_path, $path) != 0) {
- next;
- }
-
- my($key,$array);
- while (($key,$array) = each %{$cookies->{$path}}) {
- my($version,$val,$port,$path_spec,$secure,$expires) = @$array;
- if ($secure && !$secure_request) {
- next;
- }
- if ($expires && $expires < $now) {
- next;
- }
- if ($port) {
- my $found;
- if ($port =~ s/^_//) {
- # The corresponding Set-Cookie attribute was empty
- $found++ if $port eq $req_port;
- $port = "";
- }
- else {
- my $p;
- for $p (split(/,/, $port)) {
- $found++, last if $p eq $req_port;
- }
- }
- unless ($found) {
- next;
- }
- }
- if ($version > 0 && $netscape_only) {
- next;
- }
-
- # set version number of cookie header.
- # XXX: What should it be if multiple matching
- # Set-Cookie headers have different versions themselves
- if (!$set_ver++) {
- if ($version >= 1) {
- push(@cval, "\$Version=$version");
- }
- elsif (!$self->{hide_cookie2}) {
- $request->header(Cookie2 => '$Version="1"');
- }
- }
-
- # do we need to quote the value
- if ($val =~ /\W/ && $version) {
- $val =~ s/([\\\"])/\\$1/g;
- $val = qq("$val");
- }
-
- # and finally remember this cookie
- push(@cval, "$key=$val");
- if ($version >= 1) {
- push(@cval, qq(\$Path="$path")) if $path_spec;
- push(@cval, qq(\$Domain="$domain")) if $domain =~ /^\./;
- if (defined $port) {
- my $p = '$Port';
- $p .= qq(="$port") if length $port;
- push(@cval, $p);
- }
- }
-
- }
- }
-
- } continue {
- # Try with a more general domain, alternately stripping
- # leading name components and leading dots. When this
- # results in a domain with no leading dot, it is for
- # Netscape cookie compatibility only:
- #
- # a.b.c.net Any cookie
- # .b.c.net Any cookie
- # b.c.net Netscape cookie only
- # .c.net Any cookie
-
- if ($domain =~ s/^\.+//) {
- $netscape_only = 1;
- }
- else {
- $domain =~ s/[^.]*//;
- $netscape_only = 0;
- }
- }
-
- if (@cval) {
- if (my $old = $request->header("Cookie")) {
- unshift(@cval, $old);
- }
- $request->header(Cookie => join("; ", @cval));
- }
-
- $request;
-}
-
-
-sub extract_cookies
-{
- my $self = shift;
- my $response = shift || return;
-
- my @set = _split_header_words($response->_header("Set-Cookie2"));
- my @ns_set = $response->_header("Set-Cookie");
-
- return $response unless @set || @ns_set; # quick exit
-
- my $request = $response->request;
- my $url = $request->uri;
- my $req_host = _host($request, $url);
- $req_host = "$req_host.local" unless $req_host =~ /\./;
- my $req_port = $url->port;
- my $req_path = _url_path($url);
- _normalize_path($req_path) if $req_path =~ /%/;
-
- if (@ns_set) {
- # The old Netscape cookie format for Set-Cookie
- # http://curl.haxx.se/rfc/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();
-
- # Build a hash of cookies that was present in Set-Cookie2
- # headers. We need to skip them if we also find them in a
- # Set-Cookie header.
- my %in_set2;
- for (@set) {
- $in_set2{$_->[0]}++;
- }
-
- my $set;
- for $set (@ns_set) {
- $set =~ s/^\s+//;
- my @cur;
- my $param;
- my $expires;
- my $first_param = 1;
- for $param (split(/;\s*/, $set)) {
- next unless length($param);
- my($k,$v) = split(/\s*=\s*/, $param, 2);
- if (defined $v) {
- $v =~ s/\s+$//;
- #print "$k => $v\n";
- }
- else {
- $k =~ s/\s+$//;
- #print "$k => undef";
- }
- if (!$first_param && lc($k) eq "expires") {
- my $etime = str2time($v);
- if (defined $etime) {
- push(@cur, "Max-Age" => $etime - $now);
- $expires++;
- }
- else {
- # parse_date can deal with years outside the range of time_t,
- my($year, $mon, $day, $hour, $min, $sec, $tz) = parse_date($v);
- if ($year) {
- my $thisyear = (gmtime)[5] + 1900;
- if ($year < $thisyear) {
- push(@cur, "Max-Age" => -1); # any negative value will do
- $expires++;
- }
- elsif ($year >= $thisyear + 10) {
- # the date is at least 10 years into the future, just replace
- # it with something approximate
- push(@cur, "Max-Age" => 10 * 365 * 24 * 60 * 60);
- $expires++;
- }
- }
- }
- }
- elsif (!$first_param && lc($k) =~ /^(?:version|discard|ns-cookie)/) {
- # ignore
- }
- else {
- push(@cur, $k => $v);
- }
- $first_param = 0;
- }
- next unless @cur;
- next if $in_set2{$cur[0]};
-
-# push(@cur, "Port" => $req_port);
- push(@cur, "Discard" => undef) unless $expires;
- push(@cur, "Version" => 0);
- push(@cur, "ns-cookie" => 1);
- push(@set, \@cur);
- }
- }
-
- SET_COOKIE:
- for my $set (@set) {
- next unless @$set >= 2;
-
- my $key = shift @$set;
- my $val = shift @$set;
-
- my %hash;
- while (@$set) {
- my $k = shift @$set;
- my $v = shift @$set;
- my $lc = lc($k);
- # don't loose case distinction for unknown fields
- $k = $lc if $lc =~ /^(?:discard|domain|max-age|
- path|port|secure|version)$/x;
- if ($k eq "discard" || $k eq "secure") {
- $v = 1 unless defined $v;
- }
- next if exists $hash{$k}; # only first value is significant
- $hash{$k} = $v;
- };
-
- my %orig_hash = %hash;
- my $version = delete $hash{version};
- $version = 1 unless defined($version);
- my $discard = delete $hash{discard};
- my $secure = delete $hash{secure};
- my $maxage = delete $hash{'max-age'};
- my $ns_cookie = delete $hash{'ns-cookie'};
-
- # Check domain
- my $domain = delete $hash{domain};
- $domain = lc($domain) if defined $domain;
- if (defined($domain)
- && $domain ne $req_host && $domain ne ".$req_host") {
- if ($domain !~ /\./ && $domain ne "local") {
- next SET_COOKIE;
- }
- $domain = ".$domain" unless $domain =~ /^\./;
- if ($domain =~ /\.\d+$/) {
- next SET_COOKIE;
- }
- my $len = length($domain);
- unless (substr($req_host, -$len) eq $domain) {
- next SET_COOKIE;
- }
- my $hostpre = substr($req_host, 0, length($req_host) - $len);
- if ($hostpre =~ /\./ && !$ns_cookie) {
- next SET_COOKIE;
- }
- }
- else {
- $domain = $req_host;
- }
-
- my $path = delete $hash{path};
- my $path_spec;
- if (defined $path && $path ne '') {
- $path_spec++;
- _normalize_path($path) if $path =~ /%/;
- if (!$ns_cookie &&
- substr($req_path, 0, length($path)) ne $path) {
- next SET_COOKIE;
- }
- }
- else {
- $path = $req_path;
- $path =~ s,/[^/]*$,,;
- $path = "/" unless length($path);
- }
-
- my $port;
- if (exists $hash{port}) {
- $port = delete $hash{port};
- if (defined $port) {
- $port =~ s/\s+//g;
- my $found;
- for my $p (split(/,/, $port)) {
- unless ($p =~ /^\d+$/) {
- next SET_COOKIE;
- }
- $found++ if $p eq $req_port;
- }
- unless ($found) {
- next SET_COOKIE;
- }
- }
- else {
- $port = "_$req_port";
- }
- }
- $self->set_cookie($version,$key,$val,$path,$domain,$port,$path_spec,$secure,$maxage,$discard, \%hash)
- if $self->set_cookie_ok(\%orig_hash);
- }
-
- $response;
-}
-
-sub set_cookie_ok
-{
- 1;
-}
-
-
-sub set_cookie
-{
- my $self = shift;
- my($version,
- $key, $val, $path, $domain, $port,
- $path_spec, $secure, $maxage, $discard, $rest) = @_;
-
- # path and key can not be empty (key can't start with '$')
- return $self if !defined($path) || $path !~ m,^/, ||
- !defined($key) || $key =~ m,^\$,;
-
- # ensure legal port
- if (defined $port) {
- return $self unless $port =~ /^_?\d+(?:,\d+)*$/;
- }
-
- my $expires;
- if (defined $maxage) {
- if ($maxage <= 0) {
- delete $self->{COOKIES}{$domain}{$path}{$key};
- return $self;
- }
- $expires = time() + $maxage;
- }
- $version = 0 unless defined $version;
-
- my @array = ($version, $val,$port,
- $path_spec,
- $secure, $expires, $discard);
- push(@array, {%$rest}) if defined($rest) && %$rest;
- # trim off undefined values at end
- pop(@array) while !defined $array[-1];
-
- $self->{COOKIES}{$domain}{$path}{$key} = \@array;
- $self;
-}
-
-
-sub save
-{
- my $self = shift;
- my $file = shift || $self->{'file'} || return;
- local(*FILE);
- open(FILE, ">$file") or die "Can't open $file: $!";
- print FILE "#LWP-Cookies-1.0\n";
- print FILE $self->as_string(!$self->{ignore_discard});
- close(FILE);
- 1;
-}
-
-
-sub load
-{
- my $self = shift;
- my $file = shift || $self->{'file'} || return;
- local(*FILE, $_);
- local $/ = "\n"; # make sure we got standard record separator
- open(FILE, $file) or return;
- my $magic = <FILE>;
- unless ($magic =~ /^\#LWP-Cookies-(\d+\.\d+)/) {
- warn "$file does not seem to contain cookies";
- return;
- }
- while (<FILE>) {
- next unless s/^Set-Cookie3:\s*//;
- chomp;
- my $cookie;
- for $cookie (_split_header_words($_)) {
- my($key,$val) = splice(@$cookie, 0, 2);
- my %hash;
- while (@$cookie) {
- my $k = shift @$cookie;
- my $v = shift @$cookie;
- $hash{$k} = $v;
- }
- my $version = delete $hash{version};
- my $path = delete $hash{path};
- my $domain = delete $hash{domain};
- my $port = delete $hash{port};
- my $expires = str2time(delete $hash{expires});
-
- my $path_spec = exists $hash{path_spec}; delete $hash{path_spec};
- my $secure = exists $hash{secure}; delete $hash{secure};
- my $discard = exists $hash{discard}; delete $hash{discard};
-
- my @array = ($version,$val,$port,
- $path_spec,$secure,$expires,$discard);
- push(@array, \%hash) if %hash;
- $self->{COOKIES}{$domain}{$path}{$key} = \@array;
- }
- }
- close(FILE);
- 1;
-}
-
-
-sub revert
-{
- my $self = shift;
- $self->clear->load;
- $self;
-}
-
-
-sub clear
-{
- my $self = shift;
- if (@_ == 0) {
- $self->{COOKIES} = {};
- }
- elsif (@_ == 1) {
- delete $self->{COOKIES}{$_[0]};
- }
- elsif (@_ == 2) {
- delete $self->{COOKIES}{$_[0]}{$_[1]};
- }
- elsif (@_ == 3) {
- delete $self->{COOKIES}{$_[0]}{$_[1]}{$_[2]};
- }
- else {
- require Carp;
- Carp::carp('Usage: $c->clear([domain [,path [,key]]])');
- }
- $self;
-}
-
-
-sub clear_temporary_cookies
-{
- my($self) = @_;
-
- $self->scan(sub {
- if($_[9] or # "Discard" flag set
- not $_[8]) { # No expire field?
- $_[8] = -1; # Set the expire/max_age field
- $self->set_cookie(@_); # Clear the cookie
- }
- });
-}
-
-
-sub DESTROY
-{
- my $self = shift;
- local($., $@, $!, $^E, $?);
- $self->save if $self->{'autosave'};
-}
-
-
-sub scan
-{
- my($self, $cb) = @_;
- my($domain,$path,$key);
- for $domain (sort keys %{$self->{COOKIES}}) {
- for $path (sort keys %{$self->{COOKIES}{$domain}}) {
- for $key (sort keys %{$self->{COOKIES}{$domain}{$path}}) {
- my($version,$val,$port,$path_spec,
- $secure,$expires,$discard,$rest) =
- @{$self->{COOKIES}{$domain}{$path}{$key}};
- $rest = {} unless defined($rest);
- &$cb($version,$key,$val,$path,$domain,$port,
- $path_spec,$secure,$expires,$discard,$rest);
- }
- }
- }
-}
-
-
-sub as_string
-{
- my($self, $skip_discard) = @_;
- my @res;
- $self->scan(sub {
- my($version,$key,$val,$path,$domain,$port,
- $path_spec,$secure,$expires,$discard,$rest) = @_;
- return if $discard && $skip_discard;
- my @h = ($key, $val);
- push(@h, "path", $path);
- push(@h, "domain" => $domain);
- push(@h, "port" => $port) if defined $port;
- push(@h, "path_spec" => undef) if $path_spec;
- push(@h, "secure" => undef) if $secure;
- push(@h, "expires" => HTTP::Date::time2isoz($expires)) if $expires;
- push(@h, "discard" => undef) if $discard;
- my $k;
- for $k (sort keys %$rest) {
- push(@h, $k, $rest->{$k});
- }
- push(@h, "version" => $version);
- push(@res, "Set-Cookie3: " . join_header_words(\@h));
- });
- join("\n", @res, "");
-}
-
-sub _host
-{
- my($request, $url) = @_;
- if (my $h = $request->header("Host")) {
- $h =~ s/:\d+$//; # might have a port as well
- return lc($h);
- }
- return lc($url->host);
-}
-
-sub _url_path
-{
- my $url = shift;
- my $path;
- if($url->can('epath')) {
- $path = $url->epath; # URI::URL method
- }
- else {
- $path = $url->path; # URI::_generic method
- }
- $path = "/" unless length $path;
- $path;
-}
-
-sub _normalize_path # so that plain string compare can be used
-{
- my $x;
- $_[0] =~ s/%([0-9a-fA-F][0-9a-fA-F])/
- $x = uc($1);
- $x eq "2F" || $x eq "25" ? "%$x" :
- pack("C", hex($x));
- /eg;
- $_[0] =~ s/([\0-\x20\x7f-\xff])/sprintf("%%%02X",ord($1))/eg;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-HTTP::Cookies - HTTP cookie jars
-
-=head1 SYNOPSIS
-
- use HTTP::Cookies;
- $cookie_jar = HTTP::Cookies->new(
- file => "$ENV{'HOME'}/lwp_cookies.dat",
- autosave => 1,
- );
-
- use LWP;
- my $browser = LWP::UserAgent->new;
- $browser->cookie_jar($cookie_jar);
-
-Or for an empty and temporary cookie jar:
-
- use LWP;
- my $browser = LWP::UserAgent->new;
- $browser->cookie_jar( {} );
-
-=head1 DESCRIPTION
-
-This class is for objects that represent a "cookie jar" -- that is, a
-database of all the HTTP cookies that a given LWP::UserAgent object
-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://curl.haxx.se/rfc/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.
-
-Instances of the class I<HTTP::Cookies> are able to store a collection
-of Set-Cookie2: and Set-Cookie: headers and are able to use this
-information to initialize Cookie-headers in I<HTTP::Request> objects.
-The state of a I<HTTP::Cookies> object can be saved in and restored from
-files.
-
-=head1 METHODS
-
-The following methods are provided:
-
-=over 4
-
-=item $cookie_jar = HTTP::Cookies->new
-
-The constructor takes hash style parameters. The following
-parameters are recognized:
-
- file: name of the file to restore cookies from and save cookies to
- autosave: save during destruction (bool)
- ignore_discard: save even cookies that are requested to be discarded (bool)
- hide_cookie2: do not add Cookie2 header to requests
-
-Future parameters might include (not yet implemented):
-
- max_cookies 300
- max_cookies_per_domain 20
- max_cookie_size 4096
-
- no_cookies list of domain names that we never return cookies to
-
-=item $cookie_jar->add_cookie_header( $request )
-
-The add_cookie_header() method will set the appropriate Cookie:-header
-for the I<HTTP::Request> object given as argument. The $request must
-have a valid url attribute before this method is called.
-
-=item $cookie_jar->extract_cookies( $response )
-
-The extract_cookies() method will look for Set-Cookie: and
-Set-Cookie2: headers in the I<HTTP::Response> object passed as
-argument. Any of these headers that are found are used to update
-the state of the $cookie_jar.
-
-=item $cookie_jar->set_cookie( $version, $key, $val, $path, $domain, $port, $path_spec, $secure, $maxage, $discard, \%rest )
-
-The set_cookie() method updates the state of the $cookie_jar. The
-$key, $val, $domain, $port and $path arguments are strings. The
-$path_spec, $secure, $discard arguments are boolean values. The $maxage
-value is a number indicating number of seconds that this cookie will
-live. A value <= 0 will delete this cookie. %rest defines
-various other attributes like "Comment" and "CommentURL".
-
-=item $cookie_jar->save
-
-=item $cookie_jar->save( $file )
-
-This method file saves the state of the $cookie_jar to a file.
-The state can then be restored later using the load() method. If a
-filename is not specified we will use the name specified during
-construction. If the attribute I<ignore_discard> is set, then we
-will even save cookies that are marked to be discarded.
-
-The default is to save a sequence of "Set-Cookie3" lines.
-"Set-Cookie3" is a proprietary LWP format, not known to be compatible
-with any browser. The I<HTTP::Cookies::Netscape> sub-class can
-be used to save in a format compatible with Netscape.
-
-=item $cookie_jar->load
-
-=item $cookie_jar->load( $file )
-
-This method reads the cookies from the file and adds them to the
-$cookie_jar. The file must be in the format written by the save()
-method.
-
-=item $cookie_jar->revert
-
-This method empties the $cookie_jar and re-loads the $cookie_jar
-from the last save file.
-
-=item $cookie_jar->clear
-
-=item $cookie_jar->clear( $domain )
-
-=item $cookie_jar->clear( $domain, $path )
-
-=item $cookie_jar->clear( $domain, $path, $key )
-
-Invoking this method without arguments will empty the whole
-$cookie_jar. If given a single argument only cookies belonging to
-that domain will be removed. If given two arguments, cookies
-belonging to the specified path within that domain are removed. If
-given three arguments, then the cookie with the specified key, path
-and domain is removed.
-
-=item $cookie_jar->clear_temporary_cookies
-
-Discard all temporary cookies. Scans for all cookies in the jar
-with either no expire field or a true C<discard> flag. To be
-called when the user agent shuts down according to RFC 2965.
-
-=item $cookie_jar->scan( \&callback )
-
-The argument is a subroutine that will be invoked for each cookie
-stored in the $cookie_jar. The subroutine will be invoked with
-the following arguments:
-
- 0 version
- 1 key
- 2 val
- 3 path
- 4 domain
- 5 port
- 6 path_spec
- 7 secure
- 8 expires
- 9 discard
- 10 hash
-
-=item $cookie_jar->as_string
-
-=item $cookie_jar->as_string( $skip_discardables )
-
-The as_string() method will return the state of the $cookie_jar
-represented as a sequence of "Set-Cookie3" header lines separated by
-"\n". If $skip_discardables is TRUE, it will not return lines for
-cookies with the I<Discard> attribute.
-
-=back
-
-=head1 SEE ALSO
-
-L<HTTP::Cookies::Netscape>, L<HTTP::Cookies::Microsoft>
-
-=head1 COPYRIGHT
-
-Copyright 1997-2002 Gisle Aas
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
+++ /dev/null
-package HTTP::Cookies::Microsoft;
-
-use strict;
-
-use vars qw(@ISA $VERSION);
-
-$VERSION = "5.821";
-
-require HTTP::Cookies;
-@ISA=qw(HTTP::Cookies);
-
-sub load_cookies_from_file
-{
- my ($file) = @_;
- my @cookies;
- my ($key, $value, $domain_path, $flags, $lo_expire, $hi_expire);
- my ($lo_create, $hi_create, $sep);
-
- open(COOKIES, $file) || return;
-
- while ($key = <COOKIES>)
- {
- chomp($key);
- chomp($value = <COOKIES>);
- chomp($domain_path= <COOKIES>);
- chomp($flags = <COOKIES>); # 0x0001 bit is for secure
- chomp($lo_expire = <COOKIES>);
- chomp($hi_expire = <COOKIES>);
- chomp($lo_create = <COOKIES>);
- chomp($hi_create = <COOKIES>);
- chomp($sep = <COOKIES>);
-
- if (!defined($key) || !defined($value) || !defined($domain_path) ||
- !defined($flags) || !defined($hi_expire) || !defined($lo_expire) ||
- !defined($hi_create) || !defined($lo_create) || !defined($sep) ||
- ($sep ne '*'))
- {
- last;
- }
-
- if ($domain_path =~ /^([^\/]+)(\/.*)$/)
- {
- my $domain = $1;
- my $path = $2;
-
- push(@cookies, {KEY => $key, VALUE => $value, DOMAIN => $domain,
- PATH => $path, FLAGS =>$flags, HIXP =>$hi_expire,
- LOXP => $lo_expire, HICREATE => $hi_create,
- LOCREATE => $lo_create});
- }
- }
-
- return \@cookies;
-}
-
-sub get_user_name
-{
- use Win32;
- use locale;
- my $user = lc(Win32::LoginName());
-
- return $user;
-}
-
-# MSIE stores create and expire times as Win32 FILETIME,
-# which is 64 bits of 100 nanosecond intervals since Jan 01 1601
-#
-# But Cookies code expects time in 32-bit value expressed
-# in seconds since Jan 01 1970
-#
-sub epoch_time_offset_from_win32_filetime
-{
- my ($high, $low) = @_;
-
- #--------------------------------------------------------
- # USEFUL CONSTANT
- #--------------------------------------------------------
- # 0x019db1de 0xd53e8000 is 1970 Jan 01 00:00:00 in Win32 FILETIME
- #
- # 100 nanosecond intervals == 0.1 microsecond intervals
-
- my $filetime_low32_1970 = 0xd53e8000;
- my $filetime_high32_1970 = 0x019db1de;
-
- #------------------------------------
- # ALGORITHM
- #------------------------------------
- # To go from 100 nanosecond intervals to seconds since 00:00 Jan 01 1970:
- #
- # 1. Adjust 100 nanosecond intervals to Jan 01 1970 base
- # 2. Divide by 10 to get to microseconds (1/millionth second)
- # 3. Divide by 1000000 (10 ^ 6) to get to seconds
- #
- # We can combine Step 2 & 3 into one divide.
- #
- # After much trial and error, I came up with the following code which
- # avoids using Math::BigInt or floating pt, but still gives correct answers
-
- # If the filetime is before the epoch, return 0
- if (($high < $filetime_high32_1970) ||
- (($high == $filetime_high32_1970) && ($low < $filetime_low32_1970)))
- {
- return 0;
- }
-
- # Can't multiply by 0x100000000, (1 << 32),
- # without Perl issuing an integer overflow warning
- #
- # So use two multiplies by 0x10000 instead of one multiply by 0x100000000
- #
- # The result is the same.
- #
- my $date1970 = (($filetime_high32_1970 * 0x10000) * 0x10000) + $filetime_low32_1970;
- my $time = (($high * 0x10000) * 0x10000) + $low;
-
- $time -= $date1970;
- $time /= 10000000;
-
- return $time;
-}
-
-sub load_cookie
-{
- my($self, $file) = @_;
- my $now = time() - $HTTP::Cookies::EPOCH_OFFSET;
- my $cookie_data;
-
- if (-f $file)
- {
- # open the cookie file and get the data
- $cookie_data = load_cookies_from_file($file);
-
- foreach my $cookie (@{$cookie_data})
- {
- my $secure = ($cookie->{FLAGS} & 1) != 0;
- my $expires = epoch_time_offset_from_win32_filetime($cookie->{HIXP}, $cookie->{LOXP});
-
- $self->set_cookie(undef, $cookie->{KEY}, $cookie->{VALUE},
- $cookie->{PATH}, $cookie->{DOMAIN}, undef,
- 0, $secure, $expires-$now, 0);
- }
- }
-}
-
-sub load
-{
- my($self, $cookie_index) = @_;
- my $now = time() - $HTTP::Cookies::EPOCH_OFFSET;
- my $cookie_dir = '';
- my $delay_load = (defined($self->{'delayload'}) && $self->{'delayload'});
- my $user_name = get_user_name();
- my $data;
-
- $cookie_index ||= $self->{'file'} || return;
- if ($cookie_index =~ /[\\\/][^\\\/]+$/)
- {
- $cookie_dir = $` . "\\";
- }
-
- local(*INDEX, $_);
-
- open(INDEX, $cookie_index) || return;
- binmode(INDEX);
- if (256 != read(INDEX, $data, 256))
- {
- warn "$cookie_index file is not large enough";
- close(INDEX);
- return;
- }
-
- # Cookies' index.dat file starts with 32 bytes of signature
- # followed by an offset to the first record, stored as a little-endian DWORD
- my ($sig, $size) = unpack('a32 V', $data);
-
- if (($sig !~ /^Client UrlCache MMF Ver 5\.2/) || # check that sig is valid (only tested in IE6.0)
- (0x4000 != $size))
- {
- warn "$cookie_index ['$sig' $size] does not seem to contain cookies";
- close(INDEX);
- return;
- }
-
- if (0 == seek(INDEX, $size, 0)) # move the file ptr to start of the first record
- {
- close(INDEX);
- return;
- }
-
- # Cookies are usually stored in 'URL ' records in two contiguous 0x80 byte sectors (256 bytes)
- # so read in two 0x80 byte sectors and adjust if not a Cookie.
- while (256 == read(INDEX, $data, 256))
- {
- # each record starts with a 4-byte signature
- # and a count (little-endian DWORD) of 0x80 byte sectors for the record
- ($sig, $size) = unpack('a4 V', $data);
-
- # Cookies are found in 'URL ' records
- if ('URL ' ne $sig)
- {
- # skip over uninteresting record: I've seen 'HASH' and 'LEAK' records
- if (($sig eq 'HASH') || ($sig eq 'LEAK'))
- {
- # '-2' takes into account the two 0x80 byte sectors we've just read in
- if (($size > 0) && ($size != 2))
- {
- if (0 == seek(INDEX, ($size-2)*0x80, 1))
- {
- # Seek failed. Something's wrong. Gonna stop.
- last;
- }
- }
- }
- next;
- }
-
- #$REMOVE Need to check if URL records in Cookies' index.dat will
- # ever use more than two 0x80 byte sectors
- if ($size > 2)
- {
- my $more_data = ($size-2)*0x80;
-
- if ($more_data != read(INDEX, $data, $more_data, 256))
- {
- last;
- }
- }
-
- (my $user_name2 = $user_name) =~ s/ /_/g;
- if ($data =~ /Cookie\:\Q$user_name\E\@([\x21-\xFF]+).*?((?:\Q$user_name\E|\Q$user_name2\E)\@[\x21-\xFF]+\.txt)/)
- {
- my $cookie_file = $cookie_dir . $2; # form full pathname
-
- if (!$delay_load)
- {
- $self->load_cookie($cookie_file);
- }
- else
- {
- my $domain = $1;
-
- # grab only the domain name, drop everything from the first dir sep on
- if ($domain =~ m{[\\/]})
- {
- $domain = $`;
- }
-
- # set the delayload cookie for this domain with
- # the cookie_file as cookie for later-loading info
- $self->set_cookie(undef, 'cookie', $cookie_file,
- '//+delayload', $domain, undef,
- 0, 0, $now+86400, 0);
- }
- }
- }
-
- close(INDEX);
-
- 1;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-HTTP::Cookies::Microsoft - access to Microsoft cookies files
-
-=head1 SYNOPSIS
-
- use LWP;
- use HTTP::Cookies::Microsoft;
- use Win32::TieRegistry(Delimiter => "/");
- my $cookies_dir = $Registry->
- {"CUser/Software/Microsoft/Windows/CurrentVersion/Explorer/Shell Folders/Cookies"};
-
- $cookie_jar = HTTP::Cookies::Microsoft->new(
- file => "$cookies_dir\\index.dat",
- 'delayload' => 1,
- );
- my $browser = LWP::UserAgent->new;
- $browser->cookie_jar( $cookie_jar );
-
-=head1 DESCRIPTION
-
-This is a subclass of C<HTTP::Cookies> which
-loads Microsoft Internet Explorer 5.x and 6.x for Windows (MSIE)
-cookie files.
-
-See the documentation for L<HTTP::Cookies>.
-
-=head1 METHODS
-
-The following methods are provided:
-
-=over 4
-
-=item $cookie_jar = HTTP::Cookies::Microsoft->new;
-
-The constructor takes hash style parameters. In addition
-to the regular HTTP::Cookies parameters, HTTP::Cookies::Microsoft
-recognizes the following:
-
- delayload: delay loading of cookie data until a request
- is actually made. This results in faster
- runtime unless you use most of the cookies
- since only the domain's cookie data
- is loaded on demand.
-
-=back
-
-=head1 CAVEATS
-
-Please note that the code DOESN'T support saving to the MSIE
-cookie file format.
-
-=head1 AUTHOR
-
-Johnny Lee <typo_pl@hotmail.com>
-
-=head1 COPYRIGHT
-
-Copyright 2002 Johnny Lee
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=cut
-
+++ /dev/null
-package HTTP::Cookies::Netscape;
-
-use strict;
-use vars qw(@ISA $VERSION);
-
-$VERSION = "5.832";
-
-require HTTP::Cookies;
-@ISA=qw(HTTP::Cookies);
-
-sub load
-{
- my($self, $file) = @_;
- $file ||= $self->{'file'} || return;
- local(*FILE, $_);
- local $/ = "\n"; # make sure we got standard record separator
- my @cookies;
- open(FILE, $file) || return;
- my $magic = <FILE>;
- unless ($magic =~ /^\#(?: Netscape)? HTTP Cookie File/) {
- warn "$file does not look like a netscape cookies file" if $^W;
- close(FILE);
- return;
- }
- my $now = time() - $HTTP::Cookies::EPOCH_OFFSET;
- while (<FILE>) {
- next if /^\s*\#/;
- next if /^\s*$/;
- tr/\n\r//d;
- my($domain,$bool1,$path,$secure, $expires,$key,$val) = split(/\t/, $_);
- $secure = ($secure eq "TRUE");
- $self->set_cookie(undef,$key,$val,$path,$domain,undef,
- 0,$secure,$expires-$now, 0);
- }
- close(FILE);
- 1;
-}
-
-sub save
-{
- my($self, $file) = @_;
- $file ||= $self->{'file'} || return;
- local(*FILE, $_);
- open(FILE, ">$file") || return;
-
- # Use old, now broken link to the old cookie spec just in case something
- # else (not us!) requires the comment block exactly this way.
- print FILE <<EOT;
-# Netscape HTTP Cookie File
-# http://www.netscape.com/newsref/std/cookie_spec.html
-# This is a generated file! Do not edit.
-
-EOT
-
- my $now = time - $HTTP::Cookies::EPOCH_OFFSET;
- $self->scan(sub {
- my($version,$key,$val,$path,$domain,$port,
- $path_spec,$secure,$expires,$discard,$rest) = @_;
- return if $discard && !$self->{ignore_discard};
- $expires = $expires ? $expires - $HTTP::Cookies::EPOCH_OFFSET : 0;
- return if $now > $expires;
- $secure = $secure ? "TRUE" : "FALSE";
- my $bool = $domain =~ /^\./ ? "TRUE" : "FALSE";
- print FILE join("\t", $domain, $bool, $path, $secure, $expires, $key, $val), "\n";
- });
- close(FILE);
- 1;
-}
-
-1;
-__END__
-
-=head1 NAME
-
-HTTP::Cookies::Netscape - access to Netscape cookies files
-
-=head1 SYNOPSIS
-
- use LWP;
- use HTTP::Cookies::Netscape;
- $cookie_jar = HTTP::Cookies::Netscape->new(
- file => "c:/program files/netscape/users/ZombieCharity/cookies.txt",
- );
- my $browser = LWP::UserAgent->new;
- $browser->cookie_jar( $cookie_jar );
-
-=head1 DESCRIPTION
-
-This is a subclass of C<HTTP::Cookies> that reads (and optionally
-writes) Netscape/Mozilla cookie files.
-
-See the documentation for L<HTTP::Cookies>.
-
-=head1 CAVEATS
-
-Please note that the Netscape/Mozilla cookie file format can't store
-all the information available in the Set-Cookie2 headers, so you will
-probably lose some information if you save in this format.
-
-At time of writing, this module seems to work fine with Mozilla
-Phoenix/Firebird.
-
-=head1 SEE ALSO
-
-L<HTTP::Cookies::Microsoft>
-
-=head1 COPYRIGHT
-
-Copyright 2002-2003 Gisle Aas
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=cut
+++ /dev/null
-package HTTP::Daemon;
-
-use strict;
-use vars qw($VERSION @ISA $PROTO $DEBUG);
-
-$VERSION = "5.827";
-
-use IO::Socket qw(AF_INET INADDR_ANY inet_ntoa);
-@ISA=qw(IO::Socket::INET);
-
-$PROTO = "HTTP/1.1";
-
-
-sub new
-{
- my($class, %args) = @_;
- $args{Listen} ||= 5;
- $args{Proto} ||= 'tcp';
- return $class->SUPER::new(%args);
-}
-
-
-sub accept
-{
- my $self = shift;
- my $pkg = shift || "HTTP::Daemon::ClientConn";
- my ($sock, $peer) = $self->SUPER::accept($pkg);
- if ($sock) {
- ${*$sock}{'httpd_daemon'} = $self;
- return wantarray ? ($sock, $peer) : $sock;
- }
- else {
- return;
- }
-}
-
-
-sub url
-{
- my $self = shift;
- my $url = $self->_default_scheme . "://";
- my $addr = $self->sockaddr;
- if (!$addr || $addr eq INADDR_ANY) {
- require Sys::Hostname;
- $url .= lc Sys::Hostname::hostname();
- }
- else {
- $url .= gethostbyaddr($addr, AF_INET) || inet_ntoa($addr);
- }
- my $port = $self->sockport;
- $url .= ":$port" if $port != $self->_default_port;
- $url .= "/";
- $url;
-}
-
-
-sub _default_port {
- 80;
-}
-
-
-sub _default_scheme {
- "http";
-}
-
-
-sub product_tokens
-{
- "libwww-perl-daemon/$HTTP::Daemon::VERSION";
-}
-
-
-
-package HTTP::Daemon::ClientConn;
-
-use vars qw(@ISA $DEBUG);
-use IO::Socket ();
-@ISA=qw(IO::Socket::INET);
-*DEBUG = \$HTTP::Daemon::DEBUG;
-
-use HTTP::Request ();
-use HTTP::Response ();
-use HTTP::Status;
-use HTTP::Date qw(time2str);
-use LWP::MediaTypes qw(guess_media_type);
-use Carp ();
-
-my $CRLF = "\015\012"; # "\r\n" is not portable
-my $HTTP_1_0 = _http_version("HTTP/1.0");
-my $HTTP_1_1 = _http_version("HTTP/1.1");
-
-
-sub get_request
-{
- my($self, $only_headers) = @_;
- if (${*$self}{'httpd_nomore'}) {
- $self->reason("No more requests from this connection");
- return;
- }
-
- $self->reason("");
- my $buf = ${*$self}{'httpd_rbuf'};
- $buf = "" unless defined $buf;
-
- my $timeout = $ {*$self}{'io_socket_timeout'};
- my $fdset = "";
- vec($fdset, $self->fileno, 1) = 1;
- local($_);
-
- READ_HEADER:
- while (1) {
- # loop until we have the whole header in $buf
- $buf =~ s/^(?:\015?\012)+//; # ignore leading blank lines
- if ($buf =~ /\012/) { # potential, has at least one line
- if ($buf =~ /^\w+[^\012]+HTTP\/\d+\.\d+\015?\012/) {
- if ($buf =~ /\015?\012\015?\012/) {
- last READ_HEADER; # we have it
- }
- elsif (length($buf) > 16*1024) {
- $self->send_error(413); # REQUEST_ENTITY_TOO_LARGE
- $self->reason("Very long header");
- return;
- }
- }
- else {
- last READ_HEADER; # HTTP/0.9 client
- }
- }
- elsif (length($buf) > 16*1024) {
- $self->send_error(414); # REQUEST_URI_TOO_LARGE
- $self->reason("Very long first line");
- return;
- }
- print STDERR "Need more data for complete header\n" if $DEBUG;
- return unless $self->_need_more($buf, $timeout, $fdset);
- }
- if ($buf !~ s/^(\S+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) {
- ${*$self}{'httpd_client_proto'} = _http_version("HTTP/1.0");
- $self->send_error(400); # BAD_REQUEST
- $self->reason("Bad request line: $buf");
- return;
- }
- my $method = $1;
- my $uri = $2;
- my $proto = $3 || "HTTP/0.9";
- $uri = "http://$uri" if $method eq "CONNECT";
- $uri = $HTTP::URI_CLASS->new($uri, $self->daemon->url);
- my $r = HTTP::Request->new($method, $uri);
- $r->protocol($proto);
- ${*$self}{'httpd_client_proto'} = $proto = _http_version($proto);
- ${*$self}{'httpd_head'} = ($method eq "HEAD");
-
- if ($proto >= $HTTP_1_0) {
- # we expect to find some headers
- my($key, $val);
- HEADER:
- while ($buf =~ s/^([^\012]*)\012//) {
- $_ = $1;
- s/\015$//;
- if (/^([^:\s]+)\s*:\s*(.*)/) {
- $r->push_header($key, $val) if $key;
- ($key, $val) = ($1, $2);
- }
- elsif (/^\s+(.*)/) {
- $val .= " $1";
- }
- else {
- last HEADER;
- }
- }
- $r->push_header($key, $val) if $key;
- }
-
- my $conn = $r->header('Connection');
- if ($proto >= $HTTP_1_1) {
- ${*$self}{'httpd_nomore'}++ if $conn && lc($conn) =~ /\bclose\b/;
- }
- else {
- ${*$self}{'httpd_nomore'}++ unless $conn &&
- lc($conn) =~ /\bkeep-alive\b/;
- }
-
- if ($only_headers) {
- ${*$self}{'httpd_rbuf'} = $buf;
- return $r;
- }
-
- # Find out how much content to read
- my $te = $r->header('Transfer-Encoding');
- my $ct = $r->header('Content-Type');
- my $len = $r->header('Content-Length');
-
- # Act on the Expect header, if it's there
- for my $e ( $r->header('Expect') ) {
- if( lc($e) eq '100-continue' ) {
- $self->send_status_line(100);
- $self->send_crlf;
- }
- else {
- $self->send_error(417);
- $self->reason("Unsupported Expect header value");
- return;
- }
- }
-
- if ($te && lc($te) eq 'chunked') {
- # Handle chunked transfer encoding
- my $body = "";
- CHUNK:
- while (1) {
- print STDERR "Chunked\n" if $DEBUG;
- if ($buf =~ s/^([^\012]*)\012//) {
- my $chunk_head = $1;
- unless ($chunk_head =~ /^([0-9A-Fa-f]+)/) {
- $self->send_error(400);
- $self->reason("Bad chunk header $chunk_head");
- return;
- }
- my $size = hex($1);
- last CHUNK if $size == 0;
-
- my $missing = $size - length($buf) + 2; # 2=CRLF at chunk end
- # must read until we have a complete chunk
- while ($missing > 0) {
- print STDERR "Need $missing more bytes\n" if $DEBUG;
- my $n = $self->_need_more($buf, $timeout, $fdset);
- return unless $n;
- $missing -= $n;
- }
- $body .= substr($buf, 0, $size);
- substr($buf, 0, $size+2) = '';
-
- }
- else {
- # need more data in order to have a complete chunk header
- return unless $self->_need_more($buf, $timeout, $fdset);
- }
- }
- $r->content($body);
-
- # pretend it was a normal entity body
- $r->remove_header('Transfer-Encoding');
- $r->header('Content-Length', length($body));
-
- my($key, $val);
- FOOTER:
- while (1) {
- if ($buf !~ /\012/) {
- # need at least one line to look at
- return unless $self->_need_more($buf, $timeout, $fdset);
- }
- else {
- $buf =~ s/^([^\012]*)\012//;
- $_ = $1;
- s/\015$//;
- if (/^([\w\-]+)\s*:\s*(.*)/) {
- $r->push_header($key, $val) if $key;
- ($key, $val) = ($1, $2);
- }
- elsif (/^\s+(.*)/) {
- $val .= " $1";
- }
- elsif (!length) {
- last FOOTER;
- }
- else {
- $self->reason("Bad footer syntax");
- return;
- }
- }
- }
- $r->push_header($key, $val) if $key;
-
- }
- elsif ($te) {
- $self->send_error(501); # Unknown transfer encoding
- $self->reason("Unknown transfer encoding '$te'");
- return;
-
- }
- elsif ($len) {
- # Plain body specified by "Content-Length"
- my $missing = $len - length($buf);
- while ($missing > 0) {
- print "Need $missing more bytes of content\n" if $DEBUG;
- my $n = $self->_need_more($buf, $timeout, $fdset);
- return unless $n;
- $missing -= $n;
- }
- if (length($buf) > $len) {
- $r->content(substr($buf,0,$len));
- substr($buf, 0, $len) = '';
- }
- else {
- $r->content($buf);
- $buf='';
- }
- }
- elsif ($ct && $ct =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*("?)(\w+)\1/i) {
- # Handle multipart content type
- my $boundary = "$CRLF--$2--";
- my $index;
- while (1) {
- $index = index($buf, $boundary);
- last if $index >= 0;
- # end marker not yet found
- return unless $self->_need_more($buf, $timeout, $fdset);
- }
- $index += length($boundary);
- $r->content(substr($buf, 0, $index));
- substr($buf, 0, $index) = '';
-
- }
- ${*$self}{'httpd_rbuf'} = $buf;
-
- $r;
-}
-
-
-sub _need_more
-{
- my $self = shift;
- #my($buf,$timeout,$fdset) = @_;
- if ($_[1]) {
- my($timeout, $fdset) = @_[1,2];
- print STDERR "select(,,,$timeout)\n" if $DEBUG;
- my $n = select($fdset,undef,undef,$timeout);
- unless ($n) {
- $self->reason(defined($n) ? "Timeout" : "select: $!");
- return;
- }
- }
- print STDERR "sysread()\n" if $DEBUG;
- my $n = sysread($self, $_[0], 2048, length($_[0]));
- $self->reason(defined($n) ? "Client closed" : "sysread: $!") unless $n;
- $n;
-}
-
-
-sub read_buffer
-{
- my $self = shift;
- my $old = ${*$self}{'httpd_rbuf'};
- if (@_) {
- ${*$self}{'httpd_rbuf'} = shift;
- }
- $old;
-}
-
-
-sub reason
-{
- my $self = shift;
- my $old = ${*$self}{'httpd_reason'};
- if (@_) {
- ${*$self}{'httpd_reason'} = shift;
- }
- $old;
-}
-
-
-sub proto_ge
-{
- my $self = shift;
- ${*$self}{'httpd_client_proto'} >= _http_version(shift);
-}
-
-
-sub _http_version
-{
- local($_) = shift;
- return 0 unless m,^(?:HTTP/)?(\d+)\.(\d+)$,i;
- $1 * 1000 + $2;
-}
-
-
-sub antique_client
-{
- my $self = shift;
- ${*$self}{'httpd_client_proto'} < $HTTP_1_0;
-}
-
-
-sub force_last_request
-{
- my $self = shift;
- ${*$self}{'httpd_nomore'}++;
-}
-
-sub head_request
-{
- my $self = shift;
- ${*$self}{'httpd_head'};
-}
-
-
-sub send_status_line
-{
- my($self, $status, $message, $proto) = @_;
- return if $self->antique_client;
- $status ||= RC_OK;
- $message ||= status_message($status) || "";
- $proto ||= $HTTP::Daemon::PROTO || "HTTP/1.1";
- print $self "$proto $status $message$CRLF";
-}
-
-
-sub send_crlf
-{
- my $self = shift;
- print $self $CRLF;
-}
-
-
-sub send_basic_header
-{
- my $self = shift;
- return if $self->antique_client;
- $self->send_status_line(@_);
- print $self "Date: ", time2str(time), $CRLF;
- my $product = $self->daemon->product_tokens;
- print $self "Server: $product$CRLF" if $product;
-}
-
-
-sub send_header
-{
- my $self = shift;
- while (@_) {
- my($k, $v) = splice(@_, 0, 2);
- $v = "" unless defined($v);
- print $self "$k: $v$CRLF";
- }
-}
-
-
-sub send_response
-{
- my $self = shift;
- my $res = shift;
- if (!ref $res) {
- $res ||= RC_OK;
- $res = HTTP::Response->new($res, @_);
- }
- my $content = $res->content;
- my $chunked;
- unless ($self->antique_client) {
- my $code = $res->code;
- $self->send_basic_header($code, $res->message, $res->protocol);
- if ($code =~ /^(1\d\d|[23]04)$/) {
- # make sure content is empty
- $res->remove_header("Content-Length");
- $content = "";
- }
- elsif ($res->request && $res->request->method eq "HEAD") {
- # probably OK
- }
- elsif (ref($content) eq "CODE") {
- if ($self->proto_ge("HTTP/1.1")) {
- $res->push_header("Transfer-Encoding" => "chunked");
- $chunked++;
- }
- else {
- $self->force_last_request;
- }
- }
- elsif (length($content)) {
- $res->header("Content-Length" => length($content));
- }
- else {
- $self->force_last_request;
- $res->header('connection','close');
- }
- print $self $res->headers_as_string($CRLF);
- print $self $CRLF; # separates headers and content
- }
- if ($self->head_request) {
- # no content
- }
- elsif (ref($content) eq "CODE") {
- while (1) {
- my $chunk = &$content();
- last unless defined($chunk) && length($chunk);
- if ($chunked) {
- printf $self "%x%s%s%s", length($chunk), $CRLF, $chunk, $CRLF;
- }
- else {
- print $self $chunk;
- }
- }
- print $self "0$CRLF$CRLF" if $chunked; # no trailers either
- }
- elsif (length $content) {
- print $self $content;
- }
-}
-
-
-sub send_redirect
-{
- my($self, $loc, $status, $content) = @_;
- $status ||= RC_MOVED_PERMANENTLY;
- Carp::croak("Status '$status' is not redirect") unless is_redirect($status);
- $self->send_basic_header($status);
- my $base = $self->daemon->url;
- $loc = $HTTP::URI_CLASS->new($loc, $base) unless ref($loc);
- $loc = $loc->abs($base);
- print $self "Location: $loc$CRLF";
- if ($content) {
- my $ct = $content =~ /^\s*</ ? "text/html" : "text/plain";
- print $self "Content-Type: $ct$CRLF";
- }
- print $self $CRLF;
- print $self $content if $content && !$self->head_request;
- $self->force_last_request; # no use keeping the connection open
-}
-
-
-sub send_error
-{
- my($self, $status, $error) = @_;
- $status ||= RC_BAD_REQUEST;
- Carp::croak("Status '$status' is not an error") unless is_error($status);
- my $mess = status_message($status);
- $error ||= "";
- $mess = <<EOT;
-<title>$status $mess</title>
-<h1>$status $mess</h1>
-$error
-EOT
- unless ($self->antique_client) {
- $self->send_basic_header($status);
- print $self "Content-Type: text/html$CRLF";
- print $self "Content-Length: " . length($mess) . $CRLF;
- print $self $CRLF;
- }
- print $self $mess unless $self->head_request;
- $status;
-}
-
-
-sub send_file_response
-{
- my($self, $file) = @_;
- if (-d $file) {
- $self->send_dir($file);
- }
- elsif (-f _) {
- # plain file
- local(*F);
- sysopen(F, $file, 0) or
- return $self->send_error(RC_FORBIDDEN);
- binmode(F);
- my($ct,$ce) = guess_media_type($file);
- my($size,$mtime) = (stat _)[7,9];
- unless ($self->antique_client) {
- $self->send_basic_header;
- print $self "Content-Type: $ct$CRLF";
- print $self "Content-Encoding: $ce$CRLF" if $ce;
- print $self "Content-Length: $size$CRLF" if $size;
- print $self "Last-Modified: ", time2str($mtime), "$CRLF" if $mtime;
- print $self $CRLF;
- }
- $self->send_file(\*F) unless $self->head_request;
- return RC_OK;
- }
- else {
- $self->send_error(RC_NOT_FOUND);
- }
-}
-
-
-sub send_dir
-{
- my($self, $dir) = @_;
- $self->send_error(RC_NOT_FOUND) unless -d $dir;
- $self->send_error(RC_NOT_IMPLEMENTED);
-}
-
-
-sub send_file
-{
- my($self, $file) = @_;
- my $opened = 0;
- local(*FILE);
- if (!ref($file)) {
- open(FILE, $file) || return undef;
- binmode(FILE);
- $file = \*FILE;
- $opened++;
- }
- my $cnt = 0;
- my $buf = "";
- my $n;
- while ($n = sysread($file, $buf, 8*1024)) {
- last if !$n;
- $cnt += $n;
- print $self $buf;
- }
- close($file) if $opened;
- $cnt;
-}
-
-
-sub daemon
-{
- my $self = shift;
- ${*$self}{'httpd_daemon'};
-}
-
-
-1;
-
-__END__
-
-=head1 NAME
-
-HTTP::Daemon - a simple http server class
-
-=head1 SYNOPSIS
-
- use HTTP::Daemon;
- use HTTP::Status;
-
- my $d = HTTP::Daemon->new || die;
- print "Please contact me at: <URL:", $d->url, ">\n";
- while (my $c = $d->accept) {
- while (my $r = $c->get_request) {
- if ($r->method eq 'GET' and $r->uri->path eq "/xyzzy") {
- # remember, this is *not* recommended practice :-)
- $c->send_file_response("/etc/passwd");
- }
- else {
- $c->send_error(RC_FORBIDDEN)
- }
- }
- $c->close;
- undef($c);
- }
-
-=head1 DESCRIPTION
-
-Instances of the C<HTTP::Daemon> class are HTTP/1.1 servers that
-listen on a socket for incoming requests. The C<HTTP::Daemon> is a
-subclass of C<IO::Socket::INET>, so you can perform socket operations
-directly on it too.
-
-The accept() method will return when a connection from a client is
-available. The returned value will be an C<HTTP::Daemon::ClientConn>
-object which is another C<IO::Socket::INET> subclass. Calling the
-get_request() method on this object will read data from the client and
-return an C<HTTP::Request> object. The ClientConn object also provide
-methods to send back various responses.
-
-This HTTP daemon does not fork(2) for you. Your application, i.e. the
-user of the C<HTTP::Daemon> is responsible for forking if that is
-desirable. Also note that the user is responsible for generating
-responses that conform to the HTTP/1.1 protocol.
-
-The following methods of C<HTTP::Daemon> are new (or enhanced) relative
-to the C<IO::Socket::INET> base class:
-
-=over 4
-
-=item $d = HTTP::Daemon->new
-
-=item $d = HTTP::Daemon->new( %opts )
-
-The constructor method takes the same arguments as the
-C<IO::Socket::INET> constructor, but unlike its base class it can also
-be called without any arguments. The daemon will then set up a listen
-queue of 5 connections and allocate some random port number.
-
-A server that wants to bind to some specific address on the standard
-HTTP port will be constructed like this:
-
- $d = HTTP::Daemon->new(
- LocalAddr => 'www.thisplace.com',
- LocalPort => 80,
- );
-
-See L<IO::Socket::INET> for a description of other arguments that can
-be used configure the daemon during construction.
-
-=item $c = $d->accept
-
-=item $c = $d->accept( $pkg )
-
-=item ($c, $peer_addr) = $d->accept
-
-This method works the same the one provided by the base class, but it
-returns an C<HTTP::Daemon::ClientConn> reference by default. If a
-package name is provided as argument, then the returned object will be
-blessed into the given class. It is probably a good idea to make that
-class a subclass of C<HTTP::Daemon::ClientConn>.
-
-The accept method will return C<undef> if timeouts have been enabled
-and no connection is made within the given time. The timeout() method
-is described in L<IO::Socket>.
-
-In list context both the client object and the peer address will be
-returned; see the description of the accept method L<IO::Socket> for
-details.
-
-=item $d->url
-
-Returns a URL string that can be used to access the server root.
-
-=item $d->product_tokens
-
-Returns the name that this server will use to identify itself. This
-is the string that is sent with the C<Server> response header. The
-main reason to have this method is that subclasses can override it if
-they want to use another product name.
-
-The default is the string "libwww-perl-daemon/#.##" where "#.##" is
-replaced with the version number of this module.
-
-=back
-
-The C<HTTP::Daemon::ClientConn> is a C<IO::Socket::INET>
-subclass. Instances of this class are returned by the accept() method
-of C<HTTP::Daemon>. The following methods are provided:
-
-=over 4
-
-=item $c->get_request
-
-=item $c->get_request( $headers_only )
-
-This method reads data from the client and turns it into an
-C<HTTP::Request> object which is returned. It returns C<undef>
-if reading fails. If it fails, then the C<HTTP::Daemon::ClientConn>
-object ($c) should be discarded, and you should not try call this
-method again on it. The $c->reason method might give you some
-information about why $c->get_request failed.
-
-The get_request() method will normally not return until the whole
-request has been received from the client. This might not be what you
-want if the request is an upload of a large file (and with chunked
-transfer encoding HTTP can even support infinite request messages -
-uploading live audio for instance). If you pass a TRUE value as the
-$headers_only argument, then get_request() will return immediately
-after parsing the request headers and you are responsible for reading
-the rest of the request content. If you are going to call
-$c->get_request again on the same connection you better read the
-correct number of bytes.
-
-=item $c->read_buffer
-
-=item $c->read_buffer( $new_value )
-
-Bytes read by $c->get_request, but not used are placed in the I<read
-buffer>. The next time $c->get_request is called it will consume the
-bytes in this buffer before reading more data from the network
-connection itself. The read buffer is invalid after $c->get_request
-has failed.
-
-If you handle the reading of the request content yourself you need to
-empty this buffer before you read more and you need to place
-unconsumed bytes here. You also need this buffer if you implement
-services like I<101 Switching Protocols>.
-
-This method always returns the old buffer content and can optionally
-replace the buffer content if you pass it an argument.
-
-=item $c->reason
-
-When $c->get_request returns C<undef> you can obtain a short string
-describing why it happened by calling $c->reason.
-
-=item $c->proto_ge( $proto )
-
-Return TRUE if the client announced a protocol with version number
-greater or equal to the given argument. The $proto argument can be a
-string like "HTTP/1.1" or just "1.1".
-
-=item $c->antique_client
-
-Return TRUE if the client speaks the HTTP/0.9 protocol. No status
-code and no headers should be returned to such a client. This should
-be the same as !$c->proto_ge("HTTP/1.0").
-
-=item $c->head_request
-
-Return TRUE if the last request was a C<HEAD> request. No content
-body must be generated for these requests.
-
-=item $c->force_last_request
-
-Make sure that $c->get_request will not try to read more requests off
-this connection. If you generate a response that is not self
-delimiting, then you should signal this fact by calling this method.
-
-This attribute is turned on automatically if the client announces
-protocol HTTP/1.0 or worse and does not include a "Connection:
-Keep-Alive" header. It is also turned on automatically when HTTP/1.1
-or better clients send the "Connection: close" request header.
-
-=item $c->send_status_line
-
-=item $c->send_status_line( $code )
-
-=item $c->send_status_line( $code, $mess )
-
-=item $c->send_status_line( $code, $mess, $proto )
-
-Send the status line back to the client. If $code is omitted 200 is
-assumed. If $mess is omitted, then a message corresponding to $code
-is inserted. If $proto is missing the content of the
-$HTTP::Daemon::PROTO variable is used.
-
-=item $c->send_crlf
-
-Send the CRLF sequence to the client.
-
-=item $c->send_basic_header
-
-=item $c->send_basic_header( $code )
-
-=item $c->send_basic_header( $code, $mess )
-
-=item $c->send_basic_header( $code, $mess, $proto )
-
-Send the status line and the "Date:" and "Server:" headers back to
-the client. This header is assumed to be continued and does not end
-with an empty CRLF line.
-
-See the description of send_status_line() for the description of the
-accepted arguments.
-
-=item $c->send_header( $field, $value )
-
-=item $c->send_header( $field1, $value1, $field2, $value2, ... )
-
-Send one or more header lines.
-
-=item $c->send_response( $res )
-
-Write a C<HTTP::Response> object to the
-client as a response. We try hard to make sure that the response is
-self delimiting so that the connection can stay persistent for further
-request/response exchanges.
-
-The content attribute of the C<HTTP::Response> object can be a normal
-string or a subroutine reference. If it is a subroutine, then
-whatever this callback routine returns is written back to the
-client as the response content. The routine will be called until it
-return an undefined or empty value. If the client is HTTP/1.1 aware
-then we will use chunked transfer encoding for the response.
-
-=item $c->send_redirect( $loc )
-
-=item $c->send_redirect( $loc, $code )
-
-=item $c->send_redirect( $loc, $code, $entity_body )
-
-Send a redirect response back to the client. The location ($loc) can
-be an absolute or relative URL. The $code must be one the redirect
-status codes, and defaults to "301 Moved Permanently"
-
-=item $c->send_error
-
-=item $c->send_error( $code )
-
-=item $c->send_error( $code, $error_message )
-
-Send an error response back to the client. If the $code is missing a
-"Bad Request" error is reported. The $error_message is a string that
-is incorporated in the body of the HTML entity body.
-
-=item $c->send_file_response( $filename )
-
-Send back a response with the specified $filename as content. If the
-file is a directory we try to generate an HTML index of it.
-
-=item $c->send_file( $filename )
-
-=item $c->send_file( $fd )
-
-Copy the file to the client. The file can be a string (which
-will be interpreted as a filename) or a reference to an C<IO::Handle>
-or glob.
-
-=item $c->daemon
-
-Return a reference to the corresponding C<HTTP::Daemon> object.
-
-=back
-
-=head1 SEE ALSO
-
-RFC 2616
-
-L<IO::Socket::INET>, L<IO::Socket>
-
-=head1 COPYRIGHT
-
-Copyright 1996-2003, Gisle Aas
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
+++ /dev/null
-package HTTP::Date;
-
-$VERSION = "5.831";
-
-require 5.004;
-require Exporter;
-@ISA = qw(Exporter);
-@EXPORT = qw(time2str str2time);
-@EXPORT_OK = qw(parse_date time2iso time2isoz);
-
-use strict;
-require Time::Local;
-
-use vars qw(@DoW @MoY %MoY);
-@DoW = qw(Sun Mon Tue Wed Thu Fri Sat);
-@MoY = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
-@MoY{@MoY} = (1..12);
-
-my %GMT_ZONE = (GMT => 1, UTC => 1, UT => 1, Z => 1);
-
-
-sub time2str (;$)
-{
- my $time = shift;
- $time = time unless defined $time;
- my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($time);
- sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
- $DoW[$wday],
- $mday, $MoY[$mon], $year+1900,
- $hour, $min, $sec);
-}
-
-
-sub str2time ($;$)
-{
- my $str = shift;
- return undef unless defined $str;
-
- # fast exit for strictly conforming string
- if ($str =~ /^[SMTWF][a-z][a-z], (\d\d) ([JFMAJSOND][a-z][a-z]) (\d\d\d\d) (\d\d):(\d\d):(\d\d) GMT$/) {
- return eval {
- my $t = Time::Local::timegm($6, $5, $4, $1, $MoY{$2}-1, $3);
- $t < 0 ? undef : $t;
- };
- }
-
- my @d = parse_date($str);
- return undef unless @d;
- $d[1]--; # month
-
- my $tz = pop(@d);
- unless (defined $tz) {
- unless (defined($tz = shift)) {
- return eval { my $frac = $d[-1]; $frac -= ($d[-1] = int($frac));
- my $t = Time::Local::timelocal(reverse @d) + $frac;
- $t < 0 ? undef : $t;
- };
- }
- }
-
- my $offset = 0;
- if ($GMT_ZONE{uc $tz}) {
- # offset already zero
- }
- elsif ($tz =~ /^([-+])?(\d\d?):?(\d\d)?$/) {
- $offset = 3600 * $2;
- $offset += 60 * $3 if $3;
- $offset *= -1 if $1 && $1 eq '-';
- }
- else {
- eval { require Time::Zone } || return undef;
- $offset = Time::Zone::tz_offset($tz);
- return undef unless defined $offset;
- }
-
- return eval { my $frac = $d[-1]; $frac -= ($d[-1] = int($frac));
- my $t = Time::Local::timegm(reverse @d) + $frac;
- $t < 0 ? undef : $t - $offset;
- };
-}
-
-
-sub parse_date ($)
-{
- local($_) = shift;
- return unless defined;
-
- # More lax parsing below
- s/^\s+//; # kill leading space
- s/^(?:Sun|Mon|Tue|Wed|Thu|Fri|Sat)[a-z]*,?\s*//i; # Useless weekday
-
- my($day, $mon, $yr, $hr, $min, $sec, $tz, $ampm);
-
- # Then we are able to check for most of the formats with this regexp
- (($day,$mon,$yr,$hr,$min,$sec,$tz) =
- /^
- (\d\d?) # day
- (?:\s+|[-\/])
- (\w+) # month
- (?:\s+|[-\/])
- (\d+) # year
- (?:
- (?:\s+|:) # separator before clock
- (\d\d?):(\d\d) # hour:min
- (?::(\d\d))? # optional seconds
- )? # optional clock
- \s*
- ([-+]?\d{2,4}|(?![APap][Mm]\b)[A-Za-z]+)? # timezone
- \s*
- (?:\(\w+\))? # ASCII representation of timezone in parens.
- \s*$
- /x)
-
- ||
-
- # Try the ctime and asctime format
- (($mon, $day, $hr, $min, $sec, $tz, $yr) =
- /^
- (\w{1,3}) # month
- \s+
- (\d\d?) # day
- \s+
- (\d\d?):(\d\d) # hour:min
- (?::(\d\d))? # optional seconds
- \s+
- (?:([A-Za-z]+)\s+)? # optional timezone
- (\d+) # year
- \s*$ # allow trailing whitespace
- /x)
-
- ||
-
- # Then the Unix 'ls -l' date format
- (($mon, $day, $yr, $hr, $min, $sec) =
- /^
- (\w{3}) # month
- \s+
- (\d\d?) # day
- \s+
- (?:
- (\d\d\d\d) | # year
- (\d{1,2}):(\d{2}) # hour:min
- (?::(\d\d))? # optional seconds
- )
- \s*$
- /x)
-
- ||
-
- # ISO 8601 format '1996-02-29 12:00:00 -0100' and variants
- (($yr, $mon, $day, $hr, $min, $sec, $tz) =
- /^
- (\d{4}) # year
- [-\/]?
- (\d\d?) # numerical month
- [-\/]?
- (\d\d?) # day
- (?:
- (?:\s+|[-:Tt]) # separator before clock
- (\d\d?):?(\d\d) # hour:min
- (?::?(\d\d(?:\.\d*)?))? # optional seconds (and fractional)
- )? # optional clock
- \s*
- ([-+]?\d\d?:?(:?\d\d)?
- |Z|z)? # timezone (Z is "zero meridian", i.e. GMT)
- \s*$
- /x)
-
- ||
-
- # Windows 'dir' 11-12-96 03:52PM
- (($mon, $day, $yr, $hr, $min, $ampm) =
- /^
- (\d{2}) # numerical month
- -
- (\d{2}) # day
- -
- (\d{2}) # year
- \s+
- (\d\d?):(\d\d)([APap][Mm]) # hour:min AM or PM
- \s*$
- /x)
-
- ||
- return; # unrecognized format
-
- # Translate month name to number
- $mon = $MoY{$mon} ||
- $MoY{"\u\L$mon"} ||
- ($mon =~ /^\d\d?$/ && $mon >= 1 && $mon <= 12 && int($mon)) ||
- return;
-
- # If the year is missing, we assume first date before the current,
- # because of the formats we support such dates are mostly present
- # on "ls -l" listings.
- unless (defined $yr) {
- my $cur_mon;
- ($cur_mon, $yr) = (localtime)[4, 5];
- $yr += 1900;
- $cur_mon++;
- $yr-- if $mon > $cur_mon;
- }
- elsif (length($yr) < 3) {
- # Find "obvious" year
- my $cur_yr = (localtime)[5] + 1900;
- my $m = $cur_yr % 100;
- my $tmp = $yr;
- $yr += $cur_yr - $m;
- $m -= $tmp;
- $yr += ($m > 0) ? 100 : -100
- if abs($m) > 50;
- }
-
- # Make sure clock elements are defined
- $hr = 0 unless defined($hr);
- $min = 0 unless defined($min);
- $sec = 0 unless defined($sec);
-
- # Compensate for AM/PM
- if ($ampm) {
- $ampm = uc $ampm;
- $hr = 0 if $hr == 12 && $ampm eq 'AM';
- $hr += 12 if $ampm eq 'PM' && $hr != 12;
- }
-
- return($yr, $mon, $day, $hr, $min, $sec, $tz)
- if wantarray;
-
- if (defined $tz) {
- $tz = "Z" if $tz =~ /^(GMT|UTC?|[-+]?0+)$/;
- }
- else {
- $tz = "";
- }
- return sprintf("%04d-%02d-%02d %02d:%02d:%02d%s",
- $yr, $mon, $day, $hr, $min, $sec, $tz);
-}
-
-
-sub time2iso (;$)
-{
- my $time = shift;
- $time = time unless defined $time;
- my($sec,$min,$hour,$mday,$mon,$year) = localtime($time);
- sprintf("%04d-%02d-%02d %02d:%02d:%02d",
- $year+1900, $mon+1, $mday, $hour, $min, $sec);
-}
-
-
-sub time2isoz (;$)
-{
- my $time = shift;
- $time = time unless defined $time;
- my($sec,$min,$hour,$mday,$mon,$year) = gmtime($time);
- sprintf("%04d-%02d-%02d %02d:%02d:%02dZ",
- $year+1900, $mon+1, $mday, $hour, $min, $sec);
-}
-
-1;
-
-
-__END__
-
-=head1 NAME
-
-HTTP::Date - date conversion routines
-
-=head1 SYNOPSIS
-
- use HTTP::Date;
-
- $string = time2str($time); # Format as GMT ASCII time
- $time = str2time($string); # convert ASCII date to machine time
-
-=head1 DESCRIPTION
-
-This module provides functions that deal the date formats used by the
-HTTP protocol (and then some more). Only the first two functions,
-time2str() and str2time(), are exported by default.
-
-=over 4
-
-=item time2str( [$time] )
-
-The time2str() function converts a machine time (seconds since epoch)
-to a string. If the function is called without an argument or with an
-undefined argument, it will use the current time.
-
-The string returned is in the format preferred for the HTTP protocol.
-This is a fixed length subset of the format defined by RFC 1123,
-represented in Universal Time (GMT). An example of a time stamp
-in this format is:
-
- Sun, 06 Nov 1994 08:49:37 GMT
-
-=item str2time( $str [, $zone] )
-
-The str2time() function converts a string to machine time. It returns
-C<undef> if the format of $str is unrecognized, otherwise whatever the
-C<Time::Local> functions can make out of the parsed time. Dates
-before the system's epoch may not work on all operating systems. The
-time formats recognized are the same as for parse_date().
-
-The function also takes an optional second argument that specifies the
-default time zone to use when converting the date. This parameter is
-ignored if the zone is found in the date string itself. If this
-parameter is missing, and the date string format does not contain any
-zone specification, then the local time zone is assumed.
-
-If the zone is not "C<GMT>" or numerical (like "C<-0800>" or
-"C<+0100>"), then the C<Time::Zone> module must be installed in order
-to get the date recognized.
-
-=item parse_date( $str )
-
-This function will try to parse a date string, and then return it as a
-list of numerical values followed by a (possible undefined) time zone
-specifier; ($year, $month, $day, $hour, $min, $sec, $tz). The $year
-returned will B<not> have the number 1900 subtracted from it and the
-$month numbers start with 1.
-
-In scalar context the numbers are interpolated in a string of the
-"YYYY-MM-DD hh:mm:ss TZ"-format and returned.
-
-If the date is unrecognized, then the empty list is returned.
-
-The function is able to parse the following formats:
-
- "Wed, 09 Feb 1994 22:23:32 GMT" -- HTTP format
- "Thu Feb 3 17:03:55 GMT 1994" -- ctime(3) format
- "Thu Feb 3 00:00:00 1994", -- ANSI C asctime() format
- "Tuesday, 08-Feb-94 14:15:29 GMT" -- old rfc850 HTTP format
- "Tuesday, 08-Feb-1994 14:15:29 GMT" -- broken rfc850 HTTP format
-
- "03/Feb/1994:17:03:55 -0700" -- common logfile format
- "09 Feb 1994 22:23:32 GMT" -- HTTP format (no weekday)
- "08-Feb-94 14:15:29 GMT" -- rfc850 format (no weekday)
- "08-Feb-1994 14:15:29 GMT" -- broken rfc850 format (no weekday)
-
- "1994-02-03 14:15:29 -0100" -- ISO 8601 format
- "1994-02-03 14:15:29" -- zone is optional
- "1994-02-03" -- only date
- "1994-02-03T14:15:29" -- Use T as separator
- "19940203T141529Z" -- ISO 8601 compact format
- "19940203" -- only date
-
- "08-Feb-94" -- old rfc850 HTTP format (no weekday, no time)
- "08-Feb-1994" -- broken rfc850 HTTP format (no weekday, no time)
- "09 Feb 1994" -- proposed new HTTP format (no weekday, no time)
- "03/Feb/1994" -- common logfile format (no time, no offset)
-
- "Feb 3 1994" -- Unix 'ls -l' format
- "Feb 3 17:03" -- Unix 'ls -l' format
-
- "11-15-96 03:52PM" -- Windows 'dir' format
-
-The parser ignores leading and trailing whitespace. It also allow the
-seconds to be missing and the month to be numerical in most formats.
-
-If the year is missing, then we assume that the date is the first
-matching date I<before> current month. If the year is given with only
-2 digits, then parse_date() will select the century that makes the
-year closest to the current date.
-
-=item time2iso( [$time] )
-
-Same as time2str(), but returns a "YYYY-MM-DD hh:mm:ss"-formatted
-string representing time in the local time zone.
-
-=item time2isoz( [$time] )
-
-Same as time2str(), but returns a "YYYY-MM-DD hh:mm:ssZ"-formatted
-string representing Universal Time.
-
-
-=back
-
-=head1 SEE ALSO
-
-L<perlfunc/time>, L<Time::Zone>
-
-=head1 COPYRIGHT
-
-Copyright 1995-1999, Gisle Aas
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=cut
+++ /dev/null
-package HTTP::Headers;
-
-use strict;
-use Carp ();
-
-use vars qw($VERSION $TRANSLATE_UNDERSCORE);
-$VERSION = "5.835";
-
-# The $TRANSLATE_UNDERSCORE variable controls whether '_' can be used
-# as a replacement for '-' in header field names.
-$TRANSLATE_UNDERSCORE = 1 unless defined $TRANSLATE_UNDERSCORE;
-
-# "Good Practice" order of HTTP message headers:
-# - General-Headers
-# - Request-Headers
-# - Response-Headers
-# - Entity-Headers
-
-my @general_headers = qw(
- Cache-Control Connection Date Pragma Trailer Transfer-Encoding Upgrade
- Via Warning
-);
-
-my @request_headers = qw(
- Accept Accept-Charset Accept-Encoding Accept-Language
- Authorization Expect From Host
- If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since
- Max-Forwards Proxy-Authorization Range Referer TE User-Agent
-);
-
-my @response_headers = qw(
- Accept-Ranges Age ETag Location Proxy-Authenticate Retry-After Server
- Vary WWW-Authenticate
-);
-
-my @entity_headers = qw(
- Allow Content-Encoding Content-Language Content-Length Content-Location
- Content-MD5 Content-Range Content-Type Expires Last-Modified
-);
-
-my %entity_header = map { lc($_) => 1 } @entity_headers;
-
-my @header_order = (
- @general_headers,
- @request_headers,
- @response_headers,
- @entity_headers,
-);
-
-# Make alternative representations of @header_order. This is used
-# for sorting and case matching.
-my %header_order;
-my %standard_case;
-
-{
- my $i = 0;
- for (@header_order) {
- my $lc = lc $_;
- $header_order{$lc} = ++$i;
- $standard_case{$lc} = $_;
- }
-}
-
-
-
-sub new
-{
- my($class) = shift;
- my $self = bless {}, $class;
- $self->header(@_) if @_; # set up initial headers
- $self;
-}
-
-
-sub header
-{
- my $self = shift;
- Carp::croak('Usage: $h->header($field, ...)') unless @_;
- my(@old);
- my %seen;
- while (@_) {
- my $field = shift;
- my $op = @_ ? ($seen{lc($field)}++ ? 'PUSH' : 'SET') : 'GET';
- @old = $self->_header($field, shift, $op);
- }
- return @old if wantarray;
- return $old[0] if @old <= 1;
- join(", ", @old);
-}
-
-sub clear
-{
- my $self = shift;
- %$self = ();
-}
-
-
-sub push_header
-{
- my $self = shift;
- return $self->_header(@_, 'PUSH_H') if @_ == 2;
- while (@_) {
- $self->_header(splice(@_, 0, 2), 'PUSH_H');
- }
-}
-
-
-sub init_header
-{
- Carp::croak('Usage: $h->init_header($field, $val)') if @_ != 3;
- shift->_header(@_, 'INIT');
-}
-
-
-sub remove_header
-{
- my($self, @fields) = @_;
- my $field;
- my @values;
- foreach $field (@fields) {
- $field =~ tr/_/-/ if $field !~ /^:/ && $TRANSLATE_UNDERSCORE;
- my $v = delete $self->{lc $field};
- push(@values, ref($v) eq 'ARRAY' ? @$v : $v) if defined $v;
- }
- return @values;
-}
-
-sub remove_content_headers
-{
- my $self = shift;
- unless (defined(wantarray)) {
- # fast branch that does not create return object
- delete @$self{grep $entity_header{$_} || /^content-/, keys %$self};
- return;
- }
-
- my $c = ref($self)->new;
- for my $f (grep $entity_header{$_} || /^content-/, keys %$self) {
- $c->{$f} = delete $self->{$f};
- }
- $c;
-}
-
-
-sub _header
-{
- my($self, $field, $val, $op) = @_;
-
- unless ($field =~ /^:/) {
- $field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE;
- my $old = $field;
- $field = lc $field;
- unless(defined $standard_case{$field}) {
- # generate a %standard_case entry for this field
- $old =~ s/\b(\w)/\u$1/g;
- $standard_case{$field} = $old;
- }
- }
-
- $op ||= defined($val) ? 'SET' : 'GET';
- if ($op eq 'PUSH_H') {
- # Like PUSH but where we don't care about the return value
- if (exists $self->{$field}) {
- my $h = $self->{$field};
- if (ref($h) eq 'ARRAY') {
- push(@$h, ref($val) eq "ARRAY" ? @$val : $val);
- }
- else {
- $self->{$field} = [$h, ref($val) eq "ARRAY" ? @$val : $val]
- }
- return;
- }
- $self->{$field} = $val;
- return;
- }
-
- my $h = $self->{$field};
- my @old = ref($h) eq 'ARRAY' ? @$h : (defined($h) ? ($h) : ());
-
- unless ($op eq 'GET' || ($op eq 'INIT' && @old)) {
- if (defined($val)) {
- my @new = ($op eq 'PUSH') ? @old : ();
- if (ref($val) ne 'ARRAY') {
- push(@new, $val);
- }
- else {
- push(@new, @$val);
- }
- $self->{$field} = @new > 1 ? \@new : $new[0];
- }
- elsif ($op ne 'PUSH') {
- delete $self->{$field};
- }
- }
- @old;
-}
-
-
-sub _sorted_field_names
-{
- my $self = shift;
- return [ sort {
- ($header_order{$a} || 999) <=> ($header_order{$b} || 999) ||
- $a cmp $b
- } keys %$self ];
-}
-
-
-sub header_field_names {
- my $self = shift;
- return map $standard_case{$_} || $_, @{ $self->_sorted_field_names },
- if wantarray;
- return keys %$self;
-}
-
-
-sub scan
-{
- my($self, $sub) = @_;
- my $key;
- for $key (@{ $self->_sorted_field_names }) {
- next if substr($key, 0, 1) eq '_';
- my $vals = $self->{$key};
- if (ref($vals) eq 'ARRAY') {
- my $val;
- for $val (@$vals) {
- $sub->($standard_case{$key} || $key, $val);
- }
- }
- else {
- $sub->($standard_case{$key} || $key, $vals);
- }
- }
-}
-
-
-sub as_string
-{
- my($self, $endl) = @_;
- $endl = "\n" unless defined $endl;
-
- my @result = ();
- for my $key (@{ $self->_sorted_field_names }) {
- next if index($key, '_') == 0;
- my $vals = $self->{$key};
- if ( ref($vals) eq 'ARRAY' ) {
- for my $val (@$vals) {
- my $field = $standard_case{$key} || $key;
- $field =~ s/^://;
- if ( index($val, "\n") >= 0 ) {
- $val = _process_newline($val, $endl);
- }
- push @result, $field . ': ' . $val;
- }
- }
- else {
- my $field = $standard_case{$key} || $key;
- $field =~ s/^://;
- if ( index($vals, "\n") >= 0 ) {
- $vals = _process_newline($vals, $endl);
- }
- push @result, $field . ': ' . $vals;
- }
- }
-
- join($endl, @result, '');
-}
-
-sub _process_newline {
- local $_ = shift;
- my $endl = shift;
- # must handle header values with embedded newlines with care
- s/\s+$//; # trailing newlines and space must go
- s/\n(\x0d?\n)+/\n/g; # no empty lines
- s/\n([^\040\t])/\n $1/g; # intial space for continuation
- s/\n/$endl/g; # substitute with requested line ending
- $_;
-}
-
-
-
-if (eval { require Storable; 1 }) {
- *clone = \&Storable::dclone;
-} else {
- *clone = sub {
- my $self = shift;
- my $clone = HTTP::Headers->new;
- $self->scan(sub { $clone->push_header(@_);} );
- $clone;
- };
-}
-
-
-sub _date_header
-{
- require HTTP::Date;
- my($self, $header, $time) = @_;
- my($old) = $self->_header($header);
- if (defined $time) {
- $self->_header($header, HTTP::Date::time2str($time));
- }
- $old =~ s/;.*// if defined($old);
- HTTP::Date::str2time($old);
-}
-
-
-sub date { shift->_date_header('Date', @_); }
-sub expires { shift->_date_header('Expires', @_); }
-sub if_modified_since { shift->_date_header('If-Modified-Since', @_); }
-sub if_unmodified_since { shift->_date_header('If-Unmodified-Since', @_); }
-sub last_modified { shift->_date_header('Last-Modified', @_); }
-
-# This is used as a private LWP extension. The Client-Date header is
-# added as a timestamp to a response when it has been received.
-sub client_date { shift->_date_header('Client-Date', @_); }
-
-# The retry_after field is dual format (can also be a expressed as
-# number of seconds from now), so we don't provide an easy way to
-# access it until we have know how both these interfaces can be
-# addressed. One possibility is to return a negative value for
-# relative seconds and a positive value for epoch based time values.
-#sub retry_after { shift->_date_header('Retry-After', @_); }
-
-sub content_type {
- my $self = shift;
- my $ct = $self->{'content-type'};
- $self->{'content-type'} = shift if @_;
- $ct = $ct->[0] if ref($ct) eq 'ARRAY';
- return '' unless defined($ct) && length($ct);
- my @ct = split(/;\s*/, $ct, 2);
- for ($ct[0]) {
- s/\s+//g;
- $_ = lc($_);
- }
- wantarray ? @ct : $ct[0];
-}
-
-sub content_type_charset {
- my $self = shift;
- require HTTP::Headers::Util;
- my $h = $self->{'content-type'};
- $h = $h->[0] if ref($h);
- $h = "" unless defined $h;
- my @v = HTTP::Headers::Util::split_header_words($h);
- if (@v) {
- my($ct, undef, %ct_param) = @{$v[0]};
- my $charset = $ct_param{charset};
- if ($ct) {
- $ct = lc($ct);
- $ct =~ s/\s+//;
- }
- if ($charset) {
- $charset = uc($charset);
- $charset =~ s/^\s+//; $charset =~ s/\s+\z//;
- undef($charset) if $charset eq "";
- }
- return $ct, $charset if wantarray;
- return $charset;
- }
- return undef, undef if wantarray;
- return undef;
-}
-
-sub content_is_text {
- my $self = shift;
- return $self->content_type =~ m,^text/,;
-}
-
-sub content_is_html {
- my $self = shift;
- return $self->content_type eq 'text/html' || $self->content_is_xhtml;
-}
-
-sub content_is_xhtml {
- my $ct = shift->content_type;
- return $ct eq "application/xhtml+xml" ||
- $ct eq "application/vnd.wap.xhtml+xml";
-}
-
-sub content_is_xml {
- my $ct = shift->content_type;
- return 1 if $ct eq "text/xml";
- return 1 if $ct eq "application/xml";
- return 1 if $ct =~ /\+xml$/;
- return 0;
-}
-
-sub referer {
- my $self = shift;
- if (@_ && $_[0] =~ /#/) {
- # Strip fragment per RFC 2616, section 14.36.
- my $uri = shift;
- if (ref($uri)) {
- $uri = $uri->clone;
- $uri->fragment(undef);
- }
- else {
- $uri =~ s/\#.*//;
- }
- unshift @_, $uri;
- }
- ($self->_header('Referer', @_))[0];
-}
-*referrer = \&referer; # on tchrist's request
-
-sub title { (shift->_header('Title', @_))[0] }
-sub content_encoding { (shift->_header('Content-Encoding', @_))[0] }
-sub content_language { (shift->_header('Content-Language', @_))[0] }
-sub content_length { (shift->_header('Content-Length', @_))[0] }
-
-sub user_agent { (shift->_header('User-Agent', @_))[0] }
-sub server { (shift->_header('Server', @_))[0] }
-
-sub from { (shift->_header('From', @_))[0] }
-sub warning { (shift->_header('Warning', @_))[0] }
-
-sub www_authenticate { (shift->_header('WWW-Authenticate', @_))[0] }
-sub authorization { (shift->_header('Authorization', @_))[0] }
-
-sub proxy_authenticate { (shift->_header('Proxy-Authenticate', @_))[0] }
-sub proxy_authorization { (shift->_header('Proxy-Authorization', @_))[0] }
-
-sub authorization_basic { shift->_basic_auth("Authorization", @_) }
-sub proxy_authorization_basic { shift->_basic_auth("Proxy-Authorization", @_) }
-
-sub _basic_auth {
- require MIME::Base64;
- my($self, $h, $user, $passwd) = @_;
- my($old) = $self->_header($h);
- if (defined $user) {
- Carp::croak("Basic authorization user name can't contain ':'")
- if $user =~ /:/;
- $passwd = '' unless defined $passwd;
- $self->_header($h => 'Basic ' .
- MIME::Base64::encode("$user:$passwd", ''));
- }
- if (defined $old && $old =~ s/^\s*Basic\s+//) {
- my $val = MIME::Base64::decode($old);
- return $val unless wantarray;
- return split(/:/, $val, 2);
- }
- return;
-}
-
-
-1;
-
-__END__
-
-=head1 NAME
-
-HTTP::Headers - Class encapsulating HTTP Message headers
-
-=head1 SYNOPSIS
-
- require HTTP::Headers;
- $h = HTTP::Headers->new;
-
- $h->header('Content-Type' => 'text/plain'); # set
- $ct = $h->header('Content-Type'); # get
- $h->remove_header('Content-Type'); # delete
-
-=head1 DESCRIPTION
-
-The C<HTTP::Headers> class encapsulates HTTP-style message headers.
-The headers consist of attribute-value pairs also called fields, which
-may be repeated, and which are printed in a particular order. The
-field names are cases insensitive.
-
-Instances of this class are usually created as member variables of the
-C<HTTP::Request> and C<HTTP::Response> classes, internal to the
-library.
-
-The following methods are available:
-
-=over 4
-
-=item $h = HTTP::Headers->new
-
-Constructs a new C<HTTP::Headers> object. You might pass some initial
-attribute-value pairs as parameters to the constructor. I<E.g.>:
-
- $h = HTTP::Headers->new(
- Date => 'Thu, 03 Feb 1994 00:00:00 GMT',
- Content_Type => 'text/html; version=3.2',
- Content_Base => 'http://www.perl.org/');
-
-The constructor arguments are passed to the C<header> method which is
-described below.
-
-=item $h->clone
-
-Returns a copy of this C<HTTP::Headers> object.
-
-=item $h->header( $field )
-
-=item $h->header( $field => $value )
-
-=item $h->header( $f1 => $v1, $f2 => $v2, ... )
-
-Get or set the value of one or more header fields. The header field
-name ($field) is not case sensitive. To make the life easier for perl
-users who wants to avoid quoting before the => operator, you can use
-'_' as a replacement for '-' in header names.
-
-The header() method accepts multiple ($field => $value) pairs, which
-means that you can update several fields with a single invocation.
-
-The $value argument may be a plain string or a reference to an array
-of strings for a multi-valued field. If the $value is provided as
-C<undef> then the field is removed. If the $value is not given, then
-that header field will remain unchanged.
-
-The old value (or values) of the last of the header fields is returned.
-If no such field exists C<undef> will be returned.
-
-A multi-valued field will be returned as separate values in list
-context and will be concatenated with ", " as separator in scalar
-context. The HTTP spec (RFC 2616) promise that joining multiple
-values in this way will not change the semantic of a header field, but
-in practice there are cases like old-style Netscape cookies (see
-L<HTTP::Cookies>) where "," is used as part of the syntax of a single
-field value.
-
-Examples:
-
- $header->header(MIME_Version => '1.0',
- User_Agent => 'My-Web-Client/0.01');
- $header->header(Accept => "text/html, text/plain, image/*");
- $header->header(Accept => [qw(text/html text/plain image/*)]);
- @accepts = $header->header('Accept'); # get multiple values
- $accepts = $header->header('Accept'); # get values as a single string
-
-=item $h->push_header( $field => $value )
-
-=item $h->push_header( $f1 => $v1, $f2 => $v2, ... )
-
-Add a new field value for the specified header field. Previous values
-for the same field are retained.
-
-As for the header() method, the field name ($field) is not case
-sensitive and '_' can be used as a replacement for '-'.
-
-The $value argument may be a scalar or a reference to a list of
-scalars.
-
- $header->push_header(Accept => 'image/jpeg');
- $header->push_header(Accept => [map "image/$_", qw(gif png tiff)]);
-
-=item $h->init_header( $field => $value )
-
-Set the specified header to the given value, but only if no previous
-value for that field is set.
-
-The header field name ($field) is not case sensitive and '_'
-can be used as a replacement for '-'.
-
-The $value argument may be a scalar or a reference to a list of
-scalars.
-
-=item $h->remove_header( $field, ... )
-
-This function removes the header fields with the specified names.
-
-The header field names ($field) are not case sensitive and '_'
-can be used as a replacement for '-'.
-
-The return value is the values of the fields removed. In scalar
-context the number of fields removed is returned.
-
-Note that if you pass in multiple field names then it is generally not
-possible to tell which of the returned values belonged to which field.
-
-=item $h->remove_content_headers
-
-This will remove all the header fields used to describe the content of
-a message. All header field names prefixed with C<Content-> fall
-into this category, as well as C<Allow>, C<Expires> and
-C<Last-Modified>. RFC 2616 denotes these fields as I<Entity Header
-Fields>.
-
-The return value is a new C<HTTP::Headers> object that contains the
-removed headers only.
-
-=item $h->clear
-
-This will remove all header fields.
-
-=item $h->header_field_names
-
-Returns the list of distinct names for the fields present in the
-header. The field names have case as suggested by HTTP spec, and the
-names are returned in the recommended "Good Practice" order.
-
-In scalar context return the number of distinct field names.
-
-=item $h->scan( \&process_header_field )
-
-Apply a subroutine to each header field in turn. The callback routine
-is called with two parameters; the name of the field and a single
-value (a string). If a header field is multi-valued, then the
-routine is called once for each value. The field name passed to the
-callback routine has case as suggested by HTTP spec, and the headers
-will be visited in the recommended "Good Practice" order.
-
-Any return values of the callback routine are ignored. The loop can
-be broken by raising an exception (C<die>), but the caller of scan()
-would have to trap the exception itself.
-
-=item $h->as_string
-
-=item $h->as_string( $eol )
-
-Return the header fields as a formatted MIME header. Since it
-internally uses the C<scan> method to build the string, the result
-will use case as suggested by HTTP spec, and it will follow
-recommended "Good Practice" of ordering the header fields. Long header
-values are not folded.
-
-The optional $eol parameter specifies the line ending sequence to
-use. The default is "\n". Embedded "\n" characters in header field
-values will be substituted with this line ending sequence.
-
-=back
-
-=head1 CONVENIENCE METHODS
-
-The most frequently used headers can also be accessed through the
-following convenience methods. Most of 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.
-
-Methods that deal with dates/times always convert their value to system
-time (seconds since Jan 1, 1970) and they also expect this kind of
-value when the header value is set.
-
-=over 4
-
-=item $h->date
-
-This header represents the date and time at which the message was
-originated. I<E.g.>:
-
- $h->date(time); # set current date
-
-=item $h->expires
-
-This header gives the date and time after which the entity should be
-considered stale.
-
-=item $h->if_modified_since
-
-=item $h->if_unmodified_since
-
-These header fields are used to make a request conditional. If the requested
-resource has (or has not) been modified since the time specified in this field,
-then the server will return a C<304 Not Modified> response instead of
-the document itself.
-
-=item $h->last_modified
-
-This header indicates the date and time at which the resource was last
-modified. I<E.g.>:
-
- # check if document is more than 1 hour old
- if (my $last_mod = $h->last_modified) {
- if ($last_mod < time - 60*60) {
- ...
- }
- }
-
-=item $h->content_type
-
-The Content-Type header field indicates the media type of the message
-content. I<E.g.>:
-
- $h->content_type('text/html');
-
-The value returned will be converted to lower case, and potential
-parameters will be chopped off and returned as a separate value if in
-an array context. If there is no such header field, then the empty
-string is returned. This makes it safe to do the following:
-
- if ($h->content_type eq 'text/html') {
- # we enter this place even if the real header value happens to
- # be 'TEXT/HTML; version=3.0'
- ...
- }
-
-=item $h->content_type_charset
-
-Returns the upper-cased charset specified in the Content-Type header. In list
-context return the lower-cased bare content type followed by the upper-cased
-charset. Both values will be C<undef> if not specified in the header.
-
-=item $h->content_is_text
-
-Returns TRUE if the Content-Type header field indicate that the
-content is textual.
-
-=item $h->content_is_html
-
-Returns TRUE if the Content-Type header field indicate that the
-content is some kind of HTML (including XHTML). This method can't be
-used to set Content-Type.
-
-=item $h->content_is_xhtml
-
-Returns TRUE if the Content-Type header field indicate that the
-content is XHTML. This method can't be used to set Content-Type.
-
-=item $h->content_is_xml
-
-Returns TRUE if the Content-Type header field indicate that the
-content is XML. This method can't be used to set Content-Type.
-
-=item $h->content_encoding
-
-The Content-Encoding header field is used as a modifier to the
-media type. When present, its value indicates what additional
-encoding mechanism has been applied to the resource.
-
-=item $h->content_length
-
-A decimal number indicating the size in bytes of the message content.
-
-=item $h->content_language
-
-The natural language(s) of the intended audience for the message
-content. The value is one or more language tags as defined by RFC
-1766. Eg. "no" for some kind of Norwegian and "en-US" for English the
-way it is written in the US.
-
-=item $h->title
-
-The title of the document. In libwww-perl this header will be
-initialized automatically from the E<lt>TITLE>...E<lt>/TITLE> element
-of HTML documents. I<This header is no longer part of the HTTP
-standard.>
-
-=item $h->user_agent
-
-This header field is used in request messages and contains information
-about the user agent originating the request. I<E.g.>:
-
- $h->user_agent('Mozilla/5.0 (compatible; MSIE 7.0; Windows NT 6.0)');
-
-=item $h->server
-
-The server header field contains information about the software being
-used by the originating server program handling the request.
-
-=item $h->from
-
-This header should contain an Internet e-mail address for the human
-user who controls the requesting user agent. The address should be
-machine-usable, as defined by RFC822. E.g.:
-
- $h->from('King Kong <king@kong.com>');
-
-I<This header is no longer part of the HTTP standard.>
-
-=item $h->referer
-
-Used to specify the address (URI) of the document from which the
-requested resource address was obtained.
-
-The "Free On-line Dictionary of Computing" as this to say about the
-word I<referer>:
-
- <World-Wide Web> A misspelling of "referrer" which
- somehow made it into the {HTTP} standard. A given {web
- page}'s referer (sic) is the {URL} of whatever web page
- contains the link that the user followed to the current
- page. Most browsers pass this information as part of a
- request.
-
- (1998-10-19)
-
-By popular demand C<referrer> exists as an alias for this method so you
-can avoid this misspelling in your programs and still send the right
-thing on the wire.
-
-When setting the referrer, this method removes the fragment from the
-given URI if it is present, as mandated by RFC2616. Note that
-the removal does I<not> happen automatically if using the header(),
-push_header() or init_header() methods to set the referrer.
-
-=item $h->www_authenticate
-
-This header must be included as part of a C<401 Unauthorized> response.
-The field value consist of a challenge that indicates the
-authentication scheme and parameters applicable to the requested URI.
-
-=item $h->proxy_authenticate
-
-This header must be included in a C<407 Proxy Authentication Required>
-response.
-
-=item $h->authorization
-
-=item $h->proxy_authorization
-
-A user agent that wishes to authenticate itself with a server or a
-proxy, may do so by including these headers.
-
-=item $h->authorization_basic
-
-This method is used to get or set an authorization header that use the
-"Basic Authentication Scheme". In array context it will return two
-values; the user name and the password. In scalar context it will
-return I<"uname:password"> as a single string value.
-
-When used to set the header value, it expects two arguments. I<E.g.>:
-
- $h->authorization_basic($uname, $password);
-
-The method will croak if the $uname contains a colon ':'.
-
-=item $h->proxy_authorization_basic
-
-Same as authorization_basic() but will set the "Proxy-Authorization"
-header instead.
-
-=back
-
-=head1 NON-CANONICALIZED FIELD NAMES
-
-The header field name spelling is normally canonicalized including the
-'_' to '-' translation. There are some application where this is not
-appropriate. Prefixing field names with ':' allow you to force a
-specific spelling. For example if you really want a header field name
-to show up as C<foo_bar> instead of "Foo-Bar", you might set it like
-this:
-
- $h->header(":foo_bar" => 1);
-
-These field names are returned with the ':' intact for
-$h->header_field_names and the $h->scan callback, but the colons do
-not show in $h->as_string.
-
-=head1 COPYRIGHT
-
-Copyright 1995-2005 Gisle Aas.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
+++ /dev/null
-package HTTP::Headers::Auth;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = "5.817";
-
-use HTTP::Headers;
-
-package HTTP::Headers;
-
-BEGIN {
- # we provide a new (and better) implementations below
- undef(&www_authenticate);
- undef(&proxy_authenticate);
-}
-
-require HTTP::Headers::Util;
-
-sub _parse_authenticate
-{
- my @ret;
- for (HTTP::Headers::Util::split_header_words(@_)) {
- if (!defined($_->[1])) {
- # this is a new auth scheme
- push(@ret, shift(@$_) => {});
- shift @$_;
- }
- if (@ret) {
- # this a new parameter pair for the last auth scheme
- while (@$_) {
- my $k = shift @$_;
- my $v = shift @$_;
- $ret[-1]{$k} = $v;
- }
- }
- else {
- # something wrong, parameter pair without any scheme seen
- # IGNORE
- }
- }
- @ret;
-}
-
-sub _authenticate
-{
- my $self = shift;
- my $header = shift;
- my @old = $self->_header($header);
- if (@_) {
- $self->remove_header($header);
- my @new = @_;
- while (@new) {
- my $a_scheme = shift(@new);
- if ($a_scheme =~ /\s/) {
- # assume complete valid value, pass it through
- $self->push_header($header, $a_scheme);
- }
- else {
- my @param;
- if (@new) {
- my $p = $new[0];
- if (ref($p) eq "ARRAY") {
- @param = @$p;
- shift(@new);
- }
- elsif (ref($p) eq "HASH") {
- @param = %$p;
- shift(@new);
- }
- }
- my $val = ucfirst(lc($a_scheme));
- if (@param) {
- my $sep = " ";
- while (@param) {
- my $k = shift @param;
- my $v = shift @param;
- if ($v =~ /[^0-9a-zA-Z]/ || lc($k) eq "realm") {
- # must quote the value
- $v =~ s,([\\\"]),\\$1,g;
- $v = qq("$v");
- }
- $val .= "$sep$k=$v";
- $sep = ", ";
- }
- }
- $self->push_header($header, $val);
- }
- }
- }
- return unless defined wantarray;
- wantarray ? _parse_authenticate(@old) : join(", ", @old);
-}
-
-
-sub www_authenticate { shift->_authenticate("WWW-Authenticate", @_) }
-sub proxy_authenticate { shift->_authenticate("Proxy-Authenticate", @_) }
-
-1;
+++ /dev/null
-package HTTP::Headers::ETag;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = "5.810";
-
-require HTTP::Date;
-
-require HTTP::Headers;
-package HTTP::Headers;
-
-sub _etags
-{
- my $self = shift;
- my $header = shift;
- my @old = _split_etag_list($self->_header($header));
- if (@_) {
- $self->_header($header => join(", ", _split_etag_list(@_)));
- }
- wantarray ? @old : join(", ", @old);
-}
-
-sub etag { shift->_etags("ETag", @_); }
-sub if_match { shift->_etags("If-Match", @_); }
-sub if_none_match { shift->_etags("If-None-Match", @_); }
-
-sub if_range {
- # Either a date or an entity-tag
- my $self = shift;
- my @old = $self->_header("If-Range");
- if (@_) {
- my $new = shift;
- if (!defined $new) {
- $self->remove_header("If-Range");
- }
- elsif ($new =~ /^\d+$/) {
- $self->_date_header("If-Range", $new);
- }
- else {
- $self->_etags("If-Range", $new);
- }
- }
- return unless defined(wantarray);
- for (@old) {
- my $t = HTTP::Date::str2time($_);
- $_ = $t if $t;
- }
- wantarray ? @old : join(", ", @old);
-}
-
-
-# Split a list of entity tag values. The return value is a list
-# consisting of one element per entity tag. Suitable for parsing
-# headers like C<If-Match>, C<If-None-Match>. You might even want to
-# use it on C<ETag> and C<If-Range> entity tag values, because it will
-# normalize them to the common form.
-#
-# entity-tag = [ weak ] opaque-tag
-# weak = "W/"
-# opaque-tag = quoted-string
-
-
-sub _split_etag_list
-{
- my(@val) = @_;
- my @res;
- for (@val) {
- while (length) {
- my $weak = "";
- $weak = "W/" if s,^\s*[wW]/,,;
- my $etag = "";
- if (s/^\s*(\"[^\"\\]*(?:\\.[^\"\\]*)*\")//) {
- push(@res, "$weak$1");
- }
- elsif (s/^\s*,//) {
- push(@res, qq(W/"")) if $weak;
- }
- elsif (s/^\s*([^,\s]+)//) {
- $etag = $1;
- $etag =~ s/([\"\\])/\\$1/g;
- push(@res, qq($weak"$etag"));
- }
- elsif (s/^\s+// || !length) {
- push(@res, qq(W/"")) if $weak;
- }
- else {
- die "This should not happen: '$_'";
- }
- }
- }
- @res;
-}
-
-1;
+++ /dev/null
-package HTTP::Headers::Util;
-
-use strict;
-use vars qw($VERSION @ISA @EXPORT_OK);
-
-$VERSION = "5.817";
-
-require Exporter;
-@ISA=qw(Exporter);
-
-@EXPORT_OK=qw(split_header_words _split_header_words join_header_words);
-
-
-
-sub split_header_words {
- my @res = &_split_header_words;
- for my $arr (@res) {
- for (my $i = @$arr - 2; $i >= 0; $i -= 2) {
- $arr->[$i] = lc($arr->[$i]);
- }
- }
- return @res;
-}
-
-sub _split_header_words
-{
- my(@val) = @_;
- my @res;
- for (@val) {
- my @cur;
- while (length) {
- if (s/^\s*(=*[^\s=;,]+)//) { # 'token' or parameter 'attribute'
- push(@cur, $1);
- # a quoted value
- if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) {
- my $val = $1;
- $val =~ s/\\(.)/$1/g;
- push(@cur, $val);
- # some unquoted value
- }
- elsif (s/^\s*=\s*([^;,\s]*)//) {
- my $val = $1;
- $val =~ s/\s+$//;
- push(@cur, $val);
- # no value, a lone token
- }
- else {
- push(@cur, undef);
- }
- }
- elsif (s/^\s*,//) {
- push(@res, [@cur]) if @cur;
- @cur = ();
- }
- elsif (s/^\s*;// || s/^\s+//) {
- # continue
- }
- else {
- die "This should not happen: '$_'";
- }
- }
- push(@res, \@cur) if @cur;
- }
- @res;
-}
-
-
-sub join_header_words
-{
- @_ = ([@_]) if @_ && !ref($_[0]);
- my @res;
- for (@_) {
- my @cur = @$_;
- my @attr;
- while (@cur) {
- my $k = shift @cur;
- my $v = shift @cur;
- if (defined $v) {
- if ($v =~ /[\x00-\x20()<>@,;:\\\"\/\[\]?={}\x7F-\xFF]/ || !length($v)) {
- $v =~ s/([\"\\])/\\$1/g; # escape " and \
- $k .= qq(="$v");
- }
- else {
- # token
- $k .= "=$v";
- }
- }
- push(@attr, $k);
- }
- push(@res, join("; ", @attr)) if @attr;
- }
- join(", ", @res);
-}
-
-
-1;
-
-__END__
-
-=head1 NAME
-
-HTTP::Headers::Util - Header value parsing utility functions
-
-=head1 SYNOPSIS
-
- use HTTP::Headers::Util qw(split_header_words);
- @values = split_header_words($h->header("Content-Type"));
-
-=head1 DESCRIPTION
-
-This module provides a few functions that helps parsing and
-construction of valid HTTP header values. None of the functions are
-exported by default.
-
-The following functions are available:
-
-=over 4
-
-
-=item split_header_words( @header_values )
-
-This function will parse the header values given as argument into a
-list of anonymous arrays containing key/value pairs. The function
-knows how to deal with ",", ";" and "=" as well as quoted values after
-"=". A list of space separated tokens are parsed as if they were
-separated by ";".
-
-If the @header_values passed as argument contains multiple values,
-then they are treated as if they were a single value separated by
-comma ",".
-
-This means that this function is useful for parsing header fields that
-follow this syntax (BNF as from the HTTP/1.1 specification, but we relax
-the requirement for tokens).
-
- headers = #header
- header = (token | parameter) *( [";"] (token | parameter))
-
- token = 1*<any CHAR except CTLs or separators>
- separators = "(" | ")" | "<" | ">" | "@"
- | "," | ";" | ":" | "\" | <">
- | "/" | "[" | "]" | "?" | "="
- | "{" | "}" | SP | HT
-
- quoted-string = ( <"> *(qdtext | quoted-pair ) <"> )
- qdtext = <any TEXT except <">>
- quoted-pair = "\" CHAR
-
- parameter = attribute "=" value
- attribute = token
- value = token | quoted-string
-
-Each I<header> is represented by an anonymous array of key/value
-pairs. The keys will be all be forced to lower case.
-The value for a simple token (not part of a parameter) is C<undef>.
-Syntactically incorrect headers will not necessary be parsed as you
-would want.
-
-This is easier to describe with some examples:
-
- split_header_words('foo="bar"; port="80,81"; DISCARD, BAR=baz');
- split_header_words('text/html; charset="iso-8859-1"');
- split_header_words('Basic realm="\\"foo\\\\bar\\""');
-
-will return
-
- [foo=>'bar', port=>'80,81', discard=> undef], [bar=>'baz' ]
- ['text/html' => undef, charset => 'iso-8859-1']
- [basic => undef, realm => "\"foo\\bar\""]
-
-If you don't want the function to convert tokens and attribute keys to
-lower case you can call it as C<_split_header_words> instead (with a
-leading underscore).
-
-=item join_header_words( @arrays )
-
-This will do the opposite of the conversion done by split_header_words().
-It takes a list of anonymous arrays as arguments (or a list of
-key/value pairs) and produces a single header value. Attribute values
-are quoted if needed.
-
-Example:
-
- join_header_words(["text/plain" => undef, charset => "iso-8859/1"]);
- join_header_words("text/plain" => undef, charset => "iso-8859/1");
-
-will both return the string:
-
- text/plain; charset="iso-8859/1"
-
-=back
-
-=head1 COPYRIGHT
-
-Copyright 1997-1998, Gisle Aas
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
+++ /dev/null
-package HTTP::Message;
-
-use strict;
-use vars qw($VERSION $AUTOLOAD);
-$VERSION = "5.837";
-
-require HTTP::Headers;
-require Carp;
-
-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
-{
- my($class, $header, $content) = @_;
- if (defined $header) {
- Carp::croak("Bad header argument") unless ref $header;
- if (ref($header) eq "ARRAY") {
- $header = HTTP::Headers->new(@$header);
- }
- else {
- $header = $header->clone;
- }
- }
- else {
- $header = HTTP::Headers->new;
- }
- if (defined $content) {
- _utf8_downgrade($content);
- }
- else {
- $content = '';
- }
-
- bless {
- '_headers' => $header,
- '_content' => $content,
- }, $class;
-}
-
-
-sub parse
-{
- my($class, $str) = @_;
-
- my @hdr;
- while (1) {
- if ($str =~ s/^([^\s:]+)[ \t]*: ?(.*)\n?//) {
- push(@hdr, $1, $2);
- $hdr[-1] =~ s/\r\z//;
- }
- elsif (@hdr && $str =~ s/^([ \t].*)\n?//) {
- $hdr[-1] .= "\n$1";
- $hdr[-1] =~ s/\r\z//;
- }
- else {
- $str =~ s/^\r?\n//;
- last;
- }
- }
- local $HTTP::Headers::TRANSLATE_UNDERSCORE;
- new($class, \@hdr, $str);
-}
-
-
-sub clone
-{
- my $self = shift;
- my $clone = HTTP::Message->new($self->headers,
- $self->content);
- $clone->protocol($self->protocol);
- $clone;
-}
-
-
-sub clear {
- my $self = shift;
- $self->{_headers}->clear;
- $self->content("");
- delete $self->{_parts};
- return;
-}
-
-
-sub protocol {
- shift->_elem('_protocol', @_);
-}
-
-sub headers {
- my $self = shift;
-
- # recalculation of _content might change headers, so we
- # need to force it now
- $self->_content unless exists $self->{_content};
-
- $self->{_headers};
-}
-
-sub headers_as_string {
- shift->headers->as_string(@_);
-}
-
-
-sub content {
-
- my $self = $_[0];
- if (defined(wantarray)) {
- $self->_content unless exists $self->{_content};
- my $old = $self->{_content};
- $old = $$old if ref($old) eq "SCALAR";
- &_set_content if @_ > 1;
- return $old;
- }
-
- if (@_ > 1) {
- &_set_content;
- }
- else {
- Carp::carp("Useless content call in void context") if $^W;
- }
-}
-
-
-sub _set_content {
- my $self = $_[0];
- _utf8_downgrade($_[1]);
- if (!ref($_[1]) && ref($self->{_content}) eq "SCALAR") {
- ${$self->{_content}} = $_[1];
- }
- else {
- die "Can't set content to be a scalar reference" if ref($_[1]) eq "SCALAR";
- $self->{_content} = $_[1];
- delete $self->{_content_ref};
- }
- delete $self->{_parts} unless $_[2];
-}
-
-
-sub add_content
-{
- my $self = shift;
- $self->_content unless exists $self->{_content};
- my $chunkref = \$_[0];
- $chunkref = $$chunkref if ref($$chunkref); # legacy
-
- _utf8_downgrade($$chunkref);
-
- my $ref = ref($self->{_content});
- if (!$ref) {
- $self->{_content} .= $$chunkref;
- }
- elsif ($ref eq "SCALAR") {
- ${$self->{_content}} .= $$chunkref;
- }
- else {
- Carp::croak("Can't append to $ref content");
- }
- delete $self->{_parts};
-}
-
-sub add_content_utf8 {
- my($self, $buf) = @_;
- utf8::upgrade($buf);
- utf8::encode($buf);
- $self->add_content($buf);
-}
-
-sub content_ref
-{
- my $self = shift;
- $self->_content unless exists $self->{_content};
- delete $self->{_parts};
- my $old = \$self->{_content};
- my $old_cref = $self->{_content_ref};
- if (@_) {
- my $new = shift;
- Carp::croak("Setting content_ref to a non-ref") unless ref($new);
- delete $self->{_content}; # avoid modifying $$old
- $self->{_content} = $new;
- $self->{_content_ref}++;
- }
- $old = $$old if $old_cref;
- return $old;
-}
-
-
-sub content_charset
-{
- my $self = shift;
- if (my $charset = $self->content_type_charset) {
- return $charset;
- }
-
- # time to start guessing
- my $cref = $self->decoded_content(ref => 1, charset => "none");
-
- # Unicode BOM
- for ($$cref) {
- return "UTF-8" if /^\xEF\xBB\xBF/;
- return "UTF-32-LE" if /^\xFF\xFE\x00\x00/;
- return "UTF-32-BE" if /^\x00\x00\xFE\xFF/;
- return "UTF-16-LE" if /^\xFF\xFE/;
- return "UTF-16-BE" if /^\xFE\xFF/;
- }
-
- if ($self->content_is_xml) {
- # http://www.w3.org/TR/2006/REC-xml-20060816/#sec-guessing
- # XML entity not accompanied by external encoding information and not
- # in UTF-8 or UTF-16 encoding must begin with an XML encoding declaration,
- # in which the first characters must be '<?xml'
- for ($$cref) {
- return "UTF-32-BE" if /^\x00\x00\x00</;
- return "UTF-32-LE" if /^<\x00\x00\x00/;
- return "UTF-16-BE" if /^(?:\x00\s)*\x00</;
- return "UTF-16-LE" if /^(?:\s\x00)*<\x00/;
- if (/^\s*(<\?xml[^\x00]*?\?>)/) {
- if ($1 =~ /\sencoding\s*=\s*(["'])(.*?)\1/) {
- my $enc = $2;
- $enc =~ s/^\s+//; $enc =~ s/\s+\z//;
- return $enc if $enc;
- }
- }
- }
- return "UTF-8";
- }
- elsif ($self->content_is_html) {
- # look for <META charset="..."> or <META content="...">
- # http://dev.w3.org/html5/spec/Overview.html#determining-the-character-encoding
- my $charset;
- require HTML::Parser;
- my $p = HTML::Parser->new(
- start_h => [sub {
- my($tag, $attr, $self) = @_;
- $charset = $attr->{charset};
- unless ($charset) {
- # look at $attr->{content} ...
- if (my $c = $attr->{content}) {
- require HTTP::Headers::Util;
- my @v = HTTP::Headers::Util::split_header_words($c);
- return unless @v;
- my($ct, undef, %ct_param) = @{$v[0]};
- $charset = $ct_param{charset};
- }
- return unless $charset;
- }
- if ($charset =~ /^utf-?16/i) {
- # converted document, assume UTF-8
- $charset = "UTF-8";
- }
- $self->eof;
- }, "tagname, attr, self"],
- report_tags => [qw(meta)],
- utf8_mode => 1,
- );
- $p->parse($$cref);
- return $charset if $charset;
- }
- if ($self->content_type =~ /^text\//) {
- for ($$cref) {
- if (length) {
- return "US-ASCII" unless /[\x80-\xFF]/;
- require Encode;
- eval {
- Encode::decode_utf8($_, Encode::FB_CROAK() | Encode::LEAVE_SRC());
- };
- return "UTF-8" unless $@;
- return "ISO-8859-1";
- }
- }
- }
-
- return undef;
-}
-
-
-sub decoded_content
-{
- my($self, %opt) = @_;
- my $content_ref;
- my $content_ref_iscopy;
-
- eval {
- $content_ref = $self->content_ref;
- die "Can't decode ref content" if ref($content_ref) ne "SCALAR";
-
- if (my $h = $self->header("Content-Encoding")) {
- $h =~ s/^\s+//;
- $h =~ s/\s+$//;
- for my $ce (reverse split(/\s*,\s*/, lc($h))) {
- next unless $ce;
- next if $ce eq "identity";
- if ($ce eq "gzip" || $ce eq "x-gzip") {
- require IO::Uncompress::Gunzip;
- my $output;
- IO::Uncompress::Gunzip::gunzip($content_ref, \$output, Transparent => 0)
- or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError";
- $content_ref = \$output;
- $content_ref_iscopy++;
- }
- elsif ($ce eq "x-bzip2") {
- require IO::Uncompress::Bunzip2;
- my $output;
- IO::Uncompress::Bunzip2::bunzip2($content_ref, \$output, Transparent => 0)
- or die "Can't bunzip content: $IO::Uncompress::Bunzip2::Bunzip2Error";
- $content_ref = \$output;
- $content_ref_iscopy++;
- }
- elsif ($ce eq "deflate") {
- require IO::Uncompress::Inflate;
- my $output;
- my $status = IO::Uncompress::Inflate::inflate($content_ref, \$output, Transparent => 0);
- my $error = $IO::Uncompress::Inflate::InflateError;
- unless ($status) {
- # "Content-Encoding: deflate" is supposed to mean the
- # "zlib" format of RFC 1950, but Microsoft got that
- # wrong, so some servers sends the raw compressed
- # "deflate" data. This tries to inflate this format.
- $output = undef;
- require IO::Uncompress::RawInflate;
- unless (IO::Uncompress::RawInflate::rawinflate($content_ref, \$output)) {
- $self->push_header("Client-Warning" =>
- "Could not raw inflate content: $IO::Uncompress::RawInflate::RawInflateError");
- $output = undef;
- }
- }
- die "Can't inflate content: $error" unless defined $output;
- $content_ref = \$output;
- $content_ref_iscopy++;
- }
- elsif ($ce eq "compress" || $ce eq "x-compress") {
- die "Can't uncompress content";
- }
- elsif ($ce eq "base64") { # not really C-T-E, but should be harmless
- require MIME::Base64;
- $content_ref = \MIME::Base64::decode($$content_ref);
- $content_ref_iscopy++;
- }
- elsif ($ce eq "quoted-printable") { # not really C-T-E, but should be harmless
- require MIME::QuotedPrint;
- $content_ref = \MIME::QuotedPrint::decode($$content_ref);
- $content_ref_iscopy++;
- }
- else {
- die "Don't know how to decode Content-Encoding '$ce'";
- }
- }
- }
-
- if ($self->content_is_text || (my $is_xml = $self->content_is_xml)) {
- my $charset = lc(
- $opt{charset} ||
- $self->content_type_charset ||
- $opt{default_charset} ||
- $self->content_charset ||
- "ISO-8859-1"
- );
- unless ($charset =~ /^(?:none|us-ascii|iso-8859-1)\z/) {
- require Encode;
- if (do{my $v = $Encode::VERSION; $v =~ s/_//g; $v} < 2.0901 &&
- !$content_ref_iscopy)
- {
- # LEAVE_SRC did not work before Encode-2.0901
- my $copy = $$content_ref;
- $content_ref = \$copy;
- $content_ref_iscopy++;
- }
- eval {
- $content_ref = \Encode::decode($charset, $$content_ref,
- ($opt{charset_strict} ? Encode::FB_CROAK() : 0) | Encode::LEAVE_SRC());
- };
- if ($@) {
- my $retried;
- if ($@ =~ /^Unknown encoding/) {
- my $alt_charset = lc($opt{alt_charset} || "");
- if ($alt_charset && $charset ne $alt_charset) {
- # Retry decoding with the alternative charset
- $content_ref = \Encode::decode($alt_charset, $$content_ref,
- ($opt{charset_strict} ? Encode::FB_CROAK() : 0) | Encode::LEAVE_SRC())
- unless $alt_charset =~ /^(?:none|us-ascii|iso-8859-1)\z/;
- $retried++;
- }
- }
- die unless $retried;
- }
- die "Encode::decode() returned undef improperly" unless defined $$content_ref;
- if ($is_xml) {
- # Get rid of the XML encoding declaration if present
- $$content_ref =~ s/^\x{FEFF}//;
- if ($$content_ref =~ /^(\s*<\?xml[^\x00]*?\?>)/) {
- substr($$content_ref, 0, length($1)) =~ s/\sencoding\s*=\s*(["']).*?\1//;
- }
- }
- }
- }
- };
- if ($@) {
- Carp::croak($@) if $opt{raise_error};
- return undef;
- }
-
- return $opt{ref} ? $content_ref : $$content_ref;
-}
-
-
-sub decodable
-{
- # should match the Content-Encoding values that decoded_content can deal with
- my $self = shift;
- my @enc;
- # XXX preferably we should determine if the modules are available without loading
- # them here
- eval {
- require IO::Uncompress::Gunzip;
- push(@enc, "gzip", "x-gzip");
- };
- eval {
- require IO::Uncompress::Inflate;
- require IO::Uncompress::RawInflate;
- push(@enc, "deflate");
- };
- eval {
- require IO::Uncompress::Bunzip2;
- push(@enc, "x-bzip2");
- };
- # we don't care about announcing the 'identity', 'base64' and
- # 'quoted-printable' stuff
- return wantarray ? @enc : join(", ", @enc);
-}
-
-
-sub decode
-{
- my $self = shift;
- return 1 unless $self->header("Content-Encoding");
- if (defined(my $content = $self->decoded_content(charset => "none"))) {
- $self->remove_header("Content-Encoding", "Content-Length", "Content-MD5");
- $self->content($content);
- return 1;
- }
- return 0;
-}
-
-
-sub encode
-{
- my($self, @enc) = @_;
-
- Carp::croak("Can't encode multipart/* messages") if $self->content_type =~ m,^multipart/,;
- Carp::croak("Can't encode message/* messages") if $self->content_type =~ m,^message/,;
-
- return 1 unless @enc; # nothing to do
-
- my $content = $self->content;
- for my $encoding (@enc) {
- if ($encoding eq "identity") {
- # nothing to do
- }
- elsif ($encoding eq "base64") {
- require MIME::Base64;
- $content = MIME::Base64::encode($content);
- }
- elsif ($encoding eq "gzip" || $encoding eq "x-gzip") {
- require IO::Compress::Gzip;
- my $output;
- IO::Compress::Gzip::gzip(\$content, \$output, Minimal => 1)
- or die "Can't gzip content: $IO::Compress::Gzip::GzipError";
- $content = $output;
- }
- elsif ($encoding eq "deflate") {
- require IO::Compress::Deflate;
- my $output;
- IO::Compress::Deflate::deflate(\$content, \$output)
- or die "Can't deflate content: $IO::Compress::Deflate::DeflateError";
- $content = $output;
- }
- elsif ($encoding eq "x-bzip2") {
- require IO::Compress::Bzip2;
- my $output;
- IO::Compress::Bzip2::bzip2(\$content, \$output)
- or die "Can't bzip2 content: $IO::Compress::Bzip2::Bzip2Error";
- $content = $output;
- }
- elsif ($encoding eq "rot13") { # for the fun of it
- $content =~ tr/A-Za-z/N-ZA-Mn-za-m/;
- }
- else {
- return 0;
- }
- }
- my $h = $self->header("Content-Encoding");
- unshift(@enc, $h) if $h;
- $self->header("Content-Encoding", join(", ", @enc));
- $self->remove_header("Content-Length", "Content-MD5");
- $self->content($content);
- return 1;
-}
-
-
-sub as_string
-{
- my($self, $eol) = @_;
- $eol = "\n" unless defined $eol;
-
- # The calculation of content might update the headers
- # so we need to do that first.
- my $content = $self->content;
-
- return join("", $self->{'_headers'}->as_string($eol),
- $eol,
- $content,
- (@_ == 1 && length($content) &&
- $content !~ /\n\z/) ? "\n" : "",
- );
-}
-
-
-sub dump
-{
- my($self, %opt) = @_;
- my $content = $self->content;
- my $chopped = 0;
- if (!ref($content)) {
- my $maxlen = $opt{maxlength};
- $maxlen = 512 unless defined($maxlen);
- if ($maxlen && length($content) > $maxlen * 1.1 + 3) {
- $chopped = length($content) - $maxlen;
- $content = substr($content, 0, $maxlen) . "...";
- }
-
- $content =~ s/\\/\\\\/g;
- $content =~ s/\t/\\t/g;
- $content =~ s/\r/\\r/g;
-
- # no need for 3 digits in escape for these
- $content =~ s/([\0-\11\13-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
-
- $content =~ s/([\0-\11\13-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
- $content =~ s/([^\12\040-\176])/sprintf('\\x{%X}',ord($1))/eg;
-
- # remaining whitespace
- $content =~ s/( +)\n/("\\40" x length($1)) . "\n"/eg;
- $content =~ s/(\n+)\n/("\\n" x length($1)) . "\n"/eg;
- $content =~ s/\n\z/\\n/;
-
- my $no_content = "(no content)";
- if ($content eq $no_content) {
- # escape our $no_content marker
- $content =~ s/^(.)/sprintf('\\x%02X',ord($1))/eg;
- }
- elsif ($content eq "") {
- $content = "(no content)";
- }
- }
-
- my @dump;
- push(@dump, $opt{preheader}) if $opt{preheader};
- push(@dump, $self->{_headers}->as_string, $content);
- push(@dump, "(+ $chopped more bytes not shown)") if $chopped;
-
- my $dump = join("\n", @dump, "");
- $dump =~ s/^/$opt{prefix}/gm if $opt{prefix};
-
- print $dump unless defined wantarray;
- return $dump;
-}
-
-
-sub parts {
- my $self = shift;
- if (defined(wantarray) && (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR")) {
- $self->_parts;
- }
- my $old = $self->{_parts};
- if (@_) {
- my @parts = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_;
- my $ct = $self->content_type || "";
- if ($ct =~ m,^message/,) {
- Carp::croak("Only one part allowed for $ct content")
- if @parts > 1;
- }
- elsif ($ct !~ m,^multipart/,) {
- $self->remove_content_headers;
- $self->content_type("multipart/mixed");
- }
- $self->{_parts} = \@parts;
- _stale_content($self);
- }
- return @$old if wantarray;
- return $old->[0];
-}
-
-sub add_part {
- my $self = shift;
- if (($self->content_type || "") !~ m,^multipart/,) {
- my $p = HTTP::Message->new($self->remove_content_headers,
- $self->content(""));
- $self->content_type("multipart/mixed");
- $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;
- }
-
- push(@{$self->{_parts}}, @_);
- _stale_content($self);
- return;
-}
-
-sub _stale_content {
- my $self = shift;
- if (ref($self->{_content}) eq "SCALAR") {
- # must recalculate now
- $self->_content;
- }
- else {
- # just invalidate cache
- delete $self->{_content};
- delete $self->{_content_ref};
- }
-}
-
-
-# delegate all other method calls the the headers object.
-sub AUTOLOAD
-{
- my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
-
- # We create the function here so that it will not need to be
- # autoloaded the next time.
- no strict 'refs';
- *$method = sub { shift->headers->$method(@_) };
- goto &$method;
-}
-
-
-sub DESTROY {} # avoid AUTOLOADing it
-
-
-# Private method to access members in %$self
-sub _elem
-{
- my $self = shift;
- my $elem = shift;
- my $old = $self->{$elem};
- $self->{$elem} = $_[0] if @_;
- return $old;
-}
-
-
-# Create private _parts attribute from current _content
-sub _parts {
- my $self = shift;
- my $ct = $self->content_type;
- if ($ct =~ m,^multipart/,) {
- require HTTP::Headers::Util;
- my @h = HTTP::Headers::Util::split_header_words($self->header("Content-Type"));
- die "Assert" unless @h;
- my %h = @{$h[0]};
- if (defined(my $b = $h{boundary})) {
- my $str = $self->content;
- $str =~ s/\r?\n--\Q$b\E--\r?\n.*//s;
- if ($str =~ s/(^|.*?\r?\n)--\Q$b\E\r?\n//s) {
- $self->{_parts} = [map HTTP::Message->parse($_),
- split(/\r?\n--\Q$b\E\r?\n/, $str)]
- }
- }
- }
- elsif ($ct eq "message/http") {
- require HTTP::Request;
- require HTTP::Response;
- my $content = $self->content;
- my $class = ($content =~ m,^(HTTP/.*)\n,) ?
- "HTTP::Response" : "HTTP::Request";
- $self->{_parts} = [$class->parse($content)];
- }
- elsif ($ct =~ m,^message/,) {
- $self->{_parts} = [ HTTP::Message->parse($self->content) ];
- }
-
- $self->{_parts} ||= [];
-}
-
-
-# Create private _content attribute from current _parts
-sub _content {
- my $self = shift;
- my $ct = $self->{_headers}->header("Content-Type") || "multipart/mixed";
- if ($ct =~ m,^\s*message/,i) {
- _set_content($self, $self->{_parts}[0]->as_string($CRLF), 1);
- return;
- }
-
- require HTTP::Headers::Util;
- my @v = HTTP::Headers::Util::split_header_words($ct);
- Carp::carp("Multiple Content-Type headers") if @v > 1;
- @v = @{$v[0]};
-
- my $boundary;
- my $boundary_index;
- for (my @tmp = @v; @tmp;) {
- my($k, $v) = splice(@tmp, 0, 2);
- if ($k eq "boundary") {
- $boundary = $v;
- $boundary_index = @v - @tmp - 1;
- last;
- }
- }
-
- my @parts = map $_->as_string($CRLF), @{$self->{_parts}};
-
- my $bno = 0;
- $boundary = _boundary() unless defined $boundary;
- CHECK_BOUNDARY:
- {
- for (@parts) {
- if (index($_, $boundary) >= 0) {
- # must have a better boundary
- $boundary = _boundary(++$bno);
- redo CHECK_BOUNDARY;
- }
- }
- }
-
- if ($boundary_index) {
- $v[$boundary_index] = $boundary;
- }
- else {
- push(@v, boundary => $boundary);
- }
-
- $ct = HTTP::Headers::Util::join_header_words(@v);
- $self->{_headers}->header("Content-Type", $ct);
-
- _set_content($self, "--$boundary$CRLF" .
- join("$CRLF--$boundary$CRLF", @parts) .
- "$CRLF--$boundary--$CRLF",
- 1);
-}
-
-
-sub _boundary
-{
- my $size = shift || return "xYzZY";
- require MIME::Base64;
- my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), "");
- $b =~ s/[\W]/X/g; # ensure alnum only
- $b;
-}
-
-
-1;
-
-
-__END__
-
-=head1 NAME
-
-HTTP::Message - HTTP style message (base class)
-
-=head1 SYNOPSIS
-
- use base 'HTTP::Message';
-
-=head1 DESCRIPTION
-
-An C<HTTP::Message> object contains some headers and a content body.
-The following methods are available:
-
-=over 4
-
-=item $mess = HTTP::Message->new
-
-=item $mess = HTTP::Message->new( $headers )
-
-=item $mess = HTTP::Message->new( $headers, $content )
-
-This constructs a new message object. Normally you would want
-construct C<HTTP::Request> or C<HTTP::Response> objects instead.
-
-The optional $header argument should be a reference to an
-C<HTTP::Headers> object or a plain array reference of key/value pairs.
-If an C<HTTP::Headers> object is provided then a copy of it will be
-embedded into the constructed message, i.e. it will not be owned and
-can be modified afterwards without affecting the message.
-
-The optional $content argument should be a string of bytes.
-
-=item $mess = HTTP::Message->parse( $str )
-
-This constructs a new message object by parsing the given string.
-
-=item $mess->headers
-
-Returns the embedded C<HTTP::Headers> object.
-
-=item $mess->headers_as_string
-
-=item $mess->headers_as_string( $eol )
-
-Call the as_string() method for the headers in the
-message. This will be the same as
-
- $mess->headers->as_string
-
-but it will make your program a whole character shorter :-)
-
-=item $mess->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
-original raw content is returned.
-
-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( $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_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( \$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
-is huge, and it can even be used for direct manipulation of the content,
-for instance:
-
- ${$res->content_ref} =~ s/\bfoo\b/bar/g;
-
-This example would modify the content buffer in-place.
-
-If an argument is passed it will setup the content to reference some
-external source. The content() and add_content() methods
-will automatically dereference scalar references passed this way. For
-other references content() will return the reference itself and
-add_content() will refuse to do anything.
-
-=item $mess->content_charset
-
-This returns the charset used by the content in the message. The
-charset is either found as the charset attribute of the
-C<Content-Type> header or by guessing.
-
-See L<http://www.w3.org/TR/REC-html40/charset.html#spec-char-encoding>
-for details about how charset is determined.
-
-=item $mess->decoded_content( %options )
-
-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.
-
-=over
-
-=item C<charset>
-
-This override the charset parameter for text content. The value
-C<none> can used to suppress decoding of the charset.
-
-=item C<default_charset>
-
-This override the default charset guessed by content_charset() or
-if that fails "ISO-8859-1".
-
-=item C<alt_charset>
-
-If decoding fails because the charset specified in the Content-Type header
-isn't recognized by Perl's Encode module, then try decoding using this charset
-instead of failing. The C<alt_charset> might be specified as C<none> to simply
-return the string without any decoding of charset as alternative.
-
-=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 decoded_content() will return
-C<undef> on errors, but will still set $@.
-
-=item C<ref>
-
-If TRUE then a reference to decoded content is returned. This might
-be more efficient in cases where the decoded content is identical to
-the raw content as no data copying is required in this case.
-
-=back
-
-=item $mess->decodable
-
-=item HTTP::Message::decodable()
-
-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->decode
-
-This method tries to replace the content of the message with the
-decoded version and removes the C<Content-Encoding> header. Returns
-TRUE if successful and FALSE if not.
-
-If the message does not have a C<Content-Encoding> header this method
-does nothing and returns TRUE.
-
-Note that the content of the message is still bytes after this method
-has been called and you still need to call decoded_content() if you
-want to process its content as a string.
-
-=item $mess->encode( $encoding, ... )
-
-Apply the given encodings to the content of the message. Returns TRUE
-if successful. The "identity" (non-)encoding is always supported; other
-currently supported encodings, subject to availability of required
-additional modules, are "gzip", "deflate", "x-bzip2" and "base64".
-
-A successful call to this function will set the C<Content-Encoding>
-header.
-
-Note that C<multipart/*> or C<message/*> messages can't be encoded and
-this method will croak if you try.
-
-=item $mess->parts
-
-=item $mess->parts( @parts )
-
-=item $mess->parts( \@parts )
-
-Messages can be composite, i.e. contain other messages. The composite
-messages have a content type of C<multipart/*> or C<message/*>. This
-method give access to the contained messages.
-
-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
-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
-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 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
-should not be modified or made part of other messages.
-
-When updating the message with this method and the old content type of
-$mess is not C<multipart/*> or C<message/*>, then the content type is
-set to C<multipart/mixed> and all other content headers are cleared.
-
-This method will croak if the content type is C<message/*> and more
-than one part is provided.
-
-=item $mess->add_part( $part )
-
-This will add a part to a message. The $part argument should be
-another C<HTTP::Message> object. If the previous content type of
-$mess is not C<multipart/*> then the old content (together with all
-content headers) will be made part #1 and the content type made
-C<multipart/mixed> before the new part is added. The $part object is
-owned by $mess after this call and should not be modified or made part
-of other messages.
-
-There is no return value.
-
-=item $mess->clear
-
-Will clear the headers and set the content to the empty string. There
-is no return value
-
-=item $mess->protocol
-
-=item $mess->protocol( $proto )
-
-Sets the HTTP protocol used for the message. The protocol() is a string
-like C<HTTP/1.0> or C<HTTP/1.1>.
-
-=item $mess->clone
-
-Returns a copy of the message object.
-
-=item $mess->as_string
-
-=item $mess->as_string( $eol )
-
-Returns the message formatted as a single string.
-
-The optional $eol parameter specifies the line ending sequence to use.
-The default is "\n". If no $eol is given then as_string will ensure
-that the returned string is newline terminated (even when the message
-content is not). No extra newline is appended if an explicit $eol is
-passed.
-
-=item $mess->dump( %opt )
-
-Returns the message formatted as a string. In void context print the string.
-
-This differs from C<< $mess->as_string >> in that it escapes the bytes
-of the content so that it's safe to print them and it limits how much
-content to print. The escapes syntax used is the same as for Perl's
-double quoted strings. If there is no content the string "(no
-content)" is shown in its place.
-
-Options to influence the output can be passed as key/value pairs. The
-following options are recognized:
-
-=over
-
-=item maxlength => $num
-
-How much of the content to show. The default is 512. Set this to 0
-for unlimited.
-
-If the content is longer then the string is chopped at the limit and
-the string "...\n(### more bytes not shown)" appended.
-
-=item prefix => $str
-
-A string that will be prefixed to each line of the dump.
-
-=back
-
-=back
-
-All methods unknown to C<HTTP::Message> itself are delegated to the
-C<HTTP::Headers> object that is part of every message. This allows
-convenient access to these methods. Refer to L<HTTP::Headers> for
-details of these methods:
-
- $mess->header( $field => $val )
- $mess->push_header( $field => $val )
- $mess->init_header( $field => $val )
- $mess->remove_header( $field )
- $mess->remove_content_headers
- $mess->header_field_names
- $mess->scan( \&doit )
-
- $mess->date
- $mess->expires
- $mess->if_modified_since
- $mess->if_unmodified_since
- $mess->last_modified
- $mess->content_type
- $mess->content_encoding
- $mess->content_length
- $mess->content_language
- $mess->title
- $mess->user_agent
- $mess->server
- $mess->from
- $mess->referer
- $mess->www_authenticate
- $mess->authorization
- $mess->proxy_authorization
- $mess->authorization_basic
- $mess->proxy_authorization_basic
-
-=head1 COPYRIGHT
-
-Copyright 1995-2004 Gisle Aas.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
+++ /dev/null
-package HTTP::Negotiate;
-
-$VERSION = "5.835";
-sub Version { $VERSION; }
-
-require 5.002;
-require Exporter;
-@ISA = qw(Exporter);
-@EXPORT = qw(choose);
-
-require HTTP::Headers;
-
-$DEBUG = 0;
-
-sub choose ($;$)
-{
- my($variants, $request) = @_;
- my(%accept);
-
- unless (defined $request) {
- # Create a request object from the CGI environment variables
- $request = HTTP::Headers->new;
- $request->header('Accept', $ENV{HTTP_ACCEPT})
- if $ENV{HTTP_ACCEPT};
- $request->header('Accept-Charset', $ENV{HTTP_ACCEPT_CHARSET})
- if $ENV{HTTP_ACCEPT_CHARSET};
- $request->header('Accept-Encoding', $ENV{HTTP_ACCEPT_ENCODING})
- if $ENV{HTTP_ACCEPT_ENCODING};
- $request->header('Accept-Language', $ENV{HTTP_ACCEPT_LANGUAGE})
- if $ENV{HTTP_ACCEPT_LANGUAGE};
- }
-
- # Get all Accept values from the request. Build a hash initialized
- # like this:
- #
- # %accept = ( type => { 'audio/*' => { q => 0.2, mbx => 20000 },
- # 'audio/basic' => { q => 1 },
- # },
- # language => { 'no' => { q => 1 },
- # }
- # );
-
- $request->scan(sub {
- my($key, $val) = @_;
-
- my $type;
- if ($key =~ s/^Accept-//) {
- $type = lc($key);
- }
- elsif ($key eq "Accept") {
- $type = "type";
- }
- else {
- return;
- }
-
- $val =~ s/\s+//g;
- my $default_q = 1;
- for my $name (split(/,/, $val)) {
- my(%param, $param);
- if ($name =~ s/;(.*)//) {
- for $param (split(/;/, $1)) {
- my ($pk, $pv) = split(/=/, $param, 2);
- $param{lc $pk} = $pv;
- }
- }
- $name = lc $name;
- if (defined $param{'q'}) {
- $param{'q'} = 1 if $param{'q'} > 1;
- $param{'q'} = 0 if $param{'q'} < 0;
- }
- else {
- $param{'q'} = $default_q;
-
- # This makes sure that the first ones are slightly better off
- # and therefore more likely to be chosen.
- $default_q -= 0.0001;
- }
- $accept{$type}{$name} = \%param;
- }
- });
-
- # Check if any of the variants specify a language. We do this
- # because it influences how we treat those without (they default to
- # 0.5 instead of 1).
- my $any_lang = 0;
- for $var (@$variants) {
- if ($var->[5]) {
- $any_lang = 1;
- last;
- }
- }
-
- if ($DEBUG) {
- print "Negotiation parameters in the request\n";
- for $type (keys %accept) {
- print " $type:\n";
- for $name (keys %{$accept{$type}}) {
- print " $name\n";
- for $pv (keys %{$accept{$type}{$name}}) {
- print " $pv = $accept{$type}{$name}{$pv}\n";
- }
- }
- }
- }
-
- my @Q = (); # This is where we collect the results of the
- # quality calculations
-
- # Calculate quality for all the variants that are available.
- for (@$variants) {
- my($id, $qs, $ct, $enc, $cs, $lang, $bs) = @$_;
- $qs = 1 unless defined $qs;
- $ct = '' unless defined $ct;
- $bs = 0 unless defined $bs;
- $lang = lc($lang) if $lang; # lg tags are always case-insensitive
- if ($DEBUG) {
- print "\nEvaluating $id (ct='$ct')\n";
- printf " qs = %.3f\n", $qs;
- print " enc = $enc\n" if $enc && !ref($enc);
- print " enc = @$enc\n" if $enc && ref($enc);
- print " cs = $cs\n" if $cs;
- print " lang = $lang\n" if $lang;
- print " bs = $bs\n" if $bs;
- }
-
- # Calculate encoding quality
- my $qe = 1;
- # 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 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
- # field, then the value assigned is "qe=0"
- if (exists $accept{'encoding'} && $enc) {
- my @enc = ref($enc) ? @$enc : ($enc);
- for (@enc) {
- print "Is encoding $_ accepted? " if $DEBUG;
- unless(exists $accept{'encoding'}{$_}) {
- print "no\n" if $DEBUG;
- $qe = 0;
- last;
- }
- else {
- print "yes\n" if $DEBUG;
- }
- }
- }
-
- # Calculate charset quality
- my $qc = 1;
- # 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,
- # then the value assigned is "qc=1. Otherwise, if the variant's
- # charset is not listed in the provided Accept-Encoding field,
- # then the value assigned is "qc=0".
- if (exists $accept{'charset'} && $cs && $cs ne 'us-ascii' ) {
- $qc = 0 unless $accept{'charset'}{$cs};
- }
-
- # Calculate language quality
- my $ql = 1;
- if ($lang && exists $accept{'language'}) {
- 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 largest of the "q" parameter values for those language
- # tags.
- my $q = undef;
- for (@lang) {
- next unless exists $accept{'language'}{$_};
- my $this_q = $accept{'language'}{$_}{'q'};
- $q = $this_q unless defined $q;
- $q = $this_q if $this_q > $q;
- }
- if(defined $q) {
- $DEBUG and print " -- Exact language match at q=$q\n";
- }
- else {
- # If there was no exact match and at least one of
- # the Accept-Language field values is a complete
- # subtag prefix of the content language tag(s), then
- # the "q" parameter value of the largest matching
- # prefix is used.
- $DEBUG and print " -- No exact language match\n";
- my $selected = undef;
- for $al (keys %{ $accept{'language'} }) {
- if (index($al, "$lang-") == 0) {
- # $lang starting with $al isn't enough, or else
- # Accept-Language: hu (Hungarian) would seem
- # to accept a document in hup (Hupa)
- $DEBUG and print " -- $al ISA $lang\n";
- $selected = $al unless defined $selected;
- $selected = $al if length($al) > length($selected);
- }
- else {
- $DEBUG and print " -- $lang isn't a $al\n";
- }
- }
- $q = $accept{'language'}{$selected}{'q'} if $selected;
-
- # If none of the variant's content language tags or
- # tag prefixes are listed in the provided
- # Accept-Language field, then the value assigned
- # is "ql=0.001"
- $q = 0.001 unless defined $q;
- }
- $ql = $q;
- }
- else {
- $ql = 0.5 if $any_lang && exists $accept{'language'};
- }
-
- my $q = 1;
- my $mbx = undef;
- # If no Accept field is given, then the value assigned is "q=1".
- # If at least one listed media range matches the variant's media
- # type, then the "q" parameter value assigned to the most specific
- # of those matched is used (e.g. "text/html;version=3.0" is more
- # specific than "text/html", which is more specific than "text/*",
- # which in turn is more specific than "*/*"). If not media range
- # in the provided Accept field matches the variant's media type,
- # then the value assigned is "q=0".
- if (exists $accept{'type'} && $ct) {
- # First we clean up our content-type
- $ct =~ s/\s+//g;
- my $params = "";
- $params = $1 if $ct =~ s/;(.*)//;
- my($type, $subtype) = split("/", $ct, 2);
- my %param = ();
- for $param (split(/;/, $params)) {
- my($pk,$pv) = split(/=/, $param, 2);
- $param{$pk} = $pv;
- }
-
- my $sel_q = undef;
- my $sel_mbx = undef;
- my $sel_specificness = 0;
-
- ACCEPT_TYPE:
- for $at (keys %{ $accept{'type'} }) {
- print "Consider $at...\n" if $DEBUG;
- my($at_type, $at_subtype) = split("/", $at, 2);
- # Is it a match on the type
- next if $at_type ne '*' && $at_type ne $type;
- next if $at_subtype ne '*' && $at_subtype ne $subtype;
- my $specificness = 0;
- $specificness++ if $at_type ne '*';
- $specificness++ if $at_subtype ne '*';
- # Let's see if content-type parameters also match
- while (($pk, $pv) = each %param) {
- print "Check if $pk = $pv is true\n" if $DEBUG;
- next unless exists $accept{'type'}{$at}{$pk};
- next ACCEPT_TYPE
- unless $accept{'type'}{$at}{$pk} eq $pv;
- print "yes it is!!\n" if $DEBUG;
- $specificness++;
- }
- print "Hurray, type match with specificness = $specificness\n"
- if $DEBUG;
-
- if (!defined($sel_q) || $sel_specificness < $specificness) {
- $sel_q = $accept{'type'}{$at}{'q'};
- $sel_mbx = $accept{'type'}{$at}{'mbx'};
- $sel_specificness = $specificness;
- }
- }
- $q = $sel_q || 0;
- $mbx = $sel_mbx;
- }
-
- my $Q;
- if (!defined($mbx) || $mbx >= $bs) {
- $Q = $qs * $qe * $qc * $ql * $q;
- }
- else {
- $Q = 0;
- print "Variant's size is too large ==> Q=0\n" if $DEBUG;
- }
-
- if ($DEBUG) {
- $mbx = "undef" unless defined $mbx;
- printf "Q=%.4f", $Q;
- print " (q=$q, mbx=$mbx, qe=$qe, qc=$qc, ql=$ql, qs=$qs)\n";
- }
-
- push(@Q, [$id, $Q, $bs]);
- }
-
-
- @Q = sort { $b->[1] <=> $a->[1] || $a->[2] <=> $b->[2] } @Q;
-
- return @Q if wantarray;
- return undef unless @Q;
- return undef if $Q[0][1] == 0;
- $Q[0][0];
-}
-
-1;
-
-__END__
-
-
-=head1 NAME
-
-HTTP::Negotiate - choose a variant to serve
-
-=head1 SYNOPSIS
-
- use HTTP::Negotiate qw(choose);
-
- # ID QS Content-Type Encoding Char-Set Lang Size
- $variants =
- [['var1', 1.000, 'text/html', undef, 'iso-8859-1', 'en', 3000],
- ['var2', 0.950, 'text/plain', 'gzip', 'us-ascii', 'no', 400],
- ['var3', 0.3, 'image/gif', undef, undef, undef, 43555],
- ];
-
- @preferred = choose($variants, $request_headers);
- $the_one = choose($variants);
-
-=head1 DESCRIPTION
-
-This module provides a complete implementation of the HTTP content
-negotiation algorithm specified in F<draft-ietf-http-v11-spec-00.ps>
-chapter 12. Content negotiation allows for the selection of a
-preferred content representation based upon attributes of the
-negotiable variants and the value of the various Accept* header fields
-in the request.
-
-The variants are ordered by preference by calling the function
-choose().
-
-The first parameter is reference to an array of the variants to
-choose among.
-Each element in this array is an array with the values [$id, $qs,
-$content_type, $content_encoding, $charset, $content_language,
-$content_length] whose meanings are described
-below. The $content_encoding and $content_language can be either a
-single scalar value or an array reference if there are several values.
-
-The second optional parameter is either a HTTP::Headers or a HTTP::Request
-object which is searched for "Accept*" headers. If this
-parameter is missing, then the accept specification is initialized
-from the CGI environment variables HTTP_ACCEPT, HTTP_ACCEPT_CHARSET,
-HTTP_ACCEPT_ENCODING and HTTP_ACCEPT_LANGUAGE.
-
-In an array context, choose() returns a list of [variant
-identifier, calculated quality, size] tuples. The values are sorted by
-quality, highest quality first. If the calculated quality is the same
-for two variants, then they are sorted by size (smallest first). I<E.g.>:
-
- (['var1', 1, 2000], ['var2', 0.3, 512], ['var3', 0.3, 1024]);
-
-Note that also zero quality variants are included in the return list
-even if these should never be served to the client.
-
-In a scalar context, it returns the identifier of the variant with the
-highest score or C<undef> if none have non-zero quality.
-
-If the $HTTP::Negotiate::DEBUG variable is set to TRUE, then a lot of
-noise is generated on STDOUT during evaluation of choose().
-
-=head1 VARIANTS
-
-A variant is described by a list of the following values. If the
-attribute does not make sense or is unknown for a variant, then use
-C<undef> instead.
-
-=over 3
-
-=item identifier
-
-This is a string that you use as the name for the variant. This
-identifier for the preferred variants returned by choose().
-
-=item qs
-
-This is a number between 0.000 and 1.000 that describes the "source
-quality". This is what F<draft-ietf-http-v11-spec-00.ps> says about this
-value:
-
-Source quality is measured by the content provider as representing the
-amount of degradation from the original source. For example, a
-picture in JPEG form would have a lower qs when translated to the XBM
-format, and much lower qs when translated to an ASCII-art
-representation. Note, however, that this is a function of the source
-- an original piece of ASCII-art may degrade in quality if it is
-captured in JPEG form. The qs values should be assigned to each
-variant by the content provider; if no qs value has been assigned, the
-default is generally "qs=1".
-
-=item content-type
-
-This is the media type of the variant. The media type does not
-include a charset attribute, but might contain other parameters.
-Examples are:
-
- text/html
- text/html;version=2.0
- text/plain
- image/gif
- image/jpg
-
-=item content-encoding
-
-This is one or more content encodings that has been applied to the
-variant. The content encoding is generally used as a modifier to the
-content media type. The most common content encodings are:
-
- gzip
- compress
-
-=item content-charset
-
-This is the character set used when the variant contains text.
-The charset value should generally be C<undef> or one of these:
-
- us-ascii
- iso-8859-1 ... iso-8859-9
- iso-2022-jp
- iso-2022-jp-2
- iso-2022-kr
- unicode-1-1
- unicode-1-1-utf-7
- unicode-1-1-utf-8
-
-=item content-language
-
-This describes one or more languages that are used in the variant.
-Language is described like this in F<draft-ietf-http-v11-spec-00.ps>: A
-language is in this context a natural language spoken, written, or
-otherwise conveyed by human beings for communication of information to
-other human beings. Computer languages are explicitly excluded.
-
-The language tags are defined by RFC 3066. Examples
-are:
-
- no Norwegian
- en International English
- en-US US English
- en-cockney
-
-=item content-length
-
-This is the number of bytes used to represent the content.
-
-=back
-
-=head1 ACCEPT HEADERS
-
-The following Accept* headers can be used for describing content
-preferences in a request (This description is an edited extract from
-F<draft-ietf-http-v11-spec-00.ps>):
-
-=over 3
-
-=item Accept
-
-This header can be used to indicate a list of media ranges which are
-acceptable as a response to the request. The "*" character is used to
-group media types into ranges, with "*/*" indicating all media types
-and "type/*" indicating all subtypes of that type.
-
-The parameter q is used to indicate the quality factor, which
-represents the user's preference for that range of media types. The
-parameter mbx gives the maximum acceptable size of the response
-content. The default values are: q=1 and mbx=infinity. If no Accept
-header is present, then the client accepts all media types with q=1.
-
-For example:
-
- Accept: audio/*;q=0.2;mbx=200000, audio/basic
-
-would mean: "I prefer audio/basic (of any size), but send me any audio
-type if it is the best available after an 80% mark-down in quality and
-its size is less than 200000 bytes"
-
-
-=item Accept-Charset
-
-Used to indicate what character sets are acceptable for the response.
-The "us-ascii" character set is assumed to be acceptable for all user
-agents. If no Accept-Charset field is given, the default is that any
-charset is acceptable. Example:
-
- Accept-Charset: iso-8859-1, unicode-1-1
-
-
-=item Accept-Encoding
-
-Restricts the Content-Encoding values which are acceptable in the
-response. If no Accept-Encoding field is present, the server may
-assume that the client will accept any content encoding. An empty
-Accept-Encoding means that no content encoding is acceptable. Example:
-
- Accept-Encoding: compress, gzip
-
-
-=item Accept-Language
-
-This field is similar to Accept, but restricts the set of natural
-languages that are preferred in a response. Each language may be
-given an associated quality value which represents an estimate of the
-user's comprehension of that language. For example:
-
- Accept-Language: no, en-gb;q=0.8, de;q=0.55
-
-would mean: "I prefer Norwegian, but will accept British English (with
-80% comprehension) or German (with 55% comprehension).
-
-=back
-
-
-=head1 COPYRIGHT
-
-Copyright 1996,2001 Gisle Aas.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=head1 AUTHOR
-
-Gisle Aas <gisle@aas.no>
-
-=cut
+++ /dev/null
-package HTTP::Request;
-
-require HTTP::Message;
-@ISA = qw(HTTP::Message);
-$VERSION = "5.827";
-
-use strict;
-
-
-
-sub new
-{
- my($class, $method, $uri, $header, $content) = @_;
- my $self = $class->SUPER::new($header, $content);
- $self->method($method);
- $self->uri($uri);
- $self;
-}
-
-
-sub parse
-{
- my($class, $str) = @_;
- my $request_line;
- if ($str =~ s/^(.*)\n//) {
- $request_line = $1;
- }
- else {
- $request_line = $str;
- $str = "";
- }
-
- my $self = $class->SUPER::parse($str);
- my($method, $uri, $protocol) = split(' ', $request_line);
- $self->method($method) if defined($method);
- $self->uri($uri) if defined($uri);
- $self->protocol($protocol) if $protocol;
- $self;
-}
-
-
-sub clone
-{
- my $self = shift;
- my $clone = bless $self->SUPER::clone, ref($self);
- $clone->method($self->method);
- $clone->uri($self->uri);
- $clone;
-}
-
-
-sub method
-{
- shift->_elem('_method', @_);
-}
-
-
-sub uri
-{
- my $self = shift;
- my $old = $self->{'_uri'};
- if (@_) {
- my $uri = shift;
- if (!defined $uri) {
- # that's ok
- }
- elsif (ref $uri) {
- Carp::croak("A URI can't be a " . ref($uri) . " reference")
- if ref($uri) eq 'HASH' or ref($uri) eq 'ARRAY';
- Carp::croak("Can't use a " . ref($uri) . " object as a URI")
- unless $uri->can('scheme');
- $uri = $uri->clone;
- unless ($HTTP::URI_CLASS eq "URI") {
- # Argh!! Hate this... old LWP legacy!
- eval { local $SIG{__DIE__}; $uri = $uri->abs; };
- die $@ if $@ && $@ !~ /Missing base argument/;
- }
- }
- else {
- $uri = $HTTP::URI_CLASS->new($uri);
- }
- $self->{'_uri'} = $uri;
- delete $self->{'_uri_canonical'};
- }
- $old;
-}
-
-*url = \&uri; # legacy
-
-sub uri_canonical
-{
- my $self = shift;
- return $self->{'_uri_canonical'} ||= $self->{'_uri'}->canonical;
-}
-
-
-sub accept_decodable
-{
- my $self = shift;
- $self->header("Accept-Encoding", scalar($self->decodable));
-}
-
-sub as_string
-{
- my $self = shift;
- my($eol) = @_;
- $eol = "\n" unless defined $eol;
-
- my $req_line = $self->method || "-";
- my $uri = $self->uri;
- $uri = (defined $uri) ? $uri->as_string : "-";
- $req_line .= " $uri";
- my $proto = $self->protocol;
- $req_line .= " $proto" if $proto;
-
- return join($eol, $req_line, $self->SUPER::as_string(@_));
-}
-
-sub dump
-{
- my $self = shift;
- my @pre = ($self->method || "-", $self->uri || "-");
- if (my $prot = $self->protocol) {
- push(@pre, $prot);
- }
-
- return $self->SUPER::dump(
- preheader => join(" ", @pre),
- @_,
- );
-}
-
-
-1;
-
-__END__
-
-=head1 NAME
-
-HTTP::Request - HTTP style request message
-
-=head1 SYNOPSIS
-
- require HTTP::Request;
- $request = HTTP::Request->new(GET => 'http://www.example.com/');
-
-and usually used like this:
-
- $ua = LWP::UserAgent->new;
- $response = $ua->request($request);
-
-=head1 DESCRIPTION
-
-C<HTTP::Request> is a class encapsulating HTTP style requests,
-consisting of a request line, some headers, and a content body. Note
-that the LWP library uses HTTP style requests even for non-HTTP
-protocols. Instances of this class are usually passed to the
-request() method of an C<LWP::UserAgent> object.
-
-C<HTTP::Request> is a subclass of C<HTTP::Message> and therefore
-inherits its methods. The following additional methods are available:
-
-=over 4
-
-=item $r = HTTP::Request->new( $method, $uri )
-
-=item $r = HTTP::Request->new( $method, $uri, $header )
-
-=item $r = HTTP::Request->new( $method, $uri, $header, $content )
-
-Constructs a new C<HTTP::Request> object describing a request on the
-object $uri using method $method. The $method argument must be a
-string. The $uri argument can be either a string, or a reference to a
-C<URI> object. The optional $header argument should be a reference to
-an C<HTTP::Headers> object or a plain array reference of key/value
-pairs. The optional $content argument should be a string of bytes.
-
-=item $r = HTTP::Request->parse( $str )
-
-This constructs a new request object by parsing the given string.
-
-=item $r->method
-
-=item $r->method( $val )
-
-This is used to get/set the method attribute. The method should be a
-short string like "GET", "HEAD", "PUT" or "POST".
-
-=item $r->uri
-
-=item $r->uri( $val )
-
-This is used to get/set the uri attribute. The $val can be a
-reference to a URI object or a plain string. If a string is given,
-then it should be parseable as an absolute URI.
-
-=item $r->header( $field )
-
-=item $r->header( $field => $value )
-
-This is used to get/set header values and it is inherited from
-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( $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
-other methods that can be used to access the content.
-
-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 $r->as_string
-
-=item $r->as_string( $eol )
-
-Method returning a textual representation of the request.
-
-=back
-
-=head1 SEE ALSO
-
-L<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Request::Common>,
-L<HTTP::Response>
-
-=head1 COPYRIGHT
-
-Copyright 1995-2004 Gisle Aas.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
+++ /dev/null
-package HTTP::Request::Common;
-
-use strict;
-use vars qw(@EXPORT @EXPORT_OK $VERSION $DYNAMIC_FILE_UPLOAD);
-
-$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 DELETE);
-
-require HTTP::Request;
-use Carp();
-
-$VERSION = "5.824";
-
-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
-{
- my $url = shift;
- my $req = HTTP::Request->new(POST => $url);
- my $content;
- $content = shift if @_ and ref $_[0];
- my($k, $v);
- while (($k,$v) = splice(@_, 0, 2)) {
- if (lc($k) eq 'content') {
- $content = $v;
- }
- else {
- $req->push_header($k, $v);
- }
- }
- my $ct = $req->header('Content-Type');
- unless ($ct) {
- $ct = 'application/x-www-form-urlencoded';
- }
- elsif ($ct eq 'form-data') {
- $ct = 'multipart/form-data';
- }
-
- if (ref $content) {
- if ($ct =~ m,^multipart/form-data\s*(;|$),i) {
- require HTTP::Headers::Util;
- my @v = HTTP::Headers::Util::split_header_words($ct);
- Carp::carp("Multiple Content-Type headers") if @v > 1;
- @v = @{$v[0]};
-
- my $boundary;
- my $boundary_index;
- for (my @tmp = @v; @tmp;) {
- my($k, $v) = splice(@tmp, 0, 2);
- if ($k eq "boundary") {
- $boundary = $v;
- $boundary_index = @v - @tmp - 1;
- last;
- }
- }
-
- ($content, $boundary) = form_data($content, $boundary, $req);
-
- if ($boundary_index) {
- $v[$boundary_index] = $boundary;
- }
- else {
- push(@v, boundary => $boundary);
- }
-
- $ct = HTTP::Headers::Util::join_header_words(@v);
- }
- else {
- # We use a temporary URI object to format
- # the application/x-www-form-urlencoded content.
- require URI;
- my $url = URI->new('http:');
- $url->query_form(ref($content) eq "HASH" ? %$content : @$content);
- $content = $url->query;
- }
- }
-
- $req->header('Content-Type' => $ct); # might be redundant
- if (defined($content)) {
- $req->header('Content-Length' =>
- length($content)) unless ref($content);
- $req->content($content);
- }
- else {
- $req->header('Content-Length' => 0);
- }
- $req;
-}
-
-
-sub _simple_req
-{
- my($method, $url) = splice(@_, 0, 2);
- my $req = HTTP::Request->new($method => $url);
- my($k, $v);
- my $content;
- while (($k,$v) = splice(@_, 0, 2)) {
- if (lc($k) eq 'content') {
- $req->add_content($v);
- $content++;
- }
- else {
- $req->push_header($k, $v);
- }
- }
- if ($content && !defined($req->header("Content-Length"))) {
- $req->header("Content-Length", length(${$req->content_ref}));
- }
- $req;
-}
-
-
-sub form_data # RFC1867
-{
- my($data, $boundary, $req) = @_;
- my @data = ref($data) eq "HASH" ? %$data : @$data; # copy
- my $fhparts;
- my @parts;
- my($k,$v);
- while (($k,$v) = splice(@data, 0, 2)) {
- if (!ref($v)) {
- $k =~ s/([\\\"])/\\$1/g; # escape quotes and backslashes
- push(@parts,
- qq(Content-Disposition: form-data; name="$k"$CRLF$CRLF$v));
- }
- else {
- my($file, $usename, @headers) = @$v;
- unless (defined $usename) {
- $usename = $file;
- $usename =~ s,.*/,, if defined($usename);
- }
- $k =~ s/([\\\"])/\\$1/g;
- my $disp = qq(form-data; name="$k");
- if (defined($usename) and length($usename)) {
- $usename =~ s/([\\\"])/\\$1/g;
- $disp .= qq(; filename="$usename");
- }
- my $content = "";
- my $h = HTTP::Headers->new(@headers);
- if ($file) {
- open(my $fh, "<", $file) or Carp::croak("Can't open file $file: $!");
- binmode($fh);
- if ($DYNAMIC_FILE_UPLOAD) {
- # will read file later, close it now in order to
- # not accumulate to many open file handles
- close($fh);
- $content = \$file;
- }
- else {
- local($/) = undef; # slurp files
- $content = <$fh>;
- close($fh);
- }
- unless ($h->header("Content-Type")) {
- require LWP::MediaTypes;
- LWP::MediaTypes::guess_media_type($file, $h);
- }
- }
- if ($h->header("Content-Disposition")) {
- # just to get it sorted first
- $disp = $h->header("Content-Disposition");
- $h->remove_header("Content-Disposition");
- }
- if ($h->header("Content")) {
- $content = $h->header("Content");
- $h->remove_header("Content");
- }
- my $head = join($CRLF, "Content-Disposition: $disp",
- $h->as_string($CRLF),
- "");
- if (ref $content) {
- push(@parts, [$head, $$content]);
- $fhparts++;
- }
- else {
- push(@parts, $head . $content);
- }
- }
- }
- return ("", "none") unless @parts;
-
- my $content;
- if ($fhparts) {
- $boundary = boundary(10) # hopefully enough randomness
- unless $boundary;
-
- # add the boundaries to the @parts array
- for (1..@parts-1) {
- splice(@parts, $_*2-1, 0, "$CRLF--$boundary$CRLF");
- }
- unshift(@parts, "--$boundary$CRLF");
- push(@parts, "$CRLF--$boundary--$CRLF");
-
- # See if we can generate Content-Length header
- my $length = 0;
- for (@parts) {
- if (ref $_) {
- my ($head, $f) = @$_;
- my $file_size;
- unless ( -f $f && ($file_size = -s _) ) {
- # The file is either a dynamic file like /dev/audio
- # or perhaps a file in the /proc file system where
- # stat may return a 0 size even though reading it
- # will produce data. So we cannot make
- # a Content-Length header.
- undef $length;
- last;
- }
- $length += $file_size + length $head;
- }
- else {
- $length += length;
- }
- }
- $length && $req->header('Content-Length' => $length);
-
- # set up a closure that will return content piecemeal
- $content = sub {
- for (;;) {
- unless (@parts) {
- defined $length && $length != 0 &&
- Carp::croak "length of data sent did not match calculated Content-Length header. Probably because uploaded file changed in size during transfer.";
- return;
- }
- my $p = shift @parts;
- unless (ref $p) {
- $p .= shift @parts while @parts && !ref($parts[0]);
- defined $length && ($length -= length $p);
- return $p;
- }
- my($buf, $fh) = @$p;
- unless (ref($fh)) {
- my $file = $fh;
- undef($fh);
- open($fh, "<", $file) || Carp::croak("Can't open file $file: $!");
- binmode($fh);
- }
- my $buflength = length $buf;
- my $n = read($fh, $buf, 2048, $buflength);
- if ($n) {
- $buflength += $n;
- unshift(@parts, ["", $fh]);
- }
- else {
- close($fh);
- }
- if ($buflength) {
- defined $length && ($length -= $buflength);
- return $buf
- }
- }
- };
-
- }
- else {
- $boundary = boundary() unless $boundary;
-
- my $bno = 0;
- CHECK_BOUNDARY:
- {
- for (@parts) {
- if (index($_, $boundary) >= 0) {
- # must have a better boundary
- $boundary = boundary(++$bno);
- redo CHECK_BOUNDARY;
- }
- }
- last;
- }
- $content = "--$boundary$CRLF" .
- join("$CRLF--$boundary$CRLF", @parts) .
- "$CRLF--$boundary--$CRLF";
- }
-
- wantarray ? ($content, $boundary) : $content;
-}
-
-
-sub boundary
-{
- my $size = shift || return "xYzZY";
- require MIME::Base64;
- my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), "");
- $b =~ s/[\W]/X/g; # ensure alnum only
- $b;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-HTTP::Request::Common - Construct common HTTP::Request objects
-
-=head1 SYNOPSIS
-
- use HTTP::Request::Common;
- $ua = LWP::UserAgent->new;
- $ua->request(GET 'http://www.sn.no/');
- $ua->request(POST 'http://somewhere/foo', [foo => bar, bar => foo]);
-
-=head1 DESCRIPTION
-
-This module provide functions that return newly created C<HTTP::Request>
-objects. These functions are usually more convenient to use than the
-standard C<HTTP::Request> constructor for the most common requests. The
-following functions are provided:
-
-=over 4
-
-=item GET $url
-
-=item GET $url, Header => Value,...
-
-The GET() function returns an C<HTTP::Request> object initialized with
-the "GET" method and the specified URL. It is roughly equivalent to the
-following call
-
- HTTP::Request->new(
- GET => $url,
- HTTP::Headers->new(Header => Value,...),
- )
-
-but is less cluttered. What is different is that a header named
-C<Content> will initialize the content part of the request instead of
-setting a header field. Note that GET requests should normally not
-have a content, so this hack makes more sense for the PUT() and POST()
-functions described below.
-
-The get(...) method of C<LWP::UserAgent> exists as a shortcut for
-$ua->request(GET ...).
-
-=item HEAD $url
-
-=item HEAD $url, Header => Value,...
-
-Like GET() but the method in the request is "HEAD".
-
-The head(...) method of "LWP::UserAgent" exists as a shortcut for
-$ua->request(HEAD ...).
-
-=item PUT $url
-
-=item PUT $url, Header => Value,...
-
-=item PUT $url, Header => Value,..., Content => $content
-
-Like GET() but the method in the request is "PUT".
-
-The content of the request can be specified using the "Content"
-pseudo-header. This steals a bit of the header field namespace as
-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 function
-is not exported by default.
-
-=item POST $url
-
-=item POST $url, Header => Value,...
-
-=item POST $url, $form_ref, Header => Value,...
-
-=item POST $url, Header => Value,..., Content => $form_ref
-
-=item POST $url, Header => Value,..., Content => $content
-
-This works mostly like PUT() with "POST" as the method, but this
-function also takes a second optional array or hash reference
-parameter $form_ref. As for PUT() the content can also be specified
-directly using the "Content" pseudo-header, and you may also provide
-the $form_ref this way.
-
-The $form_ref argument can be used to pass key/value pairs for the
-form content. By default we will initialize a request using the
-C<application/x-www-form-urlencoded> content type. This means that
-you can emulate a HTML E<lt>form> POSTing like this:
-
- POST 'http://www.perl.org/survey.cgi',
- [ name => 'Gisle Aas',
- email => 'gisle@aas.no',
- gender => 'M',
- born => '1964',
- perc => '3%',
- ];
-
-This will create a HTTP::Request object that looks like this:
-
- POST http://www.perl.org/survey.cgi
- Content-Length: 66
- Content-Type: application/x-www-form-urlencoded
-
- name=Gisle%20Aas&email=gisle%40aas.no&gender=M&born=1964&perc=3%25
-
-Multivalued form fields can be specified by either repeating the field
-name or by passing the value as an array reference.
-
-The POST method also supports the C<multipart/form-data> content used
-for I<Form-based File Upload> as specified in RFC 1867. You trigger
-this content format by specifying a content type of C<'form-data'> as
-one of the request headers. If one of the values in the $form_ref is
-an array reference, then it is treated as a file part specification
-with the following interpretation:
-
- [ $file, $filename, Header => Value... ]
- [ undef, $filename, Header => Value,..., Content => $content ]
-
-The first value in the array ($file) is the name of a file to open.
-This file will be read and its content placed in the request. The
-routine will croak if the file can't be opened. Use an C<undef> as
-$file value if you want to specify the content directly with a
-C<Content> header. The $filename is the filename to report in the
-request. If this value is undefined, then the basename of the $file
-will be used. You can specify an empty string as $filename if you
-want to suppress sending the filename when you provide a $file value.
-
-If a $file is provided by no C<Content-Type> header, then C<Content-Type>
-and C<Content-Encoding> will be filled in automatically with the values
-returned by LWP::MediaTypes::guess_media_type()
-
-Sending my F<~/.profile> to the survey used as example above can be
-achieved by this:
-
- POST 'http://www.perl.org/survey.cgi',
- Content_Type => 'form-data',
- Content => [ name => 'Gisle Aas',
- email => 'gisle@aas.no',
- gender => 'M',
- born => '1964',
- init => ["$ENV{HOME}/.profile"],
- ]
-
-This will create a HTTP::Request object that almost looks this (the
-boundary and the content of your F<~/.profile> is likely to be
-different):
-
- POST http://www.perl.org/survey.cgi
- Content-Length: 388
- Content-Type: multipart/form-data; boundary="6G+f"
-
- --6G+f
- Content-Disposition: form-data; name="name"
-
- Gisle Aas
- --6G+f
- Content-Disposition: form-data; name="email"
-
- gisle@aas.no
- --6G+f
- Content-Disposition: form-data; name="gender"
-
- M
- --6G+f
- Content-Disposition: form-data; name="born"
-
- 1964
- --6G+f
- Content-Disposition: form-data; name="init"; filename=".profile"
- Content-Type: text/plain
-
- PATH=/local/perl/bin:$PATH
- export PATH
-
- --6G+f--
-
-If you set the $DYNAMIC_FILE_UPLOAD variable (exportable) to some TRUE
-value, then you get back a request object with a subroutine closure as
-the content attribute. This subroutine will read the content of any
-files on demand and return it in suitable chunks. This allow you to
-upload arbitrary big files without using lots of memory. You can even
-upload infinite files like F</dev/audio> if you wish; however, if
-the file is not a plain file, there will be no Content-Length header
-defined for the request. Not all servers (or server
-applications) like this. Also, if the file(s) change in size between
-the time the Content-Length is calculated and the time that the last
-chunk is delivered, the subroutine will C<Croak>.
-
-The post(...) method of "LWP::UserAgent" exists as a shortcut for
-$ua->request(POST ...).
-
-=back
-
-=head1 SEE ALSO
-
-L<HTTP::Request>, L<LWP::UserAgent>
-
-
-=head1 COPYRIGHT
-
-Copyright 1997-2004, Gisle Aas
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=cut
-
+++ /dev/null
-package HTTP::Response;
-
-require HTTP::Message;
-@ISA = qw(HTTP::Message);
-$VERSION = "5.836";
-
-use strict;
-use HTTP::Status ();
-
-
-
-sub new
-{
- my($class, $rc, $msg, $header, $content) = @_;
- my $self = $class->SUPER::new($header, $content);
- $self->code($rc);
- $self->message($msg);
- $self;
-}
-
-
-sub parse
-{
- my($class, $str) = @_;
- my $status_line;
- if ($str =~ s/^(.*)\n//) {
- $status_line = $1;
- }
- else {
- $status_line = $str;
- $str = "";
- }
-
- my $self = $class->SUPER::parse($str);
- my($protocol, $code, $message);
- if ($status_line =~ /^\d{3} /) {
- # Looks like a response created by HTTP::Response->new
- ($code, $message) = split(' ', $status_line, 2);
- } else {
- ($protocol, $code, $message) = split(' ', $status_line, 3);
- }
- $self->protocol($protocol) if $protocol;
- $self->code($code) if defined($code);
- $self->message($message) if defined($message);
- $self;
-}
-
-
-sub clone
-{
- my $self = shift;
- my $clone = bless $self->SUPER::clone, ref($self);
- $clone->code($self->code);
- $clone->message($self->message);
- $clone->request($self->request->clone) if $self->request;
- # we don't clone previous
- $clone;
-}
-
-
-sub code { shift->_elem('_rc', @_); }
-sub message { shift->_elem('_msg', @_); }
-sub previous { shift->_elem('_previous',@_); }
-sub request { shift->_elem('_request', @_); }
-
-
-sub status_line
-{
- my $self = shift;
- my $code = $self->{'_rc'} || "000";
- my $mess = $self->{'_msg'} || HTTP::Status::status_message($code) || "Unknown code";
- return "$code $mess";
-}
-
-
-sub base
-{
- my $self = shift;
- my $base = (
- $self->header('Content-Base'), # used to be HTTP/1.1
- $self->header('Content-Location'), # HTTP/1.1
- $self->header('Base'), # HTTP/1.0
- )[0];
- if ($base && $base =~ /^$URI::scheme_re:/o) {
- # already absolute
- return $HTTP::URI_CLASS->new($base);
- }
-
- my $req = $self->request;
- if ($req) {
- # if $base is undef here, the return value is effectively
- # just a copy of $self->request->uri.
- return $HTTP::URI_CLASS->new_abs($base, $req->uri);
- }
-
- # can't find an absolute base
- return undef;
-}
-
-
-sub redirects {
- my $self = shift;
- my @r;
- my $r = $self;
- while (my $p = $r->previous) {
- push(@r, $p);
- $r = $p;
- }
- return @r unless wantarray;
- return reverse @r;
-}
-
-
-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 $@;
- }
- }
- }
- }
-
- unless (defined($file) && length($file)) {
- my $uri;
- 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;
- my $self = shift;
- my($eol) = @_;
- $eol = "\n" unless defined $eol;
-
- my $status_line = $self->status_line;
- my $proto = $self->protocol;
- $status_line = "$proto $status_line" if $proto;
-
- return join($eol, $status_line, $self->SUPER::as_string(@_));
-}
-
-
-sub dump
-{
- my $self = shift;
-
- my $status_line = $self->status_line;
- my $proto = $self->protocol;
- $status_line = "$proto $status_line" if $proto;
-
- return $self->SUPER::dump(
- preheader => $status_line,
- @_,
- );
-}
-
-
-sub is_info { HTTP::Status::is_info (shift->{'_rc'}); }
-sub is_success { HTTP::Status::is_success (shift->{'_rc'}); }
-sub is_redirect { HTTP::Status::is_redirect (shift->{'_rc'}); }
-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 = HTML::Entities::encode($self->status_line);
- return <<EOM;
-<html>
-<head><title>$title</title></head>
-<body>
-<h1>$title</h1>
-<p>$body</p>
-</body>
-</html>
-EOM
-}
-
-
-sub current_age
-{
- my $self = shift;
- my $time = shift;
-
- # Implementation of RFC 2616 section 13.2.3
- # (age calculations)
- my $response_time = $self->client_date;
- my $date = $self->date;
-
- my $age = 0;
- if ($response_time && $date) {
- $age = $response_time - $date; # apparent_age
- $age = 0 if $age < 0;
- }
-
- my $age_v = $self->header('Age');
- if ($age_v && $age_v > $age) {
- $age = $age_v; # corrected_received_age
- }
-
- if ($response_time) {
- my $request = $self->request;
- if ($request) {
- my $request_time = $request->date;
- if ($request_time && $request_time < $response_time) {
- # Add response_delay to age to get 'corrected_initial_age'
- $age += $response_time - $request_time;
- }
- }
- $age += ($time || time) - $response_time;
- }
- return $age;
-}
-
-
-sub freshness_lifetime
-{
- my($self, %opt) = @_;
-
- # First look for the Cache-Control: max-age=n header
- for my $cc ($self->header('Cache-Control')) {
- for my $cc_dir (split(/\s*,\s*/, $cc)) {
- return $1 if $cc_dir =~ /^max-age\s*=\s*(\d+)/i;
- }
- }
-
- # Next possibility is to look at the "Expires" header
- my $date = $self->date || $self->client_date || $opt{time} || time;
- if (my $expires = $self->expires) {
- return $expires - $date;
- }
-
- # Must apply heuristic expiration
- return undef if exists $opt{heuristic_expiry} && !$opt{heuristic_expiry};
-
- # Default heuristic expiration parameters
- $opt{h_min} ||= 60;
- $opt{h_max} ||= 24 * 3600;
- $opt{h_lastmod_fraction} ||= 0.10; # 10% since last-mod suggested by RFC2616
- $opt{h_default} ||= 3600;
-
- # Should give a warning if more than 24 hours according to
- # RFC 2616 section 13.2.4. Here we just make this the default
- # maximum value.
-
- if (my $last_modified = $self->last_modified) {
- my $h_exp = ($date - $last_modified) * $opt{h_lastmod_fraction};
- return $opt{h_min} if $h_exp < $opt{h_min};
- return $opt{h_max} if $h_exp > $opt{h_max};
- return $h_exp;
- }
-
- # default when all else fails
- return $opt{h_min} if $opt{h_min} > $opt{h_default};
- return $opt{h_default};
-}
-
-
-sub is_fresh
-{
- my($self, %opt) = @_;
- $opt{time} ||= time;
- my $f = $self->freshness_lifetime(%opt);
- return undef unless defined($f);
- return $f > $self->current_age($opt{time});
-}
-
-
-sub fresh_until
-{
- my($self, %opt) = @_;
- $opt{time} ||= time;
- my $f = $self->freshness_lifetime(%opt);
- return undef unless defined($f);
- return $f - $self->current_age($opt{time}) + $opt{time};
-}
-
-1;
-
-
-__END__
-
-=head1 NAME
-
-HTTP::Response - HTTP style response message
-
-=head1 SYNOPSIS
-
-Response objects are returned by the request() method of the C<LWP::UserAgent>:
-
- # ...
- $response = $ua->request($request)
- if ($response->is_success) {
- print $response->decoded_content;
- }
- else {
- print STDERR $response->status_line, "\n";
- }
-
-=head1 DESCRIPTION
-
-The C<HTTP::Response> class encapsulates HTTP style responses. A
-response consists of a response line, some headers, and a content
-body. Note that the LWP library uses HTTP style responses even for
-non-HTTP protocol schemes. Instances of this class are usually
-created and returned by the request() method of an C<LWP::UserAgent>
-object.
-
-C<HTTP::Response> is a subclass of C<HTTP::Message> and therefore
-inherits its methods. The following additional methods are available:
-
-=over 4
-
-=item $r = HTTP::Response->new( $code )
-
-=item $r = HTTP::Response->new( $code, $msg )
-
-=item $r = HTTP::Response->new( $code, $msg, $header )
-
-=item $r = HTTP::Response->new( $code, $msg, $header, $content )
-
-Constructs a new C<HTTP::Response> object describing a response with
-response code $code and optional message $msg. The optional $header
-argument should be a reference to an C<HTTP::Headers> object or a
-plain array reference of key/value pairs. The optional $content
-argument should be a string of bytes. The meaning these arguments are
-described below.
-
-=item $r = HTTP::Response->parse( $str )
-
-This constructs a new response object by parsing the given string.
-
-=item $r->code
-
-=item $r->code( $code )
-
-This is used to get/set the code attribute. The code is a 3 digit
-number that encode the overall outcome of a HTTP response. The
-C<HTTP::Status> module provide constants that provide mnemonic names
-for the code attribute.
-
-=item $r->message
-
-=item $r->message( $message )
-
-This is used to get/set the message attribute. The message is a short
-human readable single line string that explains the response code.
-
-=item $r->header( $field )
-
-=item $r->header( $field => $value )
-
-This is used to get/set header values and it is inherited from
-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->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
-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 have been decoded. See L<HTTP::Message> for details.
-
-=item $r->request
-
-=item $r->request( $request )
-
-This is used to get/set the request attribute. The request attribute
-is a reference to the the request that caused this response. It does
-not have to be the same request passed to the $ua->request() method,
-because there might have been redirects and authorization retries in
-between.
-
-=item $r->previous
-
-=item $r->previous( $response )
-
-This is used to get/set the previous attribute. The previous
-attribute is used to link together chains of responses. You get
-chains of responses if the first response is redirect or unauthorized.
-The value is C<undef> if this is the first response in a chain.
-
-Note that the method $r->redirects is provided as a more convenient
-way to access the response chain.
-
-=item $r->status_line
-
-Returns the string "E<lt>code> E<lt>message>". If the message attribute
-is not set then the official name of E<lt>code> (see L<HTTP::Status>)
-is substituted.
-
-=item $r->base
-
-Returns the base URI for this response. The return value will be a
-reference to a URI object.
-
-The base URI is obtained from one the following sources (in priority
-order):
-
-=over 4
-
-=item 1.
-
-Embedded in the document content, for instance <BASE HREF="...">
-in HTML documents.
-
-=item 2.
-
-A "Content-Base:" or a "Content-Location:" header in the response.
-
-For backwards compatibility with older HTTP implementations we will
-also look for the "Base:" header.
-
-=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 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
-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 )
-
-Returns a textual representation of the response.
-
-=item $r->is_info
-
-=item $r->is_success
-
-=item $r->is_redirect
-
-=item $r->is_error
-
-These methods indicate if the response was informational, successful, a
-redirection, or an error. See L<HTTP::Status> for the meaning of these.
-
-=item $r->error_as_HTML
-
-Returns a string containing a complete HTML document indicating what
-error occurred. This method should only be called when $r->is_error
-is TRUE.
-
-=item $r->redirects
-
-Returns the list of redirect responses that lead up to this response
-by following the $r->previous chain. The list order is oldest first.
-
-In scalar context return the number of redirect responses leading up
-to this one.
-
-=item $r->current_age
-
-Calculates the "current age" of the response as specified by RFC 2616
-section 13.2.3. The age of a response is the time since it was sent
-by the origin server. The returned value is a number representing the
-age in seconds.
-
-=item $r->freshness_lifetime( %opt )
-
-Calculates the "freshness lifetime" of the response as specified by
-RFC 2616 section 13.2.4. The "freshness lifetime" is the length of
-time between the generation of a response and its expiration time.
-The returned value is the number of seconds until expiry.
-
-If the response does not contain an "Expires" or a "Cache-Control"
-header, then this function will apply some simple heuristic based on
-the "Last-Modified" header to determine a suitable lifetime. The
-following options might be passed to control the heuristics:
-
-=over
-
-=item heuristic_expiry => $bool
-
-If passed as a FALSE value, don't apply heuristics and just return
-C<undef> when "Expires" or "Cache-Control" is lacking.
-
-=item h_lastmod_fraction => $num
-
-This number represent the fraction of the difference since the
-"Last-Modified" timestamp to make the expiry time. The default is
-C<0.10>, the suggested typical setting of 10% in RFC 2616.
-
-=item h_min => $sec
-
-This is the lower limit of the heuristic expiry age to use. The
-default is C<60> (1 minute).
-
-=item h_max => $sec
-
-This is the upper limit of the heuristic expiry age to use. The
-default is C<86400> (24 hours).
-
-=item h_default => $sec
-
-This is the expiry age to use when nothing else applies. The default
-is C<3600> (1 hour) or "h_min" if greater.
-
-=back
-
-=item $r->is_fresh( %opt )
-
-Returns TRUE if the response is fresh, based on the values of
-freshness_lifetime() and current_age(). If the response is no longer
-fresh, then it has to be re-fetched or re-validated by the origin
-server.
-
-Options might be passed to control expiry heuristics, see the
-description of freshness_lifetime().
-
-=item $r->fresh_until( %opt )
-
-Returns the time (seconds since epoch) when this entity is no longer fresh.
-
-Options might be passed to control expiry heuristics, see the
-description of freshness_lifetime().
-
-=back
-
-=head1 SEE ALSO
-
-L<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Status>, L<HTTP::Request>
-
-=head1 COPYRIGHT
-
-Copyright 1995-2004 Gisle Aas.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
+++ /dev/null
-package HTTP::Status;
-
-use strict;
-require 5.002; # because we use prototypes
-
-use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
-
-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 = "5.817";
-
-# 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', # RFC 2518 (WebDAV)
- 200 => 'OK',
- 201 => 'Created',
- 202 => 'Accepted',
- 203 => 'Non-Authoritative Information',
- 204 => 'No Content',
- 205 => 'Reset Content',
- 206 => 'Partial Content',
- 207 => 'Multi-Status', # RFC 2518 (WebDAV)
- 300 => 'Multiple Choices',
- 301 => 'Moved Permanently',
- 302 => 'Found',
- 303 => 'See Other',
- 304 => 'Not Modified',
- 305 => 'Use Proxy',
- 307 => 'Temporary Redirect',
- 400 => 'Bad Request',
- 401 => 'Unauthorized',
- 402 => 'Payment Required',
- 403 => 'Forbidden',
- 404 => 'Not Found',
- 405 => 'Method Not Allowed',
- 406 => 'Not Acceptable',
- 407 => 'Proxy Authentication Required',
- 408 => 'Request Timeout',
- 409 => 'Conflict',
- 410 => 'Gone',
- 411 => 'Length Required',
- 412 => 'Precondition Failed',
- 413 => 'Request Entity Too Large',
- 414 => 'Request-URI Too Large',
- 415 => 'Unsupported Media Type',
- 416 => 'Request Range Not Satisfiable',
- 417 => 'Expectation Failed',
- 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',
- 506 => 'Variant Also Negotiates', # RFC 2295
- 507 => 'Insufficient Storage', # RFC 2518 (WebDAV)
- 509 => 'Bandwidth Limit Exceeded', # unofficial
- 510 => 'Not Extended', # RFC 2774
-);
-
-my $mnemonicCode = '';
-my ($code, $message);
-while (($code, $message) = each %StatusCode) {
- # create mnemonic subroutines
- $message =~ tr/a-z \-/A-Z__/;
- $mnemonicCode .= "sub HTTP_$message () { $code }\n";
- $mnemonicCode .= "*RC_$message = \\&HTTP_$message;\n"; # legacy
- $mnemonicCode .= "push(\@EXPORT_OK, 'HTTP_$message');\n";
- $mnemonicCode .= "push(\@EXPORT, 'RC_$message');\n";
-}
-eval $mnemonicCode; # only one eval for speed
-die if $@;
-
-# backwards compatibility
-*RC_MOVED_TEMPORARILY = \&RC_FOUND; # 302 was renamed in the standard
-push(@EXPORT, "RC_MOVED_TEMPORARILY");
-
-%EXPORT_TAGS = (
- constants => [grep /^HTTP_/, @EXPORT_OK],
- is => [grep /^is_/, @EXPORT, @EXPORT_OK],
-);
-
-
-sub status_message ($) { $StatusCode{$_[0]}; }
-
-sub is_info ($) { $_[0] >= 100 && $_[0] < 200; }
-sub is_success ($) { $_[0] >= 200 && $_[0] < 300; }
-sub is_redirect ($) { $_[0] >= 300 && $_[0] < 400; }
-sub is_error ($) { $_[0] >= 400 && $_[0] < 600; }
-sub is_client_error ($) { $_[0] >= 400 && $_[0] < 500; }
-sub is_server_error ($) { $_[0] >= 500 && $_[0] < 600; }
-
-1;
-
-
-__END__
-
-=head1 NAME
-
-HTTP::Status - HTTP Status code processing
-
-=head1 SYNOPSIS
-
- use HTTP::Status qw(:constants :is status_message);
-
- if ($rc != HTTP_OK) {
- print status_message($rc), "\n";
- }
-
- if (is_success($rc)) { ... }
- if (is_error($rc)) { ... }
- if (is_redirect($rc)) { ... }
-
-=head1 DESCRIPTION
-
-I<HTTP::Status> is a library of routines for defining and
-classifying HTTP status codes for libwww-perl. Status codes are
-used to encode the overall outcome of a HTTP response message. Codes
-correspond to those defined in RFC 2616 and RFC 2518.
-
-=head1 CONSTANTS
-
-The following constant functions can be used as mnemonic status code
-names. None of these are exported by default. Use the C<:constants>
-tag to import them all.
-
- HTTP_CONTINUE (100)
- HTTP_SWITCHING_PROTOCOLS (101)
- HTTP_PROCESSING (102)
-
- HTTP_OK (200)
- HTTP_CREATED (201)
- HTTP_ACCEPTED (202)
- HTTP_NON_AUTHORITATIVE_INFORMATION (203)
- HTTP_NO_CONTENT (204)
- HTTP_RESET_CONTENT (205)
- HTTP_PARTIAL_CONTENT (206)
- HTTP_MULTI_STATUS (207)
-
- HTTP_MULTIPLE_CHOICES (300)
- HTTP_MOVED_PERMANENTLY (301)
- HTTP_FOUND (302)
- HTTP_SEE_OTHER (303)
- HTTP_NOT_MODIFIED (304)
- HTTP_USE_PROXY (305)
- HTTP_TEMPORARY_REDIRECT (307)
-
- HTTP_BAD_REQUEST (400)
- HTTP_UNAUTHORIZED (401)
- HTTP_PAYMENT_REQUIRED (402)
- HTTP_FORBIDDEN (403)
- HTTP_NOT_FOUND (404)
- HTTP_METHOD_NOT_ALLOWED (405)
- HTTP_NOT_ACCEPTABLE (406)
- HTTP_PROXY_AUTHENTICATION_REQUIRED (407)
- HTTP_REQUEST_TIMEOUT (408)
- HTTP_CONFLICT (409)
- HTTP_GONE (410)
- HTTP_LENGTH_REQUIRED (411)
- HTTP_PRECONDITION_FAILED (412)
- HTTP_REQUEST_ENTITY_TOO_LARGE (413)
- HTTP_REQUEST_URI_TOO_LARGE (414)
- HTTP_UNSUPPORTED_MEDIA_TYPE (415)
- HTTP_REQUEST_RANGE_NOT_SATISFIABLE (416)
- HTTP_EXPECTATION_FAILED (417)
- HTTP_UNPROCESSABLE_ENTITY (422)
- HTTP_LOCKED (423)
- HTTP_FAILED_DEPENDENCY (424)
- HTTP_NO_CODE (425)
- HTTP_UPGRADE_REQUIRED (426)
- HTTP_RETRY_WITH (449)
-
- HTTP_INTERNAL_SERVER_ERROR (500)
- HTTP_NOT_IMPLEMENTED (501)
- HTTP_BAD_GATEWAY (502)
- HTTP_SERVICE_UNAVAILABLE (503)
- HTTP_GATEWAY_TIMEOUT (504)
- HTTP_HTTP_VERSION_NOT_SUPPORTED (505)
- HTTP_VARIANT_ALSO_NEGOTIATES (506)
- HTTP_INSUFFICIENT_STORAGE (507)
- HTTP_BANDWIDTH_LIMIT_EXCEEDED (509)
- HTTP_NOT_EXTENDED (510)
-
-=head1 FUNCTIONS
-
-The following additional functions are provided. Most of them are
-exported by default. The C<:is> import tag can be used to import all
-the classification functions.
-
-=over 4
-
-=item status_message( $code )
-
-The status_message() function will translate status codes to human
-readable strings. The string is the same as found in the constant
-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 (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 (2xx).
-
-=item is_redirect( $code )
-
-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 (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 (4xx). This class
-of status code is intended for cases in which the client seems to have
-erred.
-
-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 (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.
-
-This function is B<not> exported by default.
-
-=back
-
-=head1 BUGS
-
-For legacy reasons all the C<HTTP_> constants are exported by default
-with the prefix C<RC_>. It's recommended to use explict imports and
-the C<:constants> tag instead of relying on this.
package LWP;
-$VERSION = "5.837";
+$VERSION = "6.05";
sub Version { $VERSION; }
-require 5.005;
+require 5.008;
require LWP::UserAgent; # this should load everything you need
1;
__END__
+=encoding utf-8
+
=head1 NAME
LWP - The World-Wide Web library for Perl
section tries to describe what that means.
Let us start with this quote from the HTTP specification document
-<URL:http://www.w3.org/pub/WWW/Protocols/>:
+<URL:http://www.w3.org/Protocols/>:
=over 3
=item *
-The B<method> is a short string that tells what kind of
+B<method> is a short string that tells what kind of
request this is. The most common methods are B<GET>, B<PUT>,
B<POST> and B<HEAD>.
=item *
-The B<uri> is a string denoting the protocol, server and
+B<uri> is a string denoting the protocol, server and
the name of the "document" we want to access. The B<uri> might
also encode various other parameters.
=item *
-The B<headers> contain additional information about the
+B<headers> contains additional information about the
request and can also used to describe the content. The headers
are a set of keyword/value pairs.
=item *
-The B<content> is an arbitrary amount of data.
+B<content> is an arbitrary amount of data.
=back
=item *
-The B<code> is a numerical value that indicates the overall
+B<code> is a numerical value that indicates the overall
outcome of the request.
=item *
-The B<message> is a short, human readable string that
+B<message> is a short, human readable string that
corresponds to the I<code>.
=item *
-The B<headers> contain additional information about the
+B<headers> contains additional information about the
response and describe the content.
=item *
-The B<content> is an arbitrary amount of data.
+B<content> is an arbitrary amount of data.
=back
=item is_success()
-The request was was successfully received, understood or accepted.
+The request was successfully received, understood or accepted.
=item is_error()
=item *
-The B<timeout> specifies how much time we give remote servers to
+B<timeout> specifies how much time we give remote servers to
respond before the library disconnects and creates an
internal I<timeout> response.
=item *
-The B<agent> specifies the name that your application should use when it
+B<agent> specifies the name that your application uses when it
presents itself on the network.
=item *
-The B<from> attribute can be set to the e-mail address of the person
+B<from> can be set to the e-mail address of the person
responsible for running the application. If this is set, then the
address will be sent to the servers with every request.
=item *
-
The B<parse_head> specifies whether we should initialize response
+B<parse_head> specifies whether we should initialize response
headers from the E<lt>head> section of HTML documents.
=item *
-The B<proxy> and B<no_proxy> attributes specify if and when to go through
-a proxy server. <URL:http://www.w3.org/pub/WWW/Proxies/>
+B<proxy> and B<no_proxy> specify if and when to go through
+a proxy server. <URL:http://www.w3.org/History/1994/WWW/Proxies/>
=item *
-The B<credentials> provide a way to set up user names and
+B<credentials> provides a way to set up user names and
passwords needed to access certain services.
=back
All modules contain detailed information on the interfaces they
provide. The L<lwpcook> manpage is the libwww-perl cookbook that contain
examples of typical usage of the library. You might want to take a
-look at how the scripts L<lwp-request>, L<lwp-rget> and L<lwp-mirror>
-are implemented.
+look at how the scripts L<lwp-request>, L<lwp-download>, L<lwp-dump>
+and L<lwp-mirror> are implemented.
=head1 ENVIRONMENT
a proxy server. See the description of the C<env_proxy> method in
L<LWP::UserAgent>.
-=item PERL_LWP_USE_HTTP_10
+=item PERL_LWP_ENV_PROXY
+
+If set to a TRUE value, then the C<LWP::UserAgent> will by default call
+C<env_proxy> during initialization. This makes LWP honor the proxy variables
+described above.
+
+=item PERL_LWP_SSL_VERIFY_HOSTNAME
+
+The default C<verify_hostname> setting for C<LWP::UserAgent>. If
+not set the default will be 1. Set it as 0 to disable hostname
+verification (the default prior to libwww-perl 5.840.
+
+=item PERL_LWP_SSL_CA_FILE
+
+=item PERL_LWP_SSL_CA_PATH
-Enable the old HTTP/1.0 protocol driver instead of the new HTTP/1.1
-driver. You might want to set this to a TRUE value if you discover
-that your old LWP applications fails after you installed LWP-5.60 or
-better.
+The file and/or directory
+where the trusted Certificate Authority certificates
+is located. See L<LWP::UserAgent> for details.
=item PERL_HTTP_URI_CLASS
The latest version of this library is likely to be available from CPAN
as well as:
- http://github.com/gisle/libwww-perl
+ http://github.com/libwww-perl/libwww-perl
The best place to discuss this code is on the <libwww@perl.org>
mailing list.
use strict;
use vars qw/$VERSION/;
-$VERSION = '5.835';
+$VERSION = "6.00";
use Authen::NTLM "1.02";
use MIME::Base64 "2.12";
use strict;
use vars qw($VERSION $DEBUG);
-$VERSION = "5.810";
+$VERSION = "6.02";
sub new {
my($class, %cnf) = @_;
- my $total_capacity = delete $cnf{total_capacity};
- $total_capacity = 1 unless defined $total_capacity;
+
+ my $total_capacity = 1;
+ if (exists $cnf{total_capacity}) {
+ $total_capacity = delete $cnf{total_capacity};
+ }
if (%cnf && $^W) {
require Carp;
Carp::carp("Unrecognised options: @{[sort keys %cnf]}")
+++ /dev/null
-package LWP::MediaTypes;
-
-require Exporter;
-@ISA = qw(Exporter);
-@EXPORT = qw(guess_media_type media_suffix);
-@EXPORT_OK = qw(add_type add_encoding read_media_types);
-$VERSION = "5.835";
-
-use strict;
-
-# note: These hashes will also be filled with the entries found in
-# the 'media.types' file.
-
-my %suffixType = (
- 'txt' => 'text/plain',
- 'html' => 'text/html',
- 'gif' => 'image/gif',
- 'jpg' => 'image/jpeg',
- 'xml' => 'text/xml',
-);
-
-my %suffixExt = (
- 'text/plain' => 'txt',
- 'text/html' => 'html',
- 'image/gif' => 'gif',
- 'image/jpeg' => 'jpg',
- 'text/xml' => 'xml',
-);
-
-#XXX: there should be some way to define this in the media.types files.
-my %suffixEncoding = (
- 'Z' => 'compress',
- 'gz' => 'gzip',
- 'hqx' => 'x-hqx',
- 'uu' => 'x-uuencode',
- 'z' => 'x-pack',
- 'bz2' => 'x-bzip2',
-);
-
-read_media_types();
-
-
-
-sub _dump {
- require Data::Dumper;
- Data::Dumper->new([\%suffixType, \%suffixExt, \%suffixEncoding],
- [qw(*suffixType *suffixExt *suffixEncoding)])->Dump;
-}
-
-
-sub guess_media_type
-{
- my($file, $header) = @_;
- return undef unless defined $file;
-
- my $fullname;
- if (ref($file)) {
- # assume URI object
- $file = $file->path;
- #XXX should handle non http:, file: or ftp: URIs differently
- }
- else {
- $fullname = $file; # enable peek at actual file
- }
-
- my @encoding = ();
- my $ct = undef;
- for (file_exts($file)) {
- # first check this dot part as encoding spec
- if (exists $suffixEncoding{$_}) {
- unshift(@encoding, $suffixEncoding{$_});
- next;
- }
- if (exists $suffixEncoding{lc $_}) {
- unshift(@encoding, $suffixEncoding{lc $_});
- next;
- }
-
- # check content-type
- if (exists $suffixType{$_}) {
- $ct = $suffixType{$_};
- last;
- }
- if (exists $suffixType{lc $_}) {
- $ct = $suffixType{lc $_};
- last;
- }
-
- # don't know nothing about this dot part, bail out
- last;
- }
- unless (defined $ct) {
- # Take a look at the file
- if (defined $fullname) {
- $ct = (-T $fullname) ? "text/plain" : "application/octet-stream";
- }
- else {
- $ct = "application/octet-stream";
- }
- }
-
- if ($header) {
- $header->header('Content-Type' => $ct);
- $header->header('Content-Encoding' => \@encoding) if @encoding;
- }
-
- wantarray ? ($ct, @encoding) : $ct;
-}
-
-
-sub media_suffix {
- if (!wantarray && @_ == 1 && $_[0] !~ /\*/) {
- return $suffixExt{lc $_[0]};
- }
- my(@type) = @_;
- my(@suffix, $ext, $type);
- foreach (@type) {
- if (s/\*/.*/) {
- while(($ext,$type) = each(%suffixType)) {
- push(@suffix, $ext) if $type =~ /^$_$/i;
- }
- }
- else {
- my $ltype = lc $_;
- while(($ext,$type) = each(%suffixType)) {
- push(@suffix, $ext) if lc $type eq $ltype;
- }
- }
- }
- wantarray ? @suffix : $suffix[0];
-}
-
-
-sub file_exts
-{
- require File::Basename;
- my @parts = reverse split(/\./, File::Basename::basename($_[0]));
- pop(@parts); # never consider first part
- @parts;
-}
-
-
-sub add_type
-{
- my($type, @exts) = @_;
- for my $ext (@exts) {
- $ext =~ s/^\.//;
- $suffixType{$ext} = $type;
- }
- $suffixExt{lc $type} = $exts[0] if @exts;
-}
-
-
-sub add_encoding
-{
- my($type, @exts) = @_;
- for my $ext (@exts) {
- $ext =~ s/^\.//;
- $suffixEncoding{$ext} = $type;
- }
-}
-
-
-sub read_media_types
-{
- my(@files) = @_;
-
- local($/, $_) = ("\n", undef); # ensure correct $INPUT_RECORD_SEPARATOR
-
- my @priv_files = ();
- if($^O eq "MacOS") {
- push(@priv_files, "$ENV{HOME}:media.types", "$ENV{HOME}:mime.types")
- if defined $ENV{HOME}; # Some does not have a home (for instance Win32)
- }
- else {
- push(@priv_files, "$ENV{HOME}/.media.types", "$ENV{HOME}/.mime.types")
- if defined $ENV{HOME}; # Some doesn't have a home (for instance Win32)
- }
-
- # Try to locate "media.types" file, and initialize %suffixType from it
- my $typefile;
- unless (@files) {
- if($^O eq "MacOS") {
- @files = map {$_."LWP:media.types"} @INC;
- }
- else {
- @files = map {"$_/LWP/media.types"} @INC;
- }
- push @files, @priv_files;
- }
- for $typefile (@files) {
- local(*TYPE);
- open(TYPE, $typefile) || next;
- while (<TYPE>) {
- next if /^\s*#/; # comment line
- next if /^\s*$/; # blank line
- s/#.*//; # remove end-of-line comments
- my($type, @exts) = split(' ', $_);
- add_type($type, @exts);
- }
- close(TYPE);
- }
-}
-
-1;
-
-
-__END__
-
-=head1 NAME
-
-LWP::MediaTypes - guess media type for a file or a URL
-
-=head1 SYNOPSIS
-
- use LWP::MediaTypes qw(guess_media_type);
- $type = guess_media_type("/tmp/foo.gif");
-
-=head1 DESCRIPTION
-
-This module provides functions for handling media (also known as
-MIME) types and encodings. The mapping from file extensions to media
-types is defined by the F<media.types> file. If the F<~/.media.types>
-file exists it is used instead.
-For backwards compatibility we will also look for F<~/.mime.types>.
-
-The following functions are exported by default:
-
-=over 4
-
-=item guess_media_type( $filename )
-
-=item guess_media_type( $uri )
-
-=item guess_media_type( $filename_or_uri, $header_to_modify )
-
-This function tries to guess media type and encoding for a file or a URI.
-It returns the content type, which is a string like C<"text/html">.
-In array context it also returns any content encodings applied (in the
-order used to encode the file). You can pass a URI object
-reference, instead of the file name.
-
-If the type can not be deduced from looking at the file name,
-then guess_media_type() will let the C<-T> Perl operator take a look.
-If this works (and C<-T> returns a TRUE value) then we return
-I<text/plain> as the type, otherwise we return
-I<application/octet-stream> as the type.
-
-The optional second argument should be a reference to a HTTP::Headers
-object or any object that implements the $obj->header method in a
-similar way. When it is present the values of the
-'Content-Type' and 'Content-Encoding' will be set for this header.
-
-=item media_suffix( $type, ... )
-
-This function will return all suffixes that can be used to denote the
-specified media type(s). Wildcard types can be used. In a scalar
-context it will return the first suffix found. Examples:
-
- @suffixes = media_suffix('image/*', 'audio/basic');
- $suffix = media_suffix('text/html');
-
-=back
-
-The following functions are only exported by explicit request:
-
-=over 4
-
-=item add_type( $type, @exts )
-
-Associate a list of file extensions with the given media type.
-Example:
-
- add_type("x-world/x-vrml" => qw(wrl vrml));
-
-=item add_encoding( $type, @ext )
-
-Associate a list of file extensions with an encoding type.
-Example:
-
- add_encoding("x-gzip" => "gz");
-
-=item read_media_types( @files )
-
-Parse media types files and add the type mappings found there.
-Example:
-
- read_media_types("conf/mime.types");
-
-=back
-
-=head1 COPYRIGHT
-
-Copyright 1995-1999 Gisle Aas.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
require LWP::MemberMixin;
@ISA = qw(LWP::MemberMixin);
-$VERSION = "5.829";
+$VERSION = "6.00";
use strict;
use Carp ();
unless ($sock) {
# IO::Socket::INET leaves additional error messages in $@
- $@ =~ s/^.*?: //;
- die "Can't connect to $host:$port ($@)";
+ my $status = "Can't connect to $host:$port";
+ if ($@ =~ /\bconnect: (.*)/ ||
+ $@ =~ /\b(Bad hostname)\b/ ||
+ $@ =~ /\b(certificate verify failed)\b/ ||
+ $@ =~ /\b(Crypt-SSLeay can't verify hostnames)\b/
+ ) {
+ $status .= " ($1)";
+ }
+ die "$status\n\n$@";
}
# perl 5.005's IO::Socket does not have the blocking method.
# connect to remote site
my $socket = $self->_new_socket($host, $port, $timeout);
+
+ my $http_version = "";
+ if (my $proto = $request->protocol) {
+ if ($proto =~ /^(?:HTTP\/)?(1.\d+)$/) {
+ $http_version = $1;
+ $socket->http_version($http_version);
+ $socket->send_te(0) if $http_version eq "1.0";
+ }
+ }
+
$self->_check_sock($request, $socket);
my @h;
my $eof;
my $wbuf;
my $woffset = 0;
- if (ref($content_ref) eq 'CODE') {
+ INITIAL_READ:
+ if ($write_wait) {
+ # skip filling $wbuf when waiting for 100-continue
+ # because if the response is a redirect or auth required
+ # the request will be cloned and there is no way
+ # to reset the input stream
+ # return here via the label after the 100-continue is read
+ }
+ elsif (ref($content_ref) eq 'CODE') {
my $buf = &$content_ref();
$buf = "" unless defined($buf);
$buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF
vec($fbits, fileno($socket), 1) = 1;
WRITE:
- while ($woffset < length($$wbuf)) {
+ while ($write_wait || $woffset < length($$wbuf)) {
my $sel_timeout = $timeout;
if ($write_wait) {
if ($code eq "100") {
$write_wait = 0;
undef($code);
+ goto INITIAL_READ;
}
else {
$drop_connection++;
#-----------------------------------------------------------
package LWP::Protocol::http::SocketMethods;
-sub sysread {
- my $self = shift;
- if (my $timeout = ${*$self}{io_socket_timeout}) {
- die "read timeout" unless $self->can_read($timeout);
- }
- else {
- # since we have made the socket non-blocking we
- # use select to wait for some data to arrive
- $self->can_read(undef) || die "Assert";
- }
- sysread($self, $_[0], $_[1], $_[2] || 0);
-}
-
-sub can_read {
- my($self, $timeout) = @_;
- my $fbits = '';
- vec($fbits, fileno($self), 1) = 1;
- SELECT:
- {
- my $before;
- $before = time if $timeout;
- my $nfound = select($fbits, undef, undef, $timeout);
- if ($nfound < 0) {
- 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 {
my $self = shift;
!$self->can_read(0);
+++ /dev/null
-package LWP::Protocol::http10;
-
-use strict;
-
-require HTTP::Response;
-require HTTP::Status;
-require IO::Socket;
-require IO::Select;
-
-use vars qw(@ISA @EXTRA_SOCK_OPTS);
-
-require LWP::Protocol;
-@ISA = qw(LWP::Protocol);
-
-my $CRLF = "\015\012"; # how lines should be terminated;
- # "\r\n" is not correct on all systems, for
- # instance MacPerl defines it to "\012\015"
-
-sub _new_socket
-{
- my($self, $host, $port, $timeout) = @_;
-
- local($^W) = 0; # IO::Socket::INET can be noisy
- my $sock = IO::Socket::INET->new(PeerAddr => $host,
- PeerPort => $port,
- Proto => 'tcp',
- Timeout => $timeout,
- $self->_extra_sock_opts($host, $port),
- );
- unless ($sock) {
- # IO::Socket::INET leaves additional error messages in $@
- $@ =~ s/^.*?: //;
- die "Can't connect to $host:$port ($@)";
- }
- $sock;
-}
-
-sub _extra_sock_opts # to be overridden by subclass
-{
- return @EXTRA_SOCK_OPTS;
-}
-
-
-sub _check_sock
-{
- #my($self, $req, $sock) = @_;
-}
-
-sub _get_sock_info
-{
- my($self, $res, $sock) = @_;
- if (defined(my $peerhost = $sock->peerhost)) {
- $res->header("Client-Peer" => "$peerhost:" . $sock->peerport);
- }
-}
-
-sub _fixup_header
-{
- my($self, $h, $url, $proxy) = @_;
-
- $h->remove_header('Connection'); # need support here to be useful
-
- # HTTP/1.1 will require us to send the 'Host' header, so we might
- # as well start now.
- my $hhost = $url->authority;
- if ($hhost =~ s/^([^\@]*)\@//) { # get rid of potential "user:pass@"
- # add authorization header if we need them. HTTP URLs do
- # not really support specification of user and password, but
- # we allow it.
- if (defined($1) && not $h->header('Authorization')) {
- require URI::Escape;
- $h->authorization_basic(map URI::Escape::uri_unescape($_),
- split(":", $1, 2));
- }
- }
- $h->init_header('Host' => $hhost);
-
- if ($proxy) {
- # Check the proxy URI's userinfo() for proxy credentials
- # export http_proxy="http://proxyuser:proxypass@proxyhost:port"
- my $p_auth = $proxy->userinfo();
- if(defined $p_auth) {
- require URI::Escape;
- $h->proxy_authorization_basic(map URI::Escape::uri_unescape($_),
- split(":", $p_auth, 2))
- }
- }
-}
-
-
-sub request
-{
- my($self, $request, $proxy, $arg, $size, $timeout) = @_;
-
- $size ||= 4096;
-
- # check method
- my $method = $request->method;
- unless ($method =~ /^[A-Za-z0-9_!\#\$%&\'*+\-.^\`|~]+$/) { # HTTP token
- return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
- 'Library does not allow method ' .
- "$method for 'http:' URLs");
- }
-
- my $url = $request->uri;
- my($host, $port, $fullpath);
-
- # Check if we're proxy'ing
- if (defined $proxy) {
- # $proxy is an URL to an HTTP server which will proxy this request
- $host = $proxy->host;
- $port = $proxy->port;
- $fullpath = $method eq "CONNECT" ?
- ($url->host . ":" . $url->port) :
- $url->as_string;
- }
- else {
- $host = $url->host;
- $port = $url->port;
- $fullpath = $url->path_query;
- $fullpath = "/" unless length $fullpath;
- }
-
- # connect to remote site
- my $socket = $self->_new_socket($host, $port, $timeout);
- $self->_check_sock($request, $socket);
-
- my $sel = IO::Select->new($socket) if $timeout;
-
- my $request_line = "$method $fullpath HTTP/1.0$CRLF";
-
- my $h = $request->headers->clone;
- my $cont_ref = $request->content_ref;
- $cont_ref = $$cont_ref if ref($$cont_ref);
- my $ctype = ref($cont_ref);
-
- # If we're sending content we *have* to specify a content length
- # otherwise the server won't know a messagebody is coming.
- if ($ctype eq 'CODE') {
- die 'No Content-Length header for request with dynamic content'
- unless defined($h->header('Content-Length')) ||
- $h->content_type =~ /^multipart\//;
- # For HTTP/1.1 we could have used chunked transfer encoding...
- }
- else {
- $h->header('Content-Length' => length $$cont_ref)
- if defined($$cont_ref) && length($$cont_ref);
- }
-
- $self->_fixup_header($h, $url, $proxy);
-
- my $buf = $request_line . $h->as_string($CRLF) . $CRLF;
- my $n; # used for return value from syswrite/sysread
- my $length;
- my $offset;
-
- # syswrite $buf
- $length = length($buf);
- $offset = 0;
- while ( $offset < $length ) {
- die "write timeout" if $timeout && !$sel->can_write($timeout);
- $n = $socket->syswrite($buf, $length-$offset, $offset );
- die $! unless defined($n);
- $offset += $n;
- }
-
- if ($ctype eq 'CODE') {
- while ( ($buf = &$cont_ref()), defined($buf) && length($buf)) {
- # syswrite $buf
- $length = length($buf);
- $offset = 0;
- while ( $offset < $length ) {
- die "write timeout" if $timeout && !$sel->can_write($timeout);
- $n = $socket->syswrite($buf, $length-$offset, $offset );
- die $! unless defined($n);
- $offset += $n;
- }
- }
- }
- elsif (defined($$cont_ref) && length($$cont_ref)) {
- # syswrite $$cont_ref
- $length = length($$cont_ref);
- $offset = 0;
- while ( $offset < $length ) {
- die "write timeout" if $timeout && !$sel->can_write($timeout);
- $n = $socket->syswrite($$cont_ref, $length-$offset, $offset );
- die $! unless defined($n);
- $offset += $n;
- }
- }
-
- # read response line from server
- my $response;
- $buf = '';
-
- # Inside this loop we will read the response line and all headers
- # found in the response.
- while (1) {
- die "read timeout" if $timeout && !$sel->can_read($timeout);
- $n = $socket->sysread($buf, $size, length($buf));
- die $! unless defined($n);
- die "unexpected EOF before status line seen" unless $n;
-
- if ($buf =~ s/^(HTTP\/\d+\.\d+)[ \t]+(\d+)[ \t]*([^\012]*)\012//) {
- # HTTP/1.0 response or better
- my($ver,$code,$msg) = ($1, $2, $3);
- $msg =~ s/\015$//;
- $response = HTTP::Response->new($code, $msg);
- $response->protocol($ver);
-
- # ensure that we have read all headers. The headers will be
- # terminated by two blank lines
- until ($buf =~ /^\015?\012/ || $buf =~ /\015?\012\015?\012/) {
- # must read more if we can...
- die "read timeout" if $timeout && !$sel->can_read($timeout);
- my $old_len = length($buf);
- $n = $socket->sysread($buf, $size, $old_len);
- die $! unless defined($n);
- die "unexpected EOF before all headers seen" unless $n;
- }
-
- # now we start parsing the headers. The strategy is to
- # remove one line at a time from the beginning of the header
- # buffer ($res).
- my($key, $val);
- while ($buf =~ s/([^\012]*)\012//) {
- my $line = $1;
-
- # if we need to restore as content when illegal headers
- # are found.
- my $save = "$line\012";
-
- $line =~ s/\015$//;
- last unless length $line;
-
- if ($line =~ /^([a-zA-Z0-9_\-.]+)\s*:\s*(.*)/) {
- $response->push_header($key, $val) if $key;
- ($key, $val) = ($1, $2);
- }
- elsif ($line =~ /^\s+(.*)/ && $key) {
- $val .= " $1";
- }
- else {
- $response->push_header("Client-Bad-Header-Line" => $line);
- }
- }
- $response->push_header($key, $val) if $key;
- last;
-
- }
- elsif ((length($buf) >= 5 and $buf !~ /^HTTP\//) or
- $buf =~ /\012/ ) {
- # HTTP/0.9 or worse
- $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
- $response->protocol('HTTP/0.9');
- last;
-
- }
- else {
- # need more data
- }
- };
- $response->request($request);
- $self->_get_sock_info($response, $socket);
-
- if ($method eq "CONNECT") {
- $response->{client_socket} = $socket; # so it can be picked up
- $response->content($buf); # in case we read more than the headers
- return $response;
- }
-
- my $usebuf = length($buf) > 0;
- $response = $self->collect($arg, $response, sub {
- if ($usebuf) {
- $usebuf = 0;
- return \$buf;
- }
- die "read timeout" if $timeout && !$sel->can_read($timeout);
- my $n = $socket->sysread($buf, $size);
- die $! unless defined($n);
- return \$buf;
- } );
-
- #$socket->close;
-
- $response;
-}
-
-1;
+++ /dev/null
-package LWP::Protocol::https;
-
-use strict;
-
-use vars qw(@ISA);
-require LWP::Protocol::http;
-@ISA = qw(LWP::Protocol::http);
-
-sub socket_type
-{
- return "https";
-}
-
-sub _check_sock
-{
- my($self, $req, $sock) = @_;
- my $check = $req->header("If-SSL-Cert-Subject");
- if (defined $check) {
- my $cert = $sock->get_peer_certificate ||
- die "Missing SSL certificate";
- my $subject = $cert->subject_name;
- die "Bad SSL certificate subject: '$subject' !~ /$check/"
- unless $subject =~ /$check/;
- $req->remove_header("If-SSL-Cert-Subject"); # don't pass it on
- }
-}
-
-sub _get_sock_info
-{
- my $self = shift;
- $self->SUPER::_get_sock_info(@_);
- my($res, $sock) = @_;
- $res->header("Client-SSL-Cipher" => $sock->get_cipher);
- my $cert = $sock->get_peer_certificate;
- if ($cert) {
- $res->header("Client-SSL-Cert-Subject" => $cert->subject_name);
- $res->header("Client-SSL-Cert-Issuer" => $cert->issuer_name);
- }
- if(! eval { $sock->get_peer_verify }) {
- $res->header("Client-SSL-Warning" => "Peer certificate not verified");
- }
-}
-
-#-----------------------------------------------------------
-package LWP::Protocol::https::Socket;
-
-use vars qw(@ISA);
-require Net::HTTPS;
-@ISA = qw(Net::HTTPS LWP::Protocol::http::SocketMethods);
-
-1;
+++ /dev/null
-package LWP::Protocol::https10;
-
-use strict;
-
-# Figure out which SSL implementation to use
-use vars qw($SSL_CLASS);
-if ($Net::SSL::VERSION) {
- $SSL_CLASS = "Net::SSL";
-}
-elsif ($IO::Socket::SSL::VERSION) {
- $SSL_CLASS = "IO::Socket::SSL"; # it was already loaded
-}
-else {
- eval { require Net::SSL; }; # from Crypt-SSLeay
- if ($@) {
- require IO::Socket::SSL;
- $SSL_CLASS = "IO::Socket::SSL";
- }
- else {
- $SSL_CLASS = "Net::SSL";
- }
-}
-
-
-use vars qw(@ISA);
-
-require LWP::Protocol::http10;
-@ISA=qw(LWP::Protocol::http10);
-
-sub _new_socket
-{
- my($self, $host, $port, $timeout) = @_;
- local($^W) = 0; # IO::Socket::INET can be noisy
- my $sock = $SSL_CLASS->new(PeerAddr => $host,
- PeerPort => $port,
- Proto => 'tcp',
- Timeout => $timeout,
- );
- unless ($sock) {
- # IO::Socket::INET leaves additional error messages in $@
- $@ =~ s/^.*?: //;
- die "Can't connect to $host:$port ($@)";
- }
- $sock;
-}
-
-sub _check_sock
-{
- my($self, $req, $sock) = @_;
- my $check = $req->header("If-SSL-Cert-Subject");
- if (defined $check) {
- my $cert = $sock->get_peer_certificate ||
- die "Missing SSL certificate";
- my $subject = $cert->subject_name;
- die "Bad SSL certificate subject: '$subject' !~ /$check/"
- unless $subject =~ /$check/;
- $req->remove_header("If-SSL-Cert-Subject"); # don't pass it on
- }
-}
-
-sub _get_sock_info
-{
- my $self = shift;
- $self->SUPER::_get_sock_info(@_);
- my($res, $sock) = @_;
- $res->header("Client-SSL-Cipher" => $sock->get_cipher);
- my $cert = $sock->get_peer_certificate;
- if ($cert) {
- $res->header("Client-SSL-Cert-Subject" => $cert->subject_name);
- $res->header("Client-SSL-Cert-Issuer" => $cert->issuer_name);
- }
- $res->header("Client-SSL-Warning" => "Peer certificate not verified");
-}
-
-1;
require LWP::UserAgent;
@ISA = qw(LWP::UserAgent);
-$VERSION = "5.835";
+$VERSION = "6.03";
require WWW::RobotRules;
require HTTP::Request;
$self->{'rules'}->parse($robot_url, "");
my $robot_req = HTTP::Request->new('GET', $robot_url);
+ my $parse_head = $self->parse_head(0);
my $robot_res = $self->request($robot_req);
+ $self->parse_head($parse_head);
my $fresh_until = $robot_res->fresh_until;
- if ($robot_res->is_success) {
- my $c = $robot_res->content;
- if ($robot_res->content_type =~ m,^text/, && $c =~ /^\s*Disallow\s*:/mi) {
- $self->{'rules'}->parse($robot_url, $c, $fresh_until);
- }
- else {
- $self->{'rules'}->parse($robot_url, "", $fresh_until);
- }
-
- }
- else {
- $self->{'rules'}->parse($robot_url, "", $fresh_until);
+ my $content = "";
+ if ($robot_res->is_success && $robot_res->content_is_text) {
+ $content = $robot_res->decoded_content;
+ $content = "" unless $content && $content =~ /^\s*Disallow\s*:/mi;
}
+ $self->{'rules'}->parse($robot_url, $content, $fresh_until);
# recalculate allowed...
$allowed = $self->{'rules'}->allowed($request->uri);
use HTTP::Status;
push(@EXPORT, @HTTP::Status::EXPORT);
-$VERSION = "5.835";
+$VERSION = "6.00";
sub import
{
require LWP::MemberMixin;
@ISA = qw(LWP::MemberMixin);
-$VERSION = "5.835";
+$VERSION = "6.05";
use HTTP::Request ();
use HTTP::Response ();
use Carp ();
-if ($ENV{PERL_LWP_USE_HTTP_10}) {
- require LWP::Protocol::http10;
- LWP::Protocol::implementor('http', 'LWP::Protocol::http10');
- eval {
- require LWP::Protocol::https10;
- LWP::Protocol::implementor('https', 'LWP::Protocol::https10');
- };
-}
-
-
sub new
{
my $timeout = delete $cnf{timeout};
$timeout = 3*60 unless defined $timeout;
my $local_address = delete $cnf{local_address};
+ my $ssl_opts = delete $cnf{ssl_opts} || {};
+ unless (exists $ssl_opts->{verify_hostname}) {
+ # The processing of HTTPS_CA_* below is for compatibility with Crypt::SSLeay
+ if (exists $ENV{PERL_LWP_SSL_VERIFY_HOSTNAME}) {
+ $ssl_opts->{verify_hostname} = $ENV{PERL_LWP_SSL_VERIFY_HOSTNAME};
+ }
+ elsif ($ENV{HTTPS_CA_FILE} || $ENV{HTTPS_CA_DIR}) {
+ # Crypt-SSLeay compatibility (verify peer certificate; but not the hostname)
+ $ssl_opts->{verify_hostname} = 0;
+ $ssl_opts->{SSL_verify_mode} = 1;
+ }
+ else {
+ $ssl_opts->{verify_hostname} = 1;
+ }
+ }
+ unless (exists $ssl_opts->{SSL_ca_file}) {
+ if (my $ca_file = $ENV{PERL_LWP_SSL_CA_FILE} || $ENV{HTTPS_CA_FILE}) {
+ $ssl_opts->{SSL_ca_file} = $ca_file;
+ }
+ }
+ unless (exists $ssl_opts->{SSL_ca_path}) {
+ if (my $ca_path = $ENV{PERL_LWP_SSL_CA_PATH} || $ENV{HTTPS_CA_DIR}) {
+ $ssl_opts->{SSL_ca_path} = $ca_path;
+ }
+ }
my $use_eval = delete $cnf{use_eval};
$use_eval = 1 unless defined $use_eval;
my $parse_head = delete $cnf{parse_head};
my $max_size = delete $cnf{max_size};
my $max_redirect = delete $cnf{max_redirect};
$max_redirect = 7 unless defined $max_redirect;
- my $env_proxy = delete $cnf{env_proxy};
+ my $env_proxy = exists $cnf{env_proxy} ? delete $cnf{env_proxy} : $ENV{PERL_LWP_ENV_PROXY};
my $cookie_jar = delete $cnf{cookie_jar};
my $conn_cache = delete $cnf{conn_cache};
Carp::croak("Can't mix conn_cache and keep_alive")
if $conn_cache && $keep_alive;
-
my $protocols_allowed = delete $cnf{protocols_allowed};
my $protocols_forbidden = delete $cnf{protocols_forbidden};
def_headers => $def_headers,
timeout => $timeout,
local_address => $local_address,
+ ssl_opts => $ssl_opts,
use_eval => $use_eval,
show_progress=> $show_progress,
max_size => $max_size,
$@ =~ s/ at .* line \d+.*//s; # remove file/line number
$response = _new_response($request, &HTTP::Status::RC_NOT_IMPLEMENTED, $@);
if ($scheme eq "https") {
- $response->message($response->message . " (Crypt::SSLeay or IO::Socket::SSL not installed)");
+ $response->message($response->message . " (LWP::Protocol::https not installed)");
$response->content_type("text/plain");
$response->content(<<EOT);
-LWP will support https URLs if either Crypt::SSLeay or IO::Socket::SSL
-is installed. More information at
-<http://search.cpan.org/dist/libwww-perl/README.SSL>.
+LWP will support https URLs if the LWP::Protocol::https module
+is installed.
EOT
}
}
if (!$response && $self->{use_eval}) {
# we eval, and turn dies into responses below
eval {
- $response = $protocol->request($request, $proxy,
- $arg, $size, $self->{timeout});
+ $response = $protocol->request($request, $proxy, $arg, $size, $self->{timeout}) ||
+ die "No response returned by $protocol";
};
if ($@) {
- $@ =~ s/ at .* line \d+.*//s; # remove file/line number
- $response = _new_response($request,
- &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
- $@);
+ if (UNIVERSAL::isa($@, "HTTP::Response")) {
+ $response = $@;
+ $response->request($request);
+ }
+ else {
+ my $full = $@;
+ (my $status = $@) =~ s/\n.*//s;
+ $status =~ s/ at .* line \d+.*//s; # remove file/line number
+ my $code = ($status =~ s/^(\d\d\d)\s+//) ? $1 : &HTTP::Status::RC_INTERNAL_SERVER_ERROR;
+ $response = _new_response($request, $code, $status, $full);
+ }
}
}
elsif (!$response) {
}
+sub put {
+ require HTTP::Request::Common;
+ my($self, @parameters) = @_;
+ my @suff = $self->_process_colonic_headers(\@parameters, (ref($parameters[1]) ? 2 : 1));
+ return $self->request( HTTP::Request::Common::PUT( @parameters ), @suff );
+}
+
+
+sub delete {
+ require HTTP::Request::Common;
+ my($self, @parameters) = @_;
+ my @suff = $self->_process_colonic_headers(\@parameters,1);
+ return $self->request( HTTP::Request::Common::DELETE( @parameters ), @suff );
+}
+
+
sub _process_colonic_headers {
# Process :content_cb / :content_file / :read_size_hint headers.
my($self, $args, $start_index) = @_;
return $arg;
}
+
+sub is_online {
+ my $self = shift;
+ return 1 if $self->get("http://www.msftncsi.com/ncsi.txt")->content eq "Microsoft NCSI";
+ return 1 if $self->get("http://www.apple.com")->content =~ m,<title>Apple</title>,;
+ return 0;
+}
+
+
my @ANI = qw(- \ | /);
sub progress {
sub max_redirect { shift->_elem('max_redirect', @_); }
sub show_progress{ shift->_elem('show_progress', @_); }
+sub ssl_opts {
+ my $self = shift;
+ if (@_ == 1) {
+ my $k = shift;
+ return $self->{ssl_opts}{$k};
+ }
+ if (@_) {
+ my $old;
+ while (@_) {
+ my($k, $v) = splice(@_, 0, 2);
+ $old = $self->{ssl_opts}{$k} unless @_;
+ if (defined $v) {
+ $self->{ssl_opts}{$k} = $v;
+ }
+ else {
+ delete $self->{ssl_opts}{$k};
+ }
+ }
+ %{$self->{ssl_opts}} = (%{$self->{ssl_opts}}, @_);
+ return $old;
+ }
+
+ return keys %{$self->{ssl_opts}};
+}
+
sub parse_head {
my $self = shift;
if (@_) {
}
-# depreciated
+# deprecated
sub use_eval { shift->_elem('use_eval', @_); }
sub use_alarm
{
delete $copy->{conn_cache};
# copy any plain arrays and hashes; known not to need recursive copy
- for my $k (qw(proxy no_proxy requests_redirectable)) {
+ for my $k (qw(proxy no_proxy requests_redirectable ssl_opts)) {
next unless $copy->{$k};
if (ref($copy->{$k}) eq "ARRAY") {
$copy->{$k} = [ @{$copy->{$k}} ];
sub env_proxy {
my ($self) = @_;
+ require Encode;
+ require Encode::Locale;
my($k,$v);
while(($k, $v) = each %ENV) {
if ($ENV{REQUEST_METHOD}) {
next unless $k =~ /^$URI::scheme_re\z/;
# Ignore xxx_proxy variables if xxx isn't a supported protocol
next unless LWP::Protocol::implementor($k);
- $self->proxy($k, $v);
+ $self->proxy($k, Encode::decode(locale => $v));
}
}
}
sub _new_response {
- my($request, $code, $message) = @_;
+ my($request, $code, $message, $content) = @_;
+ $message ||= HTTP::Status::status_message($code);
my $response = HTTP::Response->new($code, $message);
$response->request($request);
$response->header("Client-Date" => HTTP::Date::time2str(time));
$response->header("Client-Warning" => "Internal response");
$response->header("Content-Type" => "text/plain");
- $response->content("$code $message\n");
+ $response->content($content || "$code $message\n");
return $response;
}
request method the UserAgent, which dispatches it using the relevant
protocol, and returns a C<HTTP::Response> object. There are
convenience methods for sending the most common request types: get(),
-head() and post(). When using these methods then the creation of the
-request object is hidden as shown in the synopsis above.
+head(), post(), put() and delete(). When using these methods then the
+creation of the request object is hidden as shown in the synopsis above.
The basic approach of the library is to use HTTP style communication
for all protocol schemes. This means that you will construct
cookie_jar undef
default_headers HTTP::Headers->new
local_address undef
+ ssl_opts { verify_hostname => 1 }
max_size undef
max_redirect 7
parse_head 1
requests_redirectable ['GET', 'HEAD']
timeout 180
-The following additional options are also accepted: If the
-C<env_proxy> option is passed in with a TRUE value, then proxy
-settings are read from environment variables (see env_proxy() method
-below). If the C<keep_alive> option is passed in, then a
-C<LWP::ConnCache> is set up (see conn_cache() method below). The
-C<keep_alive> value is passed on as the C<total_capacity> for the
-connection cache.
+The following additional options are also accepted: If the C<env_proxy> option
+is passed in with a TRUE value, then proxy settings are read from environment
+variables (see env_proxy() method below). If C<env_proxy> isn't provided the
+C<PERL_LWP_ENV_PROXY> environment variable controls if env_proxy() is called
+during initialization. If the C<keep_alive> option is passed in, then a
+C<LWP::ConnCache> is set up (see conn_cache() method below). The C<keep_alive>
+value is passed on as the C<total_capacity> for the connection cache.
=item $ua->clone
for the complete transaction and the request() method to actually
return might be longer.
+=item $ua->ssl_opts
+
+=item $ua->ssl_opts( $key )
+
+=item $ua->ssl_opts( $key => $value )
+
+Get/set the options for SSL connections. Without argument return the list
+of options keys currently set. With a single argument return the current
+value for the given option. With 2 arguments set the option value and return
+the old. Setting an option to the value C<undef> removes this option.
+
+The options that LWP relates to are:
+
+=over
+
+=item C<verify_hostname> => $bool
+
+When TRUE LWP will for secure protocol schemes ensure it connects to servers
+that have a valid certificate matching the expected hostname. If FALSE no
+checks are made and you can't be sure that you communicate with the expected peer.
+The no checks behaviour was the default for libwww-perl-5.837 and earlier releases.
+
+This option is initialized from the L<PERL_LWP_SSL_VERIFY_HOSTNAME> environment
+variable. If this environment variable isn't set; then C<verify_hostname>
+defaults to 1.
+
+=item C<SSL_ca_file> => $path
+
+The path to a file containing Certificate Authority certificates.
+A default setting for this option is provided by checking the environment
+variables C<PERL_LWP_SSL_CA_FILE> and C<HTTPS_CA_FILE> in order.
+
+=item C<SSL_ca_path> => $path
+
+The path to a directory containing files containing Certificate Authority
+certificates.
+A default setting for this option is provided by checking the environment
+variables C<PERL_LWP_SSL_CA_PATH> and C<HTTPS_CA_DIR> in order.
+
+=back
+
+Other options can be set and are processed directly by the SSL Socket implementation
+in use. See L<IO::Socket::SSL> or L<Net::SSL> for details.
+
+The libwww-perl core no longer bundles protocol plugins for SSL. You will need
+to install L<LWP::Protocol::https> separately to enable support for processing
+https-URLs.
+
=back
=head2 Proxy attributes
The method can assign a new request object to $_[0] to replace the
request that is sent fully.
-The return value from the callback is ignored. If an exceptions is
+The return value from the callback is ignored. If an exception is
raised it will abort the request and make the request method return a
"400 Bad request" response.
=item request_send => sub { my($request, $ua, $h) = @_; ... }
-This handler get a chance of handling requests before it's sent to the
+This handler gets a chance of handling requests before they're sent to the
protocol handlers. It should return an HTTP::Response object if it
wishes to terminate the processing; otherwise it should return nothing.
=item response_data => sub { my($response, $ua, $h, $data) = @_; ... }
-This handlers is called for each chunk of data received for the
+This handler is called for each chunk of data received for the
response. The handler might croak to abort the request.
-This handler need to return a TRUE value to be called again for
+This handler needs to return a TRUE value to be called again for
subsequent chunks for the same request.
=item response_done => sub { my($response, $ua, $h) = @_; ... }
=item response_redirect => sub { my($response, $ua, $h) = @_; ... }
The handler is called in $ua->request after C<response_done>. If the
-handler return an HTTP::Request object we'll start over with processing
+handler returns an HTTP::Request object we'll start over with processing
this request instead.
=back
to build the request. See L<HTTP::Request::Common> for a details on
how to pass form content and other advanced features.
+=item $ua->put( $url, \%form )
+
+=item $ua->put( $url, \@form )
+
+=item $ua->put( $url, \%form, $field_name => $value, ... )
+
+=item $ua->put( $url, $field_name => $value,... Content => \%form )
+
+=item $ua->put( $url, $field_name => $value,... Content => \@form )
+
+=item $ua->put( $url, $field_name => $value,... Content => $content )
+
+This method will dispatch a C<PUT> request on the given $url, with
+%form or @form providing the key/value pairs for the fill-in form
+content. Additional headers and content options are the same as for
+the get() method.
+
+This method will use the PUT() function from C<HTTP::Request::Common>
+to build the request. See L<HTTP::Request::Common> for a details on
+how to pass form content and other advanced features.
+
+=item $ua->delete( $url )
+
+=item $ua->delete( $url, $field_name => $value, ... )
+
+This method will dispatch a C<DELETE> request on the given $url. Additional
+headers and content options are the same as for the get() method.
+
+This method will use the DELETE() function from C<HTTP::Request::Common>
+to build the request. See L<HTTP::Request::Common> for a details on
+how to pass form content and other advanced features.
+
=item $ua->mirror( $url, $filename )
This method will get the document identified by $url and store it in
handle redirects or authentication responses. The request() method
will in fact invoke this method for each simple request it sends.
+=item $ua->is_online
+
+Tries to determine if you have access to the Internet. Returns
+TRUE if the built-in heuristics determine that the user agent is
+able to access the Internet (over HTTP). See also L<LWP::Online>.
+
=item $ua->is_protocol_supported( $scheme )
You can use this method to test whether this user agent object supports the
+++ /dev/null
-# This is a comment. I love comments.
-
-# This file controls what Internet media types are sent to the client for
-# given file extension(s). Sending the correct media type to the client
-# is important so they know how to handle the content of the file.
-# For more information about Internet media types, please read RFC 2045,
-# 2046, 2047, 2048, and 2077. The Internet media type registry is
-# at <http://www.iana.org/assignments/media-types/>.
-
-# MIME type Extensions
-application/activemessage
-application/andrew-inset ez
-application/applefile
-application/atom+xml atom
-application/atomcat+xml atomcat
-application/atomicmail
-application/atomsvc+xml atomsvc
-application/auth-policy+xml
-application/batch-smtp
-application/beep+xml
-application/cals-1840
-application/ccxml+xml ccxml
-application/cellml+xml
-application/cnrp+xml
-application/commonground
-application/conference-info+xml
-application/cpl+xml
-application/csta+xml
-application/cstadata+xml
-application/cybercash
-application/davmount+xml davmount
-application/dca-rft
-application/dec-dx
-application/dialog-info+xml
-application/dicom
-application/dns
-application/dvcs
-application/ecmascript ecma
-application/edi-consent
-application/edi-x12
-application/edifact
-application/epp+xml
-application/eshop
-application/fastinfoset
-application/fastsoap
-application/fits
-application/font-tdpfr pfr
-application/h224
-application/http
-application/hyperstudio stk
-application/iges
-application/im-iscomposing+xml
-application/index
-application/index.cmd
-application/index.obj
-application/index.response
-application/index.vnd
-application/iotp
-application/ipp
-application/isup
-application/javascript js
-application/json json
-application/kpml-request+xml
-application/kpml-response+xml
-application/lost+xml lostxml
-application/mac-binhex40 hqx
-application/mac-compactpro cpt
-application/macwriteii
-application/marc mrc
-application/mathematica ma nb mb
-application/mathml+xml mathml
-application/mbms-associated-procedure-description+xml
-application/mbms-deregister+xml
-application/mbms-envelope+xml
-application/mbms-msk+xml
-application/mbms-msk-response+xml
-application/mbms-protection-description+xml
-application/mbms-reception-report+xml
-application/mbms-register+xml
-application/mbms-register-response+xml
-application/mbms-user-service-description+xml
-application/mbox mbox
-application/media_control+xml
-application/mediaservercontrol+xml mscml
-application/mikey
-application/moss-keys
-application/moss-signature
-application/mosskey-data
-application/mosskey-request
-application/mp4 mp4s
-application/mpeg4-generic
-application/mpeg4-iod
-application/mpeg4-iod-xmt
-application/msword doc dot
-application/mxf mxf
-application/nasdata
-application/news-transmission
-application/nss
-application/ocsp-request
-application/ocsp-response
-application/octet-stream bin dms lha lzh class so iso dmg dist distz pkg bpk dump elc
-application/oda oda
-application/oebps-package+xml
-application/ogg ogx
-application/parityfec
-application/patch-ops-error+xml xer
-application/pdf pdf
-application/pgp-encrypted pgp
-application/pgp-keys
-application/pgp-signature asc sig
-application/pics-rules prf
-application/pidf+xml
-application/pidf-diff+xml
-application/pkcs10 p10
-application/pkcs7-mime p7m p7c
-application/pkcs7-signature p7s
-application/pkix-cert cer
-application/pkix-crl crl
-application/pkix-pkipath pkipath
-application/pkixcmp pki
-application/pls+xml pls
-application/poc-settings+xml
-application/postscript ai eps ps
-application/prs.alvestrand.titrax-sheet
-application/prs.cww cww
-application/prs.nprend
-application/prs.plucker
-application/qsig
-application/rdf+xml rdf
-application/reginfo+xml rif
-application/relax-ng-compact-syntax rnc
-application/remote-printing
-application/resource-lists+xml rl
-application/resource-lists-diff+xml rld
-application/riscos
-application/rlmi+xml
-application/rls-services+xml rs
-application/rsd+xml rsd
-application/rss+xml rss
-application/rtf rtf
-application/rtx
-application/samlassertion+xml
-application/samlmetadata+xml
-application/sbml+xml sbml
-application/scvp-cv-request scq
-application/scvp-cv-response scs
-application/scvp-vp-request spq
-application/scvp-vp-response spp
-application/sdp sdp
-application/set-payment
-application/set-payment-initiation setpay
-application/set-registration
-application/set-registration-initiation setreg
-application/sgml
-application/sgml-open-catalog
-application/shf+xml shf
-application/sieve
-application/simple-filter+xml
-application/simple-message-summary
-application/simplesymbolcontainer
-application/slate
-application/smil
-application/smil+xml smi smil
-application/soap+fastinfoset
-application/soap+xml
-application/sparql-query rq
-application/sparql-results+xml srx
-application/spirits-event+xml
-application/srgs gram
-application/srgs+xml grxml
-application/ssml+xml ssml
-application/timestamp-query
-application/timestamp-reply
-application/tve-trigger
-application/ulpfec
-application/vemmi
-application/vividence.scriptfile
-application/vnd.3gpp.bsf+xml
-application/vnd.3gpp.pic-bw-large plb
-application/vnd.3gpp.pic-bw-small psb
-application/vnd.3gpp.pic-bw-var pvb
-application/vnd.3gpp.sms
-application/vnd.3gpp2.bcmcsinfo+xml
-application/vnd.3gpp2.sms
-application/vnd.3gpp2.tcap tcap
-application/vnd.3m.post-it-notes pwn
-application/vnd.accpac.simply.aso aso
-application/vnd.accpac.simply.imp imp
-application/vnd.acucobol acu
-application/vnd.acucorp atc acutc
-application/vnd.adobe.xdp+xml xdp
-application/vnd.adobe.xfdf xfdf
-application/vnd.aether.imp
-application/vnd.americandynamics.acc acc
-application/vnd.amiga.ami ami
-application/vnd.anser-web-certificate-issue-initiation cii
-application/vnd.anser-web-funds-transfer-initiation fti
-application/vnd.antix.game-component atx
-application/vnd.apple.installer+xml mpkg
-application/vnd.arastra.swi swi
-application/vnd.audiograph aep
-application/vnd.autopackage
-application/vnd.avistar+xml
-application/vnd.blueice.multipass mpm
-application/vnd.bmi bmi
-application/vnd.businessobjects rep
-application/vnd.cab-jscript
-application/vnd.canon-cpdl
-application/vnd.canon-lips
-application/vnd.cendio.thinlinc.clientconf
-application/vnd.chemdraw+xml cdxml
-application/vnd.chipnuts.karaoke-mmd mmd
-application/vnd.cinderella cdy
-application/vnd.cirpack.isdn-ext
-application/vnd.claymore cla
-application/vnd.clonk.c4group c4g c4d c4f c4p c4u
-application/vnd.commerce-battelle
-application/vnd.commonspace csp cst
-application/vnd.contact.cmsg cdbcmsg
-application/vnd.cosmocaller cmc
-application/vnd.crick.clicker clkx
-application/vnd.crick.clicker.keyboard clkk
-application/vnd.crick.clicker.palette clkp
-application/vnd.crick.clicker.template clkt
-application/vnd.crick.clicker.wordbank clkw
-application/vnd.criticaltools.wbs+xml wbs
-application/vnd.ctc-posml pml
-application/vnd.ctct.ws+xml
-application/vnd.cups-pdf
-application/vnd.cups-postscript
-application/vnd.cups-ppd ppd
-application/vnd.cups-raster
-application/vnd.cups-raw
-application/vnd.curl curl
-application/vnd.cybank
-application/vnd.data-vision.rdz rdz
-application/vnd.denovo.fcselayout-link fe_launch
-application/vnd.dna dna
-application/vnd.dolby.mlp mlp
-application/vnd.dpgraph dpg
-application/vnd.dreamfactory dfac
-application/vnd.dvb.esgcontainer
-application/vnd.dvb.ipdcesgaccess
-application/vnd.dvb.iptv.alfec-base
-application/vnd.dvb.iptv.alfec-enhancement
-application/vnd.dxr
-application/vnd.ecdis-update
-application/vnd.ecowin.chart mag
-application/vnd.ecowin.filerequest
-application/vnd.ecowin.fileupdate
-application/vnd.ecowin.series
-application/vnd.ecowin.seriesrequest
-application/vnd.ecowin.seriesupdate
-application/vnd.enliven nml
-application/vnd.epson.esf esf
-application/vnd.epson.msf msf
-application/vnd.epson.quickanime qam
-application/vnd.epson.salt slt
-application/vnd.epson.ssf ssf
-application/vnd.ericsson.quickcall
-application/vnd.eszigno3+xml es3 et3
-application/vnd.eudora.data
-application/vnd.ezpix-album ez2
-application/vnd.ezpix-package ez3
-application/vnd.fdf fdf
-application/vnd.ffsns
-application/vnd.fints
-application/vnd.flographit gph
-application/vnd.fluxtime.clip ftc
-application/vnd.font-fontforge-sfd
-application/vnd.framemaker fm frame maker
-application/vnd.frogans.fnc fnc
-application/vnd.frogans.ltf ltf
-application/vnd.fsc.weblaunch fsc
-application/vnd.fujitsu.oasys oas
-application/vnd.fujitsu.oasys2 oa2
-application/vnd.fujitsu.oasys3 oa3
-application/vnd.fujitsu.oasysgp fg5
-application/vnd.fujitsu.oasysprs bh2
-application/vnd.fujixerox.art-ex
-application/vnd.fujixerox.art4
-application/vnd.fujixerox.hbpl
-application/vnd.fujixerox.ddd ddd
-application/vnd.fujixerox.docuworks xdw
-application/vnd.fujixerox.docuworks.binder xbd
-application/vnd.fut-misnet
-application/vnd.fuzzysheet fzs
-application/vnd.genomatix.tuxedo txd
-application/vnd.gmx gmx
-application/vnd.google-earth.kml+xml kml
-application/vnd.google-earth.kmz kmz
-application/vnd.grafeq gqf gqs
-application/vnd.gridmp
-application/vnd.groove-account gac
-application/vnd.groove-help ghf
-application/vnd.groove-identity-message gim
-application/vnd.groove-injector grv
-application/vnd.groove-tool-message gtm
-application/vnd.groove-tool-template tpl
-application/vnd.groove-vcard vcg
-application/vnd.handheld-entertainment+xml zmm
-application/vnd.hbci hbci
-application/vnd.hcl-bireports
-application/vnd.hhe.lesson-player les
-application/vnd.hp-hpgl hpgl
-application/vnd.hp-hpid hpid
-application/vnd.hp-hps hps
-application/vnd.hp-jlyt jlt
-application/vnd.hp-pcl pcl
-application/vnd.hp-pclxl pclxl
-application/vnd.httphone
-application/vnd.hydrostatix.sof-data sfd-hdstx
-application/vnd.hzn-3d-crossword x3d
-application/vnd.ibm.afplinedata
-application/vnd.ibm.electronic-media
-application/vnd.ibm.minipay mpy
-application/vnd.ibm.modcap afp listafp list3820
-application/vnd.ibm.rights-management irm
-application/vnd.ibm.secure-container sc
-application/vnd.iccprofile icc icm
-application/vnd.igloader igl
-application/vnd.immervision-ivp ivp
-application/vnd.immervision-ivu ivu
-application/vnd.informedcontrol.rms+xml
-application/vnd.intercon.formnet xpw xpx
-application/vnd.intertrust.digibox
-application/vnd.intertrust.nncp
-application/vnd.intu.qbo qbo
-application/vnd.intu.qfx qfx
-application/vnd.iptc.g2.conceptitem+xml
-application/vnd.iptc.g2.knowledgeitem+xml
-application/vnd.iptc.g2.newsitem+xml
-application/vnd.iptc.g2.packageitem+xml
-application/vnd.ipunplugged.rcprofile rcprofile
-application/vnd.irepository.package+xml irp
-application/vnd.is-xpr xpr
-application/vnd.jam jam
-application/vnd.japannet-directory-service
-application/vnd.japannet-jpnstore-wakeup
-application/vnd.japannet-payment-wakeup
-application/vnd.japannet-registration
-application/vnd.japannet-registration-wakeup
-application/vnd.japannet-setstore-wakeup
-application/vnd.japannet-verification
-application/vnd.japannet-verification-wakeup
-application/vnd.jcp.javame.midlet-rms rms
-application/vnd.jisp jisp
-application/vnd.joost.joda-archive joda
-application/vnd.kahootz ktz ktr
-application/vnd.kde.karbon karbon
-application/vnd.kde.kchart chrt
-application/vnd.kde.kformula kfo
-application/vnd.kde.kivio flw
-application/vnd.kde.kontour kon
-application/vnd.kde.kpresenter kpr kpt
-application/vnd.kde.kspread ksp
-application/vnd.kde.kword kwd kwt
-application/vnd.kenameaapp htke
-application/vnd.kidspiration kia
-application/vnd.kinar kne knp
-application/vnd.koan skp skd skt skm
-application/vnd.kodak-descriptor sse
-application/vnd.liberty-request+xml
-application/vnd.llamagraphics.life-balance.desktop lbd
-application/vnd.llamagraphics.life-balance.exchange+xml lbe
-application/vnd.lotus-1-2-3 123
-application/vnd.lotus-approach apr
-application/vnd.lotus-freelance pre
-application/vnd.lotus-notes nsf
-application/vnd.lotus-organizer org
-application/vnd.lotus-screencam scm
-application/vnd.lotus-wordpro lwp
-application/vnd.macports.portpkg portpkg
-application/vnd.marlin.drm.actiontoken+xml
-application/vnd.marlin.drm.conftoken+xml
-application/vnd.marlin.drm.license+xml
-application/vnd.marlin.drm.mdcf
-application/vnd.mcd mcd
-application/vnd.medcalcdata mc1
-application/vnd.mediastation.cdkey cdkey
-application/vnd.meridian-slingshot
-application/vnd.mfer mwf
-application/vnd.mfmp mfm
-application/vnd.micrografx.flo flo
-application/vnd.micrografx.igx igx
-application/vnd.mif mif
-application/vnd.minisoft-hp3000-save
-application/vnd.mitsubishi.misty-guard.trustweb
-application/vnd.mobius.daf daf
-application/vnd.mobius.dis dis
-application/vnd.mobius.mbk mbk
-application/vnd.mobius.mqy mqy
-application/vnd.mobius.msl msl
-application/vnd.mobius.plc plc
-application/vnd.mobius.txf txf
-application/vnd.mophun.application mpn
-application/vnd.mophun.certificate mpc
-application/vnd.motorola.flexsuite
-application/vnd.motorola.flexsuite.adsi
-application/vnd.motorola.flexsuite.fis
-application/vnd.motorola.flexsuite.gotap
-application/vnd.motorola.flexsuite.kmr
-application/vnd.motorola.flexsuite.ttc
-application/vnd.motorola.flexsuite.wem
-application/vnd.motorola.iprm
-application/vnd.mozilla.xul+xml xul
-application/vnd.ms-artgalry cil
-application/vnd.ms-asf asf
-application/vnd.ms-cab-compressed cab
-application/vnd.ms-excel xls xlm xla xlc xlt xlw
-application/vnd.ms-fontobject eot
-application/vnd.ms-htmlhelp chm
-application/vnd.ms-ims ims
-application/vnd.ms-lrm lrm
-application/vnd.ms-playready.initiator+xml
-application/vnd.ms-powerpoint ppt pps pot
-application/vnd.ms-project mpp mpt
-application/vnd.ms-tnef
-application/vnd.ms-wmdrm.lic-chlg-req
-application/vnd.ms-wmdrm.lic-resp
-application/vnd.ms-wmdrm.meter-chlg-req
-application/vnd.ms-wmdrm.meter-resp
-application/vnd.ms-works wps wks wcm wdb
-application/vnd.ms-wpl wpl
-application/vnd.ms-xpsdocument xps
-application/vnd.mseq mseq
-application/vnd.msign
-application/vnd.multiad.creator
-application/vnd.multiad.creator.cif
-application/vnd.music-niff
-application/vnd.musician mus
-application/vnd.muvee.style msty
-application/vnd.ncd.control
-application/vnd.ncd.reference
-application/vnd.nervana
-application/vnd.netfpx
-application/vnd.neurolanguage.nlu nlu
-application/vnd.noblenet-directory nnd
-application/vnd.noblenet-sealer nns
-application/vnd.noblenet-web nnw
-application/vnd.nokia.catalogs
-application/vnd.nokia.conml+wbxml
-application/vnd.nokia.conml+xml
-application/vnd.nokia.isds-radio-presets
-application/vnd.nokia.iptv.config+xml
-application/vnd.nokia.landmark+wbxml
-application/vnd.nokia.landmark+xml
-application/vnd.nokia.landmarkcollection+xml
-application/vnd.nokia.n-gage.ac+xml
-application/vnd.nokia.n-gage.data ngdat
-application/vnd.nokia.n-gage.symbian.install n-gage
-application/vnd.nokia.ncd
-application/vnd.nokia.pcd+wbxml
-application/vnd.nokia.pcd+xml
-application/vnd.nokia.radio-preset rpst
-application/vnd.nokia.radio-presets rpss
-application/vnd.novadigm.edm edm
-application/vnd.novadigm.edx edx
-application/vnd.novadigm.ext ext
-application/vnd.oasis.opendocument.chart odc
-application/vnd.oasis.opendocument.chart-template otc
-application/vnd.oasis.opendocument.formula odf
-application/vnd.oasis.opendocument.formula-template otf
-application/vnd.oasis.opendocument.graphics odg
-application/vnd.oasis.opendocument.graphics-template otg
-application/vnd.oasis.opendocument.image odi
-application/vnd.oasis.opendocument.image-template oti
-application/vnd.oasis.opendocument.presentation odp
-application/vnd.oasis.opendocument.presentation-template otp
-application/vnd.oasis.opendocument.spreadsheet ods
-application/vnd.oasis.opendocument.spreadsheet-template ots
-application/vnd.oasis.opendocument.text odt
-application/vnd.oasis.opendocument.text-master otm
-application/vnd.oasis.opendocument.text-template ott
-application/vnd.oasis.opendocument.text-web oth
-application/vnd.obn
-application/vnd.olpc-sugar xo
-application/vnd.oma-scws-config
-application/vnd.oma-scws-http-request
-application/vnd.oma-scws-http-response
-application/vnd.oma.bcast.associated-procedure-parameter+xml
-application/vnd.oma.bcast.drm-trigger+xml
-application/vnd.oma.bcast.imd+xml
-application/vnd.oma.bcast.ltkm
-application/vnd.oma.bcast.notification+xml
-application/vnd.oma.bcast.provisioningtrigger
-application/vnd.oma.bcast.sgboot
-application/vnd.oma.bcast.sgdd+xml
-application/vnd.oma.bcast.sgdu
-application/vnd.oma.bcast.simple-symbol-container
-application/vnd.oma.bcast.smartcard-trigger+xml
-application/vnd.oma.bcast.sprov+xml
-application/vnd.oma.bcast.stkm
-application/vnd.oma.dcd
-application/vnd.oma.dcdc
-application/vnd.oma.dd2+xml dd2
-application/vnd.oma.drm.risd+xml
-application/vnd.oma.group-usage-list+xml
-application/vnd.oma.poc.detailed-progress-report+xml
-application/vnd.oma.poc.final-report+xml
-application/vnd.oma.poc.groups+xml
-application/vnd.oma.poc.invocation-descriptor+xml
-application/vnd.oma.poc.optimized-progress-report+xml
-application/vnd.oma.xcap-directory+xml
-application/vnd.omads-email+xml
-application/vnd.omads-file+xml
-application/vnd.omads-folder+xml
-application/vnd.omaloc-supl-init
-application/vnd.openofficeorg.extension oxt
-application/vnd.osa.netdeploy
-application/vnd.osgi.dp dp
-application/vnd.otps.ct-kip+xml
-application/vnd.palm prc pdb pqa oprc
-application/vnd.paos.xml
-application/vnd.pg.format str
-application/vnd.pg.osasli ei6
-application/vnd.piaccess.application-licence
-application/vnd.picsel efif
-application/vnd.poc.group-advertisement+xml
-application/vnd.pocketlearn plf
-application/vnd.powerbuilder6 pbd
-application/vnd.powerbuilder6-s
-application/vnd.powerbuilder7
-application/vnd.powerbuilder7-s
-application/vnd.powerbuilder75
-application/vnd.powerbuilder75-s
-application/vnd.preminet
-application/vnd.previewsystems.box box
-application/vnd.proteus.magazine mgz
-application/vnd.publishare-delta-tree qps
-application/vnd.pvi.ptid1 ptid
-application/vnd.pwg-multiplexed
-application/vnd.pwg-xhtml-print+xml
-application/vnd.qualcomm.brew-app-res
-application/vnd.quark.quarkxpress qxd qxt qwd qwt qxl qxb
-application/vnd.rapid
-application/vnd.recordare.musicxml mxl
-application/vnd.recordare.musicxml+xml
-application/vnd.renlearn.rlprint
-application/vnd.rn-realmedia rm
-application/vnd.route66.link66+xml link66
-application/vnd.ruckus.download
-application/vnd.s3sms
-application/vnd.sbm.mid2
-application/vnd.scribus
-application/vnd.sealed.3df
-application/vnd.sealed.csf
-application/vnd.sealed.doc
-application/vnd.sealed.eml
-application/vnd.sealed.mht
-application/vnd.sealed.net
-application/vnd.sealed.ppt
-application/vnd.sealed.tiff
-application/vnd.sealed.xls
-application/vnd.sealedmedia.softseal.html
-application/vnd.sealedmedia.softseal.pdf
-application/vnd.seemail see
-application/vnd.sema sema
-application/vnd.semd semd
-application/vnd.semf semf
-application/vnd.shana.informed.formdata ifm
-application/vnd.shana.informed.formtemplate itp
-application/vnd.shana.informed.interchange iif
-application/vnd.shana.informed.package ipk
-application/vnd.simtech-mindmapper twd twds
-application/vnd.smaf mmf
-application/vnd.software602.filler.form+xml
-application/vnd.software602.filler.form-xml-zip
-application/vnd.solent.sdkm+xml sdkm sdkd
-application/vnd.spotfire.dxp dxp
-application/vnd.spotfire.sfs sfs
-application/vnd.sss-cod
-application/vnd.sss-dtf
-application/vnd.sss-ntf
-application/vnd.street-stream
-application/vnd.sun.wadl+xml
-application/vnd.sus-calendar sus susp
-application/vnd.svd svd
-application/vnd.swiftview-ics
-application/vnd.syncml+xml xsm
-application/vnd.syncml.dm+wbxml bdm
-application/vnd.syncml.dm+xml xdm
-application/vnd.syncml.ds.notification
-application/vnd.tao.intent-module-archive tao
-application/vnd.tmobile-livetv tmo
-application/vnd.trid.tpt tpt
-application/vnd.triscape.mxs mxs
-application/vnd.trueapp tra
-application/vnd.truedoc
-application/vnd.ufdl ufd ufdl
-application/vnd.uiq.theme utz
-application/vnd.umajin umj
-application/vnd.unity unityweb
-application/vnd.uoml+xml uoml
-application/vnd.uplanet.alert
-application/vnd.uplanet.alert-wbxml
-application/vnd.uplanet.bearer-choice
-application/vnd.uplanet.bearer-choice-wbxml
-application/vnd.uplanet.cacheop
-application/vnd.uplanet.cacheop-wbxml
-application/vnd.uplanet.channel
-application/vnd.uplanet.channel-wbxml
-application/vnd.uplanet.list
-application/vnd.uplanet.list-wbxml
-application/vnd.uplanet.listcmd
-application/vnd.uplanet.listcmd-wbxml
-application/vnd.uplanet.signal
-application/vnd.vcx vcx
-application/vnd.vd-study
-application/vnd.vectorworks
-application/vnd.vidsoft.vidconference
-application/vnd.visio vsd vst vss vsw
-application/vnd.visionary vis
-application/vnd.vividence.scriptfile
-application/vnd.vsf vsf
-application/vnd.wap.sic
-application/vnd.wap.slc
-application/vnd.wap.wbxml wbxml
-application/vnd.wap.wmlc wmlc
-application/vnd.wap.wmlscriptc wmlsc
-application/vnd.webturbo wtb
-application/vnd.wfa.wsc
-application/vnd.wmc
-application/vnd.wmf.bootstrap
-application/vnd.wordperfect wpd
-application/vnd.wqd wqd
-application/vnd.wrq-hp3000-labelled
-application/vnd.wt.stf stf
-application/vnd.wv.csp+wbxml
-application/vnd.wv.csp+xml
-application/vnd.wv.ssp+xml
-application/vnd.xara xar
-application/vnd.xfdl xfdl
-application/vnd.xmi+xml
-application/vnd.xmpie.cpkg
-application/vnd.xmpie.dpkg
-application/vnd.xmpie.plan
-application/vnd.xmpie.ppkg
-application/vnd.xmpie.xlim
-application/vnd.yamaha.hv-dic hvd
-application/vnd.yamaha.hv-script hvs
-application/vnd.yamaha.hv-voice hvp
-application/vnd.yamaha.smaf-audio saf
-application/vnd.yamaha.smaf-phrase spf
-application/vnd.yellowriver-custom-menu cmp
-application/vnd.zzazz.deck+xml zaz
-application/voicexml+xml vxml
-application/watcherinfo+xml
-application/whoispp-query
-application/whoispp-response
-application/winhlp hlp
-application/wita
-application/wordperfect5.1
-application/wsdl+xml wsdl
-application/wspolicy+xml wspolicy
-application/x-ace-compressed ace
-application/x-bcpio bcpio
-application/x-bittorrent torrent
-application/x-bzip bz
-application/x-bzip2 bz2 boz
-application/x-cdlink vcd
-application/x-chat chat
-application/x-chess-pgn pgn
-application/x-compress
-application/x-cpio cpio
-application/x-csh csh
-application/x-director dcr dir dxr fgd
-application/x-dvi dvi
-application/x-futuresplash spl
-application/x-gtar gtar
-application/x-gzip
-application/x-hdf hdf
-application/x-latex latex
-application/x-ms-wmd wmd
-application/x-ms-wmz wmz
-application/x-msaccess mdb
-application/x-msbinder obd
-application/x-mscardfile crd
-application/x-msclip clp
-application/x-msdownload exe dll com bat msi
-application/x-msmediaview mvb m13 m14
-application/x-msmetafile wmf
-application/x-msmoney mny
-application/x-mspublisher pub
-application/x-msschedule scd
-application/x-msterminal trm
-application/x-mswrite wri
-application/x-netcdf nc cdf
-application/x-pkcs12 p12 pfx
-application/x-pkcs7-certificates p7b spc
-application/x-pkcs7-certreqresp p7r
-application/x-rar-compressed rar
-application/x-sh sh
-application/x-shar shar
-application/x-shockwave-flash swf
-application/x-stuffit sit
-application/x-stuffitx sitx
-application/x-sv4cpio sv4cpio
-application/x-sv4crc sv4crc
-application/x-tar tar
-application/x-tcl tcl
-application/x-tex tex
-application/x-texinfo texinfo texi
-application/x-ustar ustar
-application/x-wais-source src
-application/x-x509-ca-cert der crt
-application/x400-bp
-application/xcap-att+xml
-application/xcap-caps+xml
-application/xcap-el+xml
-application/xcap-error+xml
-application/xcap-ns+xml
-application/xenc+xml xenc
-application/xhtml+xml xhtml xht
-application/xml xml xsl
-application/xml-dtd dtd
-application/xml-external-parsed-entity
-application/xmpp+xml
-application/xop+xml xop
-application/xslt+xml xslt
-application/xspf+xml xspf
-application/xv+xml mxml xhvml xvml xvm
-application/zip zip
-audio/32kadpcm
-audio/3gpp
-audio/3gpp2
-audio/ac3
-audio/amr
-audio/amr-wb
-audio/amr-wb+
-audio/asc
-audio/basic au snd
-audio/bv16
-audio/bv32
-audio/clearmode
-audio/cn
-audio/dat12
-audio/dls
-audio/dsr-es201108
-audio/dsr-es202050
-audio/dsr-es202211
-audio/dsr-es202212
-audio/dvi4
-audio/eac3
-audio/evrc
-audio/evrc-qcp
-audio/evrc0
-audio/evrc1
-audio/evrcb
-audio/evrcb0
-audio/evrcb1
-audio/evrcwb
-audio/evrcwb0
-audio/evrcwb1
-audio/g722
-audio/g7221
-audio/g723
-audio/g726-16
-audio/g726-24
-audio/g726-32
-audio/g726-40
-audio/g728
-audio/g729
-audio/g7291
-audio/g729d
-audio/g729e
-audio/gsm
-audio/gsm-efr
-audio/ilbc
-audio/l16
-audio/l20
-audio/l24
-audio/l8
-audio/lpc
-audio/midi mid midi kar rmi
-audio/mobile-xmf
-audio/mp4 mp4a
-audio/mp4a-latm
-audio/mpa
-audio/mpa-robust
-audio/mpeg mpga mp2 mp2a mp3 m2a m3a
-audio/mpeg4-generic
-audio/ogg oga ogg spx
-audio/parityfec
-audio/pcma
-audio/pcmu
-audio/prs.sid
-audio/qcelp
-audio/red
-audio/rtp-enc-aescm128
-audio/rtp-midi
-audio/rtx
-audio/smv
-audio/smv0
-audio/smv-qcp
-audio/sp-midi
-audio/t140c
-audio/t38
-audio/telephone-event
-audio/tone
-audio/ulpfec
-audio/vdvi
-audio/vmr-wb
-audio/vnd.3gpp.iufp
-audio/vnd.4sb
-audio/vnd.audiokoz
-audio/vnd.celp
-audio/vnd.cisco.nse
-audio/vnd.cmles.radio-events
-audio/vnd.cns.anp1
-audio/vnd.cns.inf1
-audio/vnd.digital-winds eol
-audio/vnd.dlna.adts
-audio/vnd.dolby.mlp
-audio/vnd.dts dts
-audio/vnd.dts.hd dtshd
-audio/vnd.everad.plj
-audio/vnd.hns.audio
-audio/vnd.lucent.voice lvp
-audio/vnd.ms-playready.media.pya pya
-audio/vnd.nokia.mobile-xmf
-audio/vnd.nortel.vbk
-audio/vnd.nuera.ecelp4800 ecelp4800
-audio/vnd.nuera.ecelp7470 ecelp7470
-audio/vnd.nuera.ecelp9600 ecelp9600
-audio/vnd.octel.sbc
-audio/vnd.qcelp
-audio/vnd.rhetorex.32kadpcm
-audio/vnd.sealedmedia.softseal.mpeg
-audio/vnd.vmx.cvsd
-audio/vorbis
-audio/vorbis-config
-audio/wav wav
-audio/x-aiff aif aiff aifc
-audio/x-mpegurl m3u
-audio/x-ms-wax wax
-audio/x-ms-wma wma
-audio/x-pn-realaudio ram ra
-audio/x-pn-realaudio-plugin rmp
-audio/x-wav wav
-chemical/x-cdx cdx
-chemical/x-cif cif
-chemical/x-cmdf cmdf
-chemical/x-cml cml
-chemical/x-csml csml
-chemical/x-pdb pdb
-chemical/x-xyz xyz
-image/bmp bmp
-image/cgm cgm
-image/fits
-image/g3fax g3
-image/gif gif
-image/ief ief
-image/jp2
-image/jpeg jpeg jpg jpe
-image/jpm
-image/jpx
-image/naplps
-image/png png
-image/prs.btif btif
-image/prs.pti
-image/svg+xml svg svgz
-image/t38
-image/tiff tiff tif
-image/tiff-fx
-image/vnd.adobe.photoshop psd
-image/vnd.cns.inf2
-image/vnd.djvu djvu djv
-image/vnd.dwg dwg
-image/vnd.dxf dxf
-image/vnd.fastbidsheet fbs
-image/vnd.fpx fpx
-image/vnd.fst fst
-image/vnd.fujixerox.edmics-mmr mmr
-image/vnd.fujixerox.edmics-rlc rlc
-image/vnd.globalgraphics.pgb
-image/vnd.microsoft.icon
-image/vnd.mix
-image/vnd.ms-modi mdi
-image/vnd.net-fpx npx
-image/vnd.sealed.png
-image/vnd.sealedmedia.softseal.gif
-image/vnd.sealedmedia.softseal.jpg
-image/vnd.svf
-image/vnd.wap.wbmp wbmp
-image/vnd.xiff xif
-image/x-cmu-raster ras
-image/x-cmx cmx
-image/x-icon ico
-image/x-pcx pcx
-image/x-pict pic pct
-image/x-portable-anymap pnm
-image/x-portable-bitmap pbm
-image/x-portable-graymap pgm
-image/x-portable-pixmap ppm
-image/x-rgb rgb
-image/x-xbitmap xbm
-image/x-xpixmap xpm
-image/x-xwindowdump xwd
-message/cpim
-message/delivery-status
-message/disposition-notification
-message/external-body
-message/global
-message/global-delivery-status
-message/global-disposition-notification
-message/global-headers
-message/http
-message/news
-message/partial
-message/rfc822 eml mime
-message/s-http
-message/sip
-message/sipfrag
-message/tracking-status
-message/vnd.si.simp
-model/iges igs iges
-model/mesh msh mesh silo
-model/vnd.dwf dwf
-model/vnd.flatland.3dml
-model/vnd.gdl gdl
-model/vnd.gs.gdl
-model/vnd.gtw gtw
-model/vnd.moml+xml
-model/vnd.mts mts
-model/vnd.parasolid.transmit.binary
-model/vnd.parasolid.transmit.text
-model/vnd.vtu vtu
-model/vrml wrl vrml
-multipart/alternative
-multipart/appledouble
-multipart/byteranges
-multipart/digest
-multipart/encrypted
-multipart/form-data
-multipart/header-set
-multipart/mixed
-multipart/parallel
-multipart/related
-multipart/report
-multipart/signed
-multipart/voice-message
-text/calendar ics ifb
-text/css css
-text/csv csv
-text/directory
-text/dns
-text/enriched
-text/html html htm
-text/parityfec
-text/plain txt text conf def list log in
-text/prs.fallenstein.rst
-text/prs.lines.tag dsc
-text/red
-text/rfc822-headers
-text/richtext rtx
-text/rtf
-text/rtp-enc-aescm128
-text/rtx
-text/sgml sgml sgm
-text/t140
-text/tab-separated-values tsv
-text/troff t tr roff man me ms
-text/ulpfec
-text/uri-list uri uris urls
-text/vnd.abc
-text/vnd.curl
-text/vnd.dmclientscript
-text/vnd.esmertec.theme-descriptor
-text/vnd.fly fly
-text/vnd.fmi.flexstor flx
-text/vnd.graphviz gv
-text/vnd.in3d.3dml 3dml
-text/vnd.in3d.spot spot
-text/vnd.iptc.newsml
-text/vnd.iptc.nitf
-text/vnd.latex-z
-text/vnd.motorola.reflex
-text/vnd.ms-mediapackage
-text/vnd.net2phone.commcenter.command
-text/vnd.si.uricatalogue
-text/vnd.sun.j2me.app-descriptor jad
-text/vnd.trolltech.linguist
-text/vnd.wap.si
-text/vnd.wap.sl
-text/vnd.wap.wml wml
-text/vnd.wap.wmlscript wmls
-text/x-asm s asm
-text/x-c c cc cxx cpp h hh dic
-text/x-fortran f for f77 f90
-text/x-pascal p pas
-text/x-java-source java
-text/x-setext etx
-text/x-uuencode uu
-text/x-vcalendar vcs
-text/x-vcard vcf
-text/xml
-text/xml-external-parsed-entity
-video/3gpp 3gp
-video/3gpp-tt
-video/3gpp2 3g2
-video/bmpeg
-video/bt656
-video/celb
-video/dv
-video/h261 h261
-video/h263 h263
-video/h263-1998
-video/h263-2000
-video/h264 h264
-video/jpeg jpgv
-video/jpeg2000
-video/jpm jpm jpgm
-video/mj2 mj2 mjp2
-video/mp1s
-video/mp2p
-video/mp2t
-video/mp4 mp4 mp4v mpg4
-video/mp4v-es
-video/mpeg mpeg mpg mpe m1v m2v
-video/mpeg4-generic
-video/mpv
-video/nv
-video/ogg ogv
-video/parityfec
-video/pointer
-video/quicktime qt mov
-video/raw
-video/rtp-enc-aescm128
-video/rtx
-video/smpte292m
-video/ulpfec
-video/vc1
-video/vnd.cctv
-video/vnd.dlna.mpeg-tts
-video/vnd.fvt fvt
-video/vnd.hns.video
-video/vnd.iptvforum.1dparityfec-1010
-video/vnd.iptvforum.1dparityfec-2005
-video/vnd.iptvforum.2dparityfec-1010
-video/vnd.iptvforum.2dparityfec-2005
-video/vnd.iptvforum.ttsavc
-video/vnd.iptvforum.ttsmpeg2
-video/vnd.motorola.video
-video/vnd.motorola.videop
-video/vnd.mpegurl mxu m4u
-video/vnd.ms-playready.media.pyv pyv
-video/vnd.nokia.interleaved-multimedia
-video/vnd.nokia.videovoip
-video/vnd.objectvideo
-video/vnd.sealed.mpeg1
-video/vnd.sealed.mpeg4
-video/vnd.sealed.swf
-video/vnd.sealedmedia.softseal.mov
-video/vnd.vivo viv
-video/x-fli fli
-video/x-ms-asf asf asx
-video/x-ms-wm wm
-video/x-ms-wmv wmv
-video/x-ms-wmx wmx
-video/x-ms-wvx wvx
-video/x-msvideo avi
-video/x-sgi-movie movie
-x-conference/x-cooltalk ice
+++ /dev/null
-package Net::HTTP;
-
-use strict;
-use vars qw($VERSION @ISA $SOCKET_CLASS);
-
-$VERSION = "5.834";
-unless ($SOCKET_CLASS) {
- eval { require IO::Socket::INET } || require IO::Socket;
- $SOCKET_CLASS = "IO::Socket::INET";
-}
-require Net::HTTP::Methods;
-require Carp;
-
-@ISA = ($SOCKET_CLASS, '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);
-}
-
-sub http_connect {
- my($self, $cnf) = @_;
- $self->SUPER::configure($cnf);
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::HTTP - Low-level HTTP connection (client)
-
-=head1 SYNOPSIS
-
- use Net::HTTP;
- my $s = Net::HTTP->new(Host => "www.perl.com") || die $@;
- $s->write_request(GET => "/", 'User-Agent' => "Mozilla/5.0");
- my($code, $mess, %h) = $s->read_response_headers;
-
- while (1) {
- my $buf;
- my $n = $s->read_entity_body($buf, 1024);
- die "read failed: $!" unless defined $n;
- last unless $n;
- print $buf;
- }
-
-=head1 DESCRIPTION
-
-The C<Net::HTTP> class is a low-level HTTP client. An instance of the
-C<Net::HTTP> class represents a connection to an HTTP server. The
-HTTP protocol is described in RFC 2616. The C<Net::HTTP> class
-supports C<HTTP/1.0> and C<HTTP/1.1>.
-
-C<Net::HTTP> is a sub-class of C<IO::Socket::INET>. You can mix the
-methods described below with reading and writing from the socket
-directly. This is not necessary a good idea, unless you know what you
-are doing.
-
-The following methods are provided (in addition to those of
-C<IO::Socket::INET>):
-
-=over
-
-=item $s = Net::HTTP->new( %options )
-
-The C<Net::HTTP> constructor method takes the same options as
-C<IO::Socket::INET>'s as well as these:
-
- Host: Initial host attribute value
- KeepAlive: Initial keep_alive attribute value
- SendTE: Initial send_te attribute_value
- HTTPVersion: Initial http_version attribute value
- PeerHTTPVersion: Initial peer_http_version attribute value
- MaxLineLength: Initial max_line_length attribute value
- MaxHeaderLines: Initial max_header_lines attribute value
-
-The C<Host> option is also the default for C<IO::Socket::INET>'s
-C<PeerAddr>. The C<PeerPort> defaults to 80 if not provided.
-
-The C<Listen> option provided by C<IO::Socket::INET>'s constructor
-method is not allowed.
-
-If unable to connect to the given HTTP server then the constructor
-returns C<undef> and $@ contains the reason. After a successful
-connect, a C<Net:HTTP> object is returned.
-
-=item $s->host
-
-Get/set the default value of the C<Host> header to send. The $host
-must not be set to an empty string (or C<undef>) for HTTP/1.1.
-
-=item $s->keep_alive
-
-Get/set the I<keep-alive> value. If this value is TRUE then the
-request will be sent with headers indicating that the server should try
-to keep the connection open so that multiple requests can be sent.
-
-The actual headers set will depend on the value of the C<http_version>
-and C<peer_http_version> attributes.
-
-=item $s->send_te
-
-Get/set the a value indicating if the request will be sent with a "TE"
-header to indicate the transfer encodings that the server can choose to
-use. The list of encodings announced as accepted by this client depends
-on availability of the following modules: C<Compress::Raw::Zlib> for
-I<deflate>, and C<IO::Compress::Gunzip> for I<gzip>.
-
-=item $s->http_version
-
-Get/set the HTTP version number that this client should announce.
-This value can only be set to "1.0" or "1.1". The default is "1.1".
-
-=item $s->peer_http_version
-
-Get/set the protocol version number of our peer. This value will
-initially be "1.0", but will be updated by a successful
-read_response_headers() method call.
-
-=item $s->max_line_length
-
-Get/set a limit on the length of response line and response header
-lines. The default is 8192. A value of 0 means no limit.
-
-=item $s->max_header_length
-
-Get/set a limit on the number of header lines that a response can
-have. The default is 128. A value of 0 means no limit.
-
-=item $s->format_request($method, $uri, %headers, [$content])
-
-Format a request message and return it as a string. If the headers do
-not include a C<Host> header, then a header is inserted with the value
-of the C<host> attribute. Headers like C<Connection> and
-C<Keep-Alive> might also be added depending on the status of the
-C<keep_alive> attribute.
-
-If $content is given (and it is non-empty), then a C<Content-Length>
-header is automatically added unless it was already present.
-
-=item $s->write_request($method, $uri, %headers, [$content])
-
-Format and send a request message. Arguments are the same as for
-format_request(). Returns true if successful.
-
-=item $s->format_chunk( $data )
-
-Returns the string to be written for the given chunk of data.
-
-=item $s->write_chunk($data)
-
-Will write a new chunk of request entity body data. This method
-should only be used if the C<Transfer-Encoding> header with a value of
-C<chunked> was sent in the request. Note, writing zero-length data is
-a no-op. Use the write_chunk_eof() method to signal end of entity
-body data.
-
-Returns true if successful.
-
-=item $s->format_chunk_eof( %trailers )
-
-Returns the string to be written for signaling EOF when a
-C<Transfer-Encoding> of C<chunked> is used.
-
-=item $s->write_chunk_eof( %trailers )
-
-Will write eof marker for chunked data and optional trailers. Note
-that trailers should not really be used unless is was signaled
-with a C<Trailer> header.
-
-Returns true if successful.
-
-=item ($code, $mess, %headers) = $s->read_response_headers( %opts )
-
-Read response headers from server and return it. The $code is the 3
-digit HTTP status code (see L<HTTP::Status>) and $mess is the textual
-message that came with it. Headers are then returned as key/value
-pairs. Since key letter casing is not normalized and the same key can
-even occur multiple times, assigning these values directly to a hash
-is not wise. Only the $code is returned if this method is called in
-scalar context.
-
-As a side effect this method updates the 'peer_http_version'
-attribute.
-
-Options might be passed in as key/value pairs. There are currently
-only two options supported; C<laxed> and C<junk_out>.
-
-The C<laxed> option will make read_response_headers() more forgiving
-towards servers that have not learned how to speak HTTP properly. The
-C<laxed> option is a boolean flag, and is enabled by passing in a TRUE
-value. The C<junk_out> option can be used to capture bad header lines
-when C<laxed> is enabled. The value should be an array reference.
-Bad header lines will be pushed onto the array.
-
-The C<laxed> option must be specified in order to communicate with
-pre-HTTP/1.0 servers that don't describe the response outcome or the
-data they send back with a header block. For these servers
-peer_http_version is set to "0.9" and this method returns (200,
-"Assumed OK").
-
-The method will raise an exception (die) if the server does not speak
-proper HTTP or if the C<max_line_length> or C<max_header_length>
-limits are reached. If the C<laxed> option is turned on and
-C<max_line_length> and C<max_header_length> checks are turned off,
-then no exception will be raised and this method will always
-return a response code.
-
-=item $n = $s->read_entity_body($buf, $size);
-
-Reads chunks of the entity body content. Basically the same interface
-as for read() and sysread(), but the buffer offset argument is not
-supported yet. This method should only be called after a successful
-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 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.
-
-=item %headers = $s->get_trailers
-
-After read_entity_body() has returned 0 to indicate end of the entity
-body, you might call this method to pick up any trailers.
-
-=item $s->_rbuf
-
-Get/set the read buffer content. The read_response_headers() and
-read_entity_body() methods use an internal buffer which they will look
-for data before they actually sysread more from the socket itself. If
-they read too much, the remaining data will be left in this buffer.
-
-=item $s->_rbuf_length
-
-Returns the number of bytes in the read buffer. This should always be
-the same as:
-
- length($s->_rbuf)
-
-but might be more efficient.
-
-=back
-
-=head1 SUBCLASSING
-
-The read_response_headers() and read_entity_body() will invoke the
-sysread() method when they need more data. Subclasses might want to
-override this method to control how reading takes place.
-
-The object itself is a glob. Subclasses should avoid using hash key
-names prefixed with C<http_> and C<io_>.
-
-=head1 SEE ALSO
-
-L<LWP>, L<IO::Socket::INET>, L<Net::HTTP::NB>
-
-=head1 COPYRIGHT
-
-Copyright 2001-2003 Gisle Aas.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=cut
+++ /dev/null
-package Net::HTTP::Methods;
-
-require 5.005; # 4-arg substr
-
-use strict;
-use vars qw($VERSION);
-
-$VERSION = "5.834";
-
-my $CRLF = "\015\012"; # "\r\n" is not portable
-
-*_bytes = defined(&utf8::downgrade) ?
- sub {
- unless (utf8::downgrade($_[0], 1)) {
- require Carp;
- Carp::croak("Wide character in HTTP request (bytes required)");
- }
- return $_[0];
- }
- :
- sub {
- return $_[0];
- };
-
-
-sub new {
- my $class = shift;
- unshift(@_, "Host") if @_ == 1;
- my %cnf = @_;
- require Symbol;
- my $self = bless Symbol::gensym(), $class;
- return $self->http_configure(\%cnf);
-}
-
-sub http_configure {
- my($self, $cnf) = @_;
-
- die "Listen option not allowed" if $cnf->{Listen};
- my $explict_host = (exists $cnf->{Host});
- my $host = delete $cnf->{Host};
- my $peer = $cnf->{PeerAddr} || $cnf->{PeerHost};
- 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;
- }
-
- if (!$explict_host) {
- $host = $peer;
- $host =~ s/:.*//;
- }
- if ($host && $host !~ /:/) {
- my $p = $cnf->{PeerPort};
- $host .= ":$p" if $p != $self->http_default_port;
- }
-
- $cnf->{Proto} = 'tcp';
-
- my $keep_alive = delete $cnf->{KeepAlive};
- my $http_version = delete $cnf->{HTTPVersion};
- $http_version = "1.1" unless defined $http_version;
- my $peer_http_version = delete $cnf->{PeerHTTPVersion};
- $peer_http_version = "1.0" unless defined $peer_http_version;
- my $send_te = delete $cnf->{SendTE};
- my $max_line_length = delete $cnf->{MaxLineLength};
- $max_line_length = 8*1024 unless defined $max_line_length;
- my $max_header_lines = delete $cnf->{MaxHeaderLines};
- $max_header_lines = 128 unless defined $max_header_lines;
-
- return undef unless $self->http_connect($cnf);
-
- $self->host($host);
- $self->keep_alive($keep_alive);
- $self->send_te($send_te);
- $self->http_version($http_version);
- $self->peer_http_version($peer_http_version);
- $self->max_line_length($max_line_length);
- $self->max_header_lines($max_header_lines);
-
- ${*$self}{'http_buf'} = "";
-
- return $self;
-}
-
-sub http_default_port {
- 80;
-}
-
-# set up property accessors
-for my $method (qw(host keep_alive send_te max_line_length max_header_lines peer_http_version)) {
- my $prop_name = "http_" . $method;
- no strict 'refs';
- *$method = sub {
- my $self = shift;
- my $old = ${*$self}{$prop_name};
- ${*$self}{$prop_name} = shift if @_;
- return $old;
- };
-}
-
-# we want this one to be a bit smarter
-sub http_version {
- my $self = shift;
- my $old = ${*$self}{'http_version'};
- if (@_) {
- my $v = shift;
- $v = "1.0" if $v eq "1"; # float
- unless ($v eq "1.0" or $v eq "1.1") {
- require Carp;
- Carp::croak("Unsupported HTTP version '$v'");
- }
- ${*$self}{'http_version'} = $v;
- }
- $old;
-}
-
-sub format_request {
- my $self = shift;
- my $method = shift;
- my $uri = shift;
-
- my $content = (@_ % 2) ? pop : "";
-
- for ($method, $uri) {
- require Carp;
- Carp::croak("Bad method or uri") if /\s/ || !length;
- }
-
- push(@{${*$self}{'http_request_method'}}, $method);
- my $ver = ${*$self}{'http_version'};
- my $peer_ver = ${*$self}{'http_peer_http_version'} || "1.0";
-
- my @h;
- my @connection;
- my %given = (host => 0, "content-length" => 0, "te" => 0);
- while (@_) {
- my($k, $v) = splice(@_, 0, 2);
- my $lc_k = lc($k);
- if ($lc_k eq "connection") {
- $v =~ s/^\s+//;
- $v =~ s/\s+$//;
- push(@connection, split(/\s*,\s*/, $v));
- next;
- }
- if (exists $given{$lc_k}) {
- $given{$lc_k}++;
- }
- push(@h, "$k: $v");
- }
-
- if (length($content) && !$given{'content-length'}) {
- push(@h, "Content-Length: " . length($content));
- }
-
- my @h2;
- if ($given{te}) {
- push(@connection, "TE") unless grep lc($_) eq "te", @connection;
- }
- elsif ($self->send_te && gunzip_ok()) {
- # gzip is less wanted since the IO::Uncompress::Gunzip interface for
- # it does not really allow chunked decoding to take place easily.
- push(@h2, "TE: deflate,gzip;q=0.3");
- push(@connection, "TE");
- }
-
- unless (grep lc($_) eq "close", @connection) {
- if ($self->keep_alive) {
- if ($peer_ver eq "1.0") {
- # from looking at Netscape's headers
- push(@h2, "Keep-Alive: 300");
- unshift(@connection, "Keep-Alive");
- }
- }
- else {
- push(@connection, "close") if $ver ge "1.1";
- }
- }
- push(@h2, "Connection: " . join(", ", @connection)) if @connection;
- unless ($given{host}) {
- my $h = ${*$self}{'http_host'};
- push(@h2, "Host: $h") if $h;
- }
-
- return _bytes(join($CRLF, "$method $uri HTTP/$ver", @h2, @h, "", $content));
-}
-
-
-sub write_request {
- my $self = shift;
- $self->print($self->format_request(@_));
-}
-
-sub format_chunk {
- my $self = shift;
- return $_[0] unless defined($_[0]) && length($_[0]);
- return _bytes(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF);
-}
-
-sub write_chunk {
- my $self = shift;
- return 1 unless defined($_[0]) && length($_[0]);
- $self->print(_bytes(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF));
-}
-
-sub format_chunk_eof {
- my $self = shift;
- my @h;
- while (@_) {
- push(@h, sprintf "%s: %s$CRLF", splice(@_, 0, 2));
- }
- return _bytes(join("", "0$CRLF", @h, $CRLF));
-}
-
-sub write_chunk_eof {
- my $self = shift;
- $self->print($self->format_chunk_eof(@_));
-}
-
-
-sub my_read {
- die if @_ > 3;
- my $self = shift;
- my $len = $_[1];
- for (${*$self}{'http_buf'}) {
- if (length) {
- $_[0] = substr($_, 0, $len, "");
- return length($_[0]);
- }
- else {
- return $self->sysread($_[0], $len);
- }
- }
-}
-
-
-sub my_readline {
- my $self = shift;
- my $what = shift;
- for (${*$self}{'http_buf'}) {
- my $max_line_length = ${*$self}{'http_max_line_length'};
- my $pos;
- while (1) {
- # find line ending
- $pos = index($_, "\012");
- last if $pos >= 0;
- die "$what line too long (limit is $max_line_length)"
- if $max_line_length && length($_) > $max_line_length;
-
- # need to read more data to find a line ending
- 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 "$what read failed: $!" unless length;
- }
- unless ($n) {
- return undef unless length;
- return substr($_, 0, length, "");
- }
- }
- }
- die "$what line too long ($pos; limit is $max_line_length)"
- if $max_line_length && $pos > $max_line_length;
-
- my $line = substr($_, 0, $pos+1, "");
- $line =~ s/(\015?\012)\z// || die "Assert";
- return wantarray ? ($line, $1) : $line;
- }
-}
-
-
-sub _rbuf {
- my $self = shift;
- if (@_) {
- for (${*$self}{'http_buf'}) {
- my $old;
- $old = $_ if defined wantarray;
- $_ = shift;
- return $old;
- }
- }
- else {
- return ${*$self}{'http_buf'};
- }
-}
-
-sub _rbuf_length {
- my $self = shift;
- return length ${*$self}{'http_buf'};
-}
-
-
-sub _read_header_lines {
- my $self = shift;
- my $junk_out = shift;
-
- my @headers;
- my $line_count = 0;
- my $max_header_lines = ${*$self}{'http_max_header_lines'};
- while (my $line = my_readline($self, 'Header')) {
- if ($line =~ /^(\S+?)\s*:\s*(.*)/s) {
- push(@headers, $1, $2);
- }
- elsif (@headers && $line =~ s/^\s+//) {
- $headers[-1] .= " " . $line;
- }
- elsif ($junk_out) {
- push(@$junk_out, $line);
- }
- else {
- die "Bad header: '$line'\n";
- }
- if ($max_header_lines) {
- $line_count++;
- if ($line_count >= $max_header_lines) {
- die "Too many header lines (limit is $max_header_lines)";
- }
- }
- }
- return @headers;
-}
-
-
-sub read_response_headers {
- my($self, %opt) = @_;
- my $laxed = $opt{laxed};
-
- my($status, $eol) = my_readline($self, 'Status');
- unless (defined $status) {
- die "Server closed connection without sending any data back";
- }
-
- my($peer_ver, $code, $message) = split(/\s+/, $status, 3);
- if (!$peer_ver || $peer_ver !~ s,^HTTP/,, || $code !~ /^[1-5]\d\d$/) {
- die "Bad response status line: '$status'" unless $laxed;
- # assume HTTP/0.9
- ${*$self}{'http_peer_http_version'} = "0.9";
- ${*$self}{'http_status'} = "200";
- substr(${*$self}{'http_buf'}, 0, 0) = $status . ($eol || "");
- return 200 unless wantarray;
- return (200, "Assumed OK");
- };
-
- ${*$self}{'http_peer_http_version'} = $peer_ver;
- ${*$self}{'http_status'} = $code;
-
- my $junk_out;
- if ($laxed) {
- $junk_out = $opt{junk_out} || [];
- }
- my @headers = $self->_read_header_lines($junk_out);
-
- # pick out headers that read_entity_body might need
- my @te;
- my $content_length;
- for (my $i = 0; $i < @headers; $i += 2) {
- my $h = lc($headers[$i]);
- if ($h eq 'transfer-encoding') {
- my $te = $headers[$i+1];
- $te =~ s/^\s+//;
- $te =~ s/\s+$//;
- push(@te, $te) if length($te);
- }
- elsif ($h eq 'content-length') {
- # ignore bogus and overflow values
- if ($headers[$i+1] =~ /^\s*(\d{1,15})(?:\s|$)/) {
- $content_length = $1;
- }
- }
- }
- ${*$self}{'http_te'} = join(",", @te);
- ${*$self}{'http_content_length'} = $content_length;
- ${*$self}{'http_first_body'}++;
- delete ${*$self}{'http_trailers'};
- return $code unless wantarray;
- return ($code, $message, @headers);
-}
-
-
-sub read_entity_body {
- my $self = shift;
- my $buf_ref = \$_[0];
- my $size = $_[1];
- die "Offset not supported yet" if $_[2];
-
- my $chunked;
- my $bytes;
-
- if (${*$self}{'http_first_body'}) {
- ${*$self}{'http_first_body'} = 0;
- delete ${*$self}{'http_chunked'};
- delete ${*$self}{'http_bytes'};
- my $method = shift(@{${*$self}{'http_request_method'}});
- my $status = ${*$self}{'http_status'};
- if ($method eq "HEAD") {
- # this response is always empty regardless of other headers
- $bytes = 0;
- }
- elsif (my $te = ${*$self}{'http_te'}) {
- my @te = split(/\s*,\s*/, lc($te));
- die "Chunked must be last Transfer-Encoding '$te'"
- unless pop(@te) eq "chunked";
-
- for (@te) {
- if ($_ eq "deflate" && inflate_ok()) {
- #require Compress::Raw::Zlib;
- my ($i, $status) = Compress::Raw::Zlib::Inflate->new();
- die "Can't make inflator: $status" unless $i;
- $_ = sub { my $out; $i->inflate($_[0], \$out); $out }
- }
- elsif ($_ eq "gzip" && gunzip_ok()) {
- #require IO::Uncompress::Gunzip;
- my @buf;
- $_ = sub {
- push(@buf, $_[0]);
- return "" unless $_[1];
- my $input = join("", @buf);
- my $output;
- IO::Uncompress::Gunzip::gunzip(\$input, \$output, Transparent => 0)
- or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError";
- return \$output;
- };
- }
- elsif ($_ eq "identity") {
- $_ = sub { $_[0] };
- }
- else {
- die "Can't handle transfer encoding '$te'";
- }
- }
-
- @te = reverse(@te);
-
- ${*$self}{'http_te2'} = @te ? \@te : "";
- $chunked = -1;
- }
- 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'
-
- # Read until EOF
- }
- }
- else {
- $chunked = ${*$self}{'http_chunked'};
- $bytes = ${*$self}{'http_bytes'};
- }
-
- if (defined $chunked) {
- # The state encoded in $chunked is:
- # $chunked == 0: read CRLF after chunk, then chunk header
- # $chunked == -1: read chunk header
- # $chunked > 0: bytes left in current chunk to read
-
- if ($chunked <= 0) {
- my $line = my_readline($self, 'Entity body');
- if ($chunked == 0) {
- die "Missing newline after chunk data: '$line'"
- if !defined($line) || $line ne "";
- $line = my_readline($self, 'Entity body');
- }
- die "EOF when chunk header expected" unless defined($line);
- my $chunk_len = $line;
- $chunk_len =~ s/;.*//; # ignore potential chunk parameters
- unless ($chunk_len =~ /^([\da-fA-F]+)\s*$/) {
- die "Bad chunk-size in HTTP response: $line";
- }
- $chunked = hex($1);
- if ($chunked == 0) {
- ${*$self}{'http_trailers'} = [$self->_read_header_lines];
- $$buf_ref = "";
-
- my $n = 0;
- if (my $transforms = delete ${*$self}{'http_te2'}) {
- for (@$transforms) {
- $$buf_ref = &$_($$buf_ref, 1);
- }
- $n = length($$buf_ref);
- }
-
- # in case somebody tries to read more, make sure we continue
- # to return EOF
- delete ${*$self}{'http_chunked'};
- ${*$self}{'http_bytes'} = 0;
-
- return $n;
- }
- }
-
- my $n = $chunked;
- $n = $size if $size && $size < $n;
- $n = my_read($self, $$buf_ref, $n);
- return undef unless defined $n;
-
- ${*$self}{'http_chunked'} = $chunked - $n;
-
- if ($n > 0) {
- if (my $transforms = ${*$self}{'http_te2'}) {
- for (@$transforms) {
- $$buf_ref = &$_($$buf_ref, 0);
- }
- $n = length($$buf_ref);
- $n = -1 if $n == 0;
- }
- }
- return $n;
- }
- elsif (defined $bytes) {
- unless ($bytes) {
- $$buf_ref = "";
- return 0;
- }
- my $n = $bytes;
- $n = $size if $size && $size < $n;
- $n = my_read($self, $$buf_ref, $n);
- return undef unless defined $n;
- ${*$self}{'http_bytes'} = $bytes - $n;
- return $n;
- }
- else {
- # read until eof
- $size ||= 8*1024;
- return my_read($self, $$buf_ref, $size);
- }
-}
-
-sub get_trailers {
- my $self = shift;
- @{${*$self}{'http_trailers'} || []};
-}
-
-BEGIN {
-my $gunzip_ok;
-my $inflate_ok;
-
-sub gunzip_ok {
- return $gunzip_ok if defined $gunzip_ok;
-
- # Try to load IO::Uncompress::Gunzip.
- local $@;
- local $SIG{__DIE__};
- $gunzip_ok = 0;
-
- eval {
- require IO::Uncompress::Gunzip;
- $gunzip_ok++;
- };
-
- return $gunzip_ok;
-}
-
-sub inflate_ok {
- return $inflate_ok if defined $inflate_ok;
-
- # Try to load Compress::Raw::Zlib.
- local $@;
- local $SIG{__DIE__};
- $inflate_ok = 0;
-
- eval {
- require Compress::Raw::Zlib;
- $inflate_ok++;
- };
-
- return $inflate_ok;
-}
-
-} # BEGIN
-
-1;
+++ /dev/null
-package Net::HTTP::NB;
-
-use strict;
-use vars qw($VERSION @ISA);
-
-$VERSION = "5.810";
-
-require Net::HTTP;
-@ISA=qw(Net::HTTP);
-
-sub sysread {
- my $self = $_[0];
- if (${*$self}{'httpnb_read_count'}++) {
- ${*$self}{'http_buf'} = ${*$self}{'httpnb_save'};
- die "Multi-read\n";
- }
- my $buf;
- my $offset = $_[3] || 0;
- my $n = sysread($self, $_[1], $_[2], $offset);
- ${*$self}{'httpnb_save'} .= substr($_[1], $offset);
- return $n;
-}
-
-sub read_response_headers {
- my $self = shift;
- ${*$self}{'httpnb_read_count'} = 0;
- ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'};
- my @h = eval { $self->SUPER::read_response_headers(@_) };
- if ($@) {
- return if $@ eq "Multi-read\n";
- die;
- }
- return @h;
-}
-
-sub read_entity_body {
- my $self = shift;
- ${*$self}{'httpnb_read_count'} = 0;
- ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'};
- # XXX I'm not so sure this does the correct thing in case of
- # transfer-encoding tranforms
- my $n = eval { $self->SUPER::read_entity_body(@_); };
- if ($@) {
- $_[0] = "";
- return -1;
- }
- return $n;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::HTTP::NB - Non-blocking HTTP client
-
-=head1 SYNOPSIS
-
- use Net::HTTP::NB;
- my $s = Net::HTTP::NB->new(Host => "www.perl.com") || die $@;
- $s->write_request(GET => "/");
-
- use IO::Select;
- my $sel = IO::Select->new($s);
-
- READ_HEADER: {
- die "Header timeout" unless $sel->can_read(10);
- my($code, $mess, %h) = $s->read_response_headers;
- redo READ_HEADER unless $code;
- }
-
- while (1) {
- die "Body timeout" unless $sel->can_read(10);
- my $buf;
- my $n = $s->read_entity_body($buf, 1024);
- last unless $n;
- print $buf;
- }
-
-=head1 DESCRIPTION
-
-Same interface as C<Net::HTTP> but it will never try multiple reads
-when the read_response_headers() or read_entity_body() methods are
-invoked. This make it possible to multiplex multiple Net::HTTP::NB
-using select without risk blocking.
-
-If read_response_headers() did not see enough data to complete the
-headers an empty list is returned.
-
-If read_entity_body() did not see new entity data in its read
-the value -1 is returned.
-
-=head1 SEE ALSO
-
-L<Net::HTTP>
-
-=head1 COPYRIGHT
-
-Copyright 2001 Gisle Aas.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=cut
+++ /dev/null
-package Net::HTTPS;
-
-use strict;
-use vars qw($VERSION $SSL_SOCKET_CLASS @ISA);
-
-$VERSION = "5.819";
-
-# Figure out which SSL implementation to use
-if ($SSL_SOCKET_CLASS) {
- # somebody already set it
-}
-elsif ($Net::SSL::VERSION) {
- $SSL_SOCKET_CLASS = "Net::SSL";
-}
-elsif ($IO::Socket::SSL::VERSION) {
- $SSL_SOCKET_CLASS = "IO::Socket::SSL"; # it was already loaded
-}
-else {
- eval { require Net::SSL; }; # from Crypt-SSLeay
- if ($@) {
- my $old_errsv = $@;
- eval {
- require IO::Socket::SSL;
- };
- if ($@) {
- $old_errsv =~ s/\s\(\@INC contains:.*\)/)/g;
- die $old_errsv . $@;
- }
- $SSL_SOCKET_CLASS = "IO::Socket::SSL";
- }
- else {
- $SSL_SOCKET_CLASS = "Net::SSL";
- }
-}
-
-require Net::HTTP::Methods;
-
-@ISA=($SSL_SOCKET_CLASS, 'Net::HTTP::Methods');
-
-sub configure {
- my($self, $cnf) = @_;
- $self->http_configure($cnf);
-}
-
-sub http_connect {
- my($self, $cnf) = @_;
- $self->SUPER::configure($cnf);
-}
-
-sub http_default_port {
- 443;
-}
-
-# The underlying SSLeay classes fails to work if the socket is
-# placed in non-blocking mode. This override of the blocking
-# method makes sure it stays the way it was created.
-sub blocking { } # noop
-
-1;
+++ /dev/null
-package WWW::RobotRules;
-
-$VERSION = "5.832";
-sub Version { $VERSION; }
-
-use strict;
-use URI ();
-
-
-
-sub new {
- my($class, $ua) = @_;
-
- # This ugly hack is needed to ensure backwards compatibility.
- # The "WWW::RobotRules" class is now really abstract.
- $class = "WWW::RobotRules::InCore" if $class eq "WWW::RobotRules";
-
- my $self = bless { }, $class;
- $self->agent($ua);
- $self;
-}
-
-
-sub parse {
- my($self, $robot_txt_uri, $txt, $fresh_until) = @_;
- $robot_txt_uri = URI->new("$robot_txt_uri");
- my $netloc = $robot_txt_uri->host . ":" . $robot_txt_uri->port;
-
- $self->clear_rules($netloc);
- $self->fresh_until($netloc, $fresh_until || (time + 365*24*3600));
-
- my $ua;
- my $is_me = 0; # 1 iff this record is for me
- my $is_anon = 0; # 1 iff this record is for *
- my $seen_disallow = 0; # watch for missing record separators
- my @me_disallowed = (); # rules disallowed for me
- my @anon_disallowed = (); # rules disallowed for *
-
- # blank lines are significant, so turn CRLF into LF to avoid generating
- # false ones
- $txt =~ s/\015\012/\012/g;
-
- # split at \012 (LF) or \015 (CR) (Mac text files have just CR for EOL)
- for(split(/[\012\015]/, $txt)) {
-
- # Lines containing only a comment are discarded completely, and
- # therefore do not indicate a record boundary.
- next if /^\s*\#/;
-
- s/\s*\#.*//; # remove comments at end-of-line
-
- if (/^\s*$/) { # blank line
- last if $is_me; # That was our record. No need to read the rest.
- $is_anon = 0;
- $seen_disallow = 0;
- }
- elsif (/^\s*User-Agent\s*:\s*(.*)/i) {
- $ua = $1;
- $ua =~ s/\s+$//;
-
- if ($seen_disallow) {
- # treat as start of a new record
- $seen_disallow = 0;
- last if $is_me; # That was our record. No need to read the rest.
- $is_anon = 0;
- }
-
- if ($is_me) {
- # This record already had a User-agent that
- # we matched, so just continue.
- }
- elsif ($ua eq '*') {
- $is_anon = 1;
- }
- elsif($self->is_me($ua)) {
- $is_me = 1;
- }
- }
- elsif (/^\s*Disallow\s*:\s*(.*)/i) {
- unless (defined $ua) {
- warn "RobotRules <$robot_txt_uri>: Disallow without preceding User-agent\n" if $^W;
- $is_anon = 1; # assume that User-agent: * was intended
- }
- my $disallow = $1;
- $disallow =~ s/\s+$//;
- $seen_disallow = 1;
- if (length $disallow) {
- my $ignore;
- eval {
- my $u = URI->new_abs($disallow, $robot_txt_uri);
- $ignore++ if $u->scheme ne $robot_txt_uri->scheme;
- $ignore++ if lc($u->host) ne lc($robot_txt_uri->host);
- $ignore++ if $u->port ne $robot_txt_uri->port;
- $disallow = $u->path_query;
- $disallow = "/" unless length $disallow;
- };
- next if $@;
- next if $ignore;
- }
-
- if ($is_me) {
- push(@me_disallowed, $disallow);
- }
- elsif ($is_anon) {
- push(@anon_disallowed, $disallow);
- }
- }
- elsif (/\S\s*:/) {
- # ignore
- }
- else {
- warn "RobotRules <$robot_txt_uri>: Malformed record: <$_>\n" if $^W;
- }
- }
-
- if ($is_me) {
- $self->push_rules($netloc, @me_disallowed);
- }
- else {
- $self->push_rules($netloc, @anon_disallowed);
- }
-}
-
-
-#
-# Returns TRUE if the given name matches the
-# name of this robot
-#
-sub is_me {
- my($self, $ua_line) = @_;
- my $me = $self->agent;
-
- # See whether my short-name is a substring of the
- # "User-Agent: ..." line that we were passed:
-
- if(index(lc($me), lc($ua_line)) >= 0) {
- return 1;
- }
- else {
- return '';
- }
-}
-
-
-sub allowed {
- my($self, $uri) = @_;
- $uri = URI->new("$uri");
-
- return 1 unless $uri->scheme eq 'http' or $uri->scheme eq 'https';
- # Robots.txt applies to only those schemes.
-
- my $netloc = $uri->host . ":" . $uri->port;
-
- my $fresh_until = $self->fresh_until($netloc);
- return -1 if !defined($fresh_until) || $fresh_until < time;
-
- my $str = $uri->path_query;
- my $rule;
- for $rule ($self->rules($netloc)) {
- return 1 unless length $rule;
- return 0 if index($str, $rule) == 0;
- }
- return 1;
-}
-
-
-# The following methods must be provided by the subclass.
-sub agent;
-sub visit;
-sub no_visits;
-sub last_visits;
-sub fresh_until;
-sub push_rules;
-sub clear_rules;
-sub rules;
-sub dump;
-
-
-
-package WWW::RobotRules::InCore;
-
-use vars qw(@ISA);
-@ISA = qw(WWW::RobotRules);
-
-
-
-sub agent {
- my ($self, $name) = @_;
- my $old = $self->{'ua'};
- if ($name) {
- # Strip it so that it's just the short name.
- # I.e., "FooBot" => "FooBot"
- # "FooBot/1.2" => "FooBot"
- # "FooBot/1.2 [http://foobot.int; foo@bot.int]" => "FooBot"
-
- $name = $1 if $name =~ m/(\S+)/; # get first word
- $name =~ s!/.*!!; # get rid of version
- unless ($old && $old eq $name) {
- delete $self->{'loc'}; # all old info is now stale
- $self->{'ua'} = $name;
- }
- }
- $old;
-}
-
-
-sub visit {
- my($self, $netloc, $time) = @_;
- return unless $netloc;
- $time ||= time;
- $self->{'loc'}{$netloc}{'last'} = $time;
- my $count = \$self->{'loc'}{$netloc}{'count'};
- if (!defined $$count) {
- $$count = 1;
- }
- else {
- $$count++;
- }
-}
-
-
-sub no_visits {
- my ($self, $netloc) = @_;
- $self->{'loc'}{$netloc}{'count'};
-}
-
-
-sub last_visit {
- my ($self, $netloc) = @_;
- $self->{'loc'}{$netloc}{'last'};
-}
-
-
-sub fresh_until {
- my ($self, $netloc, $fresh_until) = @_;
- my $old = $self->{'loc'}{$netloc}{'fresh'};
- if (defined $fresh_until) {
- $self->{'loc'}{$netloc}{'fresh'} = $fresh_until;
- }
- $old;
-}
-
-
-sub push_rules {
- my($self, $netloc, @rules) = @_;
- push (@{$self->{'loc'}{$netloc}{'rules'}}, @rules);
-}
-
-
-sub clear_rules {
- my($self, $netloc) = @_;
- delete $self->{'loc'}{$netloc}{'rules'};
-}
-
-
-sub rules {
- my($self, $netloc) = @_;
- if (defined $self->{'loc'}{$netloc}{'rules'}) {
- return @{$self->{'loc'}{$netloc}{'rules'}};
- }
- else {
- return ();
- }
-}
-
-
-sub dump
-{
- my $self = shift;
- for (keys %$self) {
- next if $_ eq 'loc';
- print "$_ = $self->{$_}\n";
- }
- for (keys %{$self->{'loc'}}) {
- my @rules = $self->rules($_);
- print "$_: ", join("; ", @rules), "\n";
- }
-}
-
-
-1;
-
-__END__
-
-
-# Bender: "Well, I don't have anything else
-# planned for today. Let's get drunk!"
-
-=head1 NAME
-
-WWW::RobotRules - database of robots.txt-derived permissions
-
-=head1 SYNOPSIS
-
- use WWW::RobotRules;
- my $rules = WWW::RobotRules->new('MOMspider/1.0');
-
- use LWP::Simple qw(get);
-
- {
- my $url = "http://some.place/robots.txt";
- my $robots_txt = get $url;
- $rules->parse($url, $robots_txt) if defined $robots_txt;
- }
-
- {
- my $url = "http://some.other.place/robots.txt";
- my $robots_txt = get $url;
- $rules->parse($url, $robots_txt) if defined $robots_txt;
- }
-
- # Now we can check if a URL is valid for those servers
- # whose "robots.txt" files we've gotten and parsed:
- if($rules->allowed($url)) {
- $c = get $url;
- ...
- }
-
-=head1 DESCRIPTION
-
-This module parses F</robots.txt> files as specified in
-"A Standard for Robot Exclusion", at
-<http://www.robotstxt.org/wc/norobots.html>
-Webmasters can use the F</robots.txt> file to forbid conforming
-robots from accessing parts of their web site.
-
-The parsed files are kept in a WWW::RobotRules object, and this object
-provides methods to check if access to a given URL is prohibited. The
-same WWW::RobotRules object can be used for one or more parsed
-F</robots.txt> files on any number of hosts.
-
-The following methods are provided:
-
-=over 4
-
-=item $rules = WWW::RobotRules->new($robot_name)
-
-This is the constructor for WWW::RobotRules objects. The first
-argument given to new() is the name of the robot.
-
-=item $rules->parse($robot_txt_url, $content, $fresh_until)
-
-The parse() method takes as arguments the URL that was used to
-retrieve the F</robots.txt> file, and the contents of the file.
-
-=item $rules->allowed($uri)
-
-Returns TRUE if this robot is allowed to retrieve this URL.
-
-=item $rules->agent([$name])
-
-Get/set the agent name. NOTE: Changing the agent name will clear the robots.txt
-rules and expire times out of the cache.
-
-=back
-
-=head1 ROBOTS.TXT
-
-The format and semantics of the "/robots.txt" file are as follows
-(this is an edited abstract of
-<http://www.robotstxt.org/wc/norobots.html>):
-
-The file consists of one or more records separated by one or more
-blank lines. Each record contains lines of the form
-
- <field-name>: <value>
-
-The field name is case insensitive. Text after the '#' character on a
-line is ignored during parsing. This is used for comments. The
-following <field-names> can be used:
-
-=over 3
-
-=item User-Agent
-
-The value of this field is the name of the robot the record is
-describing access policy for. If more than one I<User-Agent> field is
-present the record describes an identical access policy for more than
-one robot. At least one field needs to be present per record. If the
-value is '*', the record describes the default access policy for any
-robot that has not not matched any of the other records.
-
-The I<User-Agent> fields must occur before the I<Disallow> fields. If a
-record contains a I<User-Agent> field after a I<Disallow> field, that
-constitutes a malformed record. This parser will assume that a blank
-line should have been placed before that I<User-Agent> field, and will
-break the record into two. All the fields before the I<User-Agent> field
-will constitute a record, and the I<User-Agent> field will be the first
-field in a new record.
-
-=item Disallow
-
-The value of this field specifies a partial URL that is not to be
-visited. This can be a full path, or a partial path; any URL that
-starts with this value will not be retrieved
-
-=back
-
-Unrecognized records are ignored.
-
-=head1 ROBOTS.TXT EXAMPLES
-
-The following example "/robots.txt" file specifies that no robots
-should visit any URL starting with "/cyberworld/map/" or "/tmp/":
-
- User-agent: *
- Disallow: /cyberworld/map/ # This is an infinite virtual URL space
- Disallow: /tmp/ # these will soon disappear
-
-This example "/robots.txt" file specifies that no robots should visit
-any URL starting with "/cyberworld/map/", except the robot called
-"cybermapper":
-
- User-agent: *
- Disallow: /cyberworld/map/ # This is an infinite virtual URL space
-
- # Cybermapper knows where to go.
- User-agent: cybermapper
- Disallow:
-
-This example indicates that no robots should visit this site further:
-
- # go away
- User-agent: *
- Disallow: /
-
-This is an example of a malformed robots.txt file.
-
- # robots.txt for ancientcastle.example.com
- # I've locked myself away.
- User-agent: *
- Disallow: /
- # The castle is your home now, so you can go anywhere you like.
- User-agent: Belle
- Disallow: /west-wing/ # except the west wing!
- # It's good to be the Prince...
- User-agent: Beast
- Disallow:
-
-This file is missing the required blank lines between records.
-However, the intention is clear.
-
-=head1 SEE ALSO
-
-L<LWP::RobotUA>, L<WWW::RobotRules::AnyDBM_File>
+++ /dev/null
-package WWW::RobotRules::AnyDBM_File;
-
-require WWW::RobotRules;
-@ISA = qw(WWW::RobotRules);
-$VERSION = "5.835";
-
-use Carp ();
-use AnyDBM_File;
-use Fcntl;
-use strict;
-
-=head1 NAME
-
-WWW::RobotRules::AnyDBM_File - Persistent RobotRules
-
-=head1 SYNOPSIS
-
- require WWW::RobotRules::AnyDBM_File;
- require LWP::RobotUA;
-
- # Create a robot useragent that uses a diskcaching RobotRules
- my $rules = WWW::RobotRules::AnyDBM_File->new( 'my-robot/1.0', 'cachefile' );
- my $ua = WWW::RobotUA->new( 'my-robot/1.0', 'me@foo.com', $rules );
-
- # Then just use $ua as usual
- $res = $ua->request($req);
-
-=head1 DESCRIPTION
-
-This is a subclass of I<WWW::RobotRules> that uses the AnyDBM_File
-package to implement persistent diskcaching of F<robots.txt> and host
-visit information.
-
-The constructor (the new() method) takes an extra argument specifying
-the name of the DBM file to use. If the DBM file already exists, then
-you can specify undef as agent name as the name can be obtained from
-the DBM database.
-
-=cut
-
-sub new
-{
- my ($class, $ua, $file) = @_;
- Carp::croak('WWW::RobotRules::AnyDBM_File filename required') unless $file;
-
- my $self = bless { }, $class;
- $self->{'filename'} = $file;
- tie %{$self->{'dbm'}}, 'AnyDBM_File', $file, O_CREAT|O_RDWR, 0640
- or Carp::croak("Can't open $file: $!");
-
- if ($ua) {
- $self->agent($ua);
- }
- else {
- # Try to obtain name from DBM file
- $ua = $self->{'dbm'}{"|ua-name|"};
- Carp::croak("No agent name specified") unless $ua;
- }
-
- $self;
-}
-
-sub agent {
- my($self, $newname) = @_;
- my $old = $self->{'dbm'}{"|ua-name|"};
- if (defined $newname) {
- $newname =~ s!/?\s*\d+.\d+\s*$!!; # loose version
- unless ($old && $old eq $newname) {
- # Old info is now stale.
- my $file = $self->{'filename'};
- untie %{$self->{'dbm'}};
- tie %{$self->{'dbm'}}, 'AnyDBM_File', $file, O_TRUNC|O_RDWR, 0640;
- %{$self->{'dbm'}} = ();
- $self->{'dbm'}{"|ua-name|"} = $newname;
- }
- }
- $old;
-}
-
-sub no_visits {
- my ($self, $netloc) = @_;
- my $t = $self->{'dbm'}{"$netloc|vis"};
- return 0 unless $t;
- (split(/;\s*/, $t))[0];
-}
-
-sub last_visit {
- my ($self, $netloc) = @_;
- my $t = $self->{'dbm'}{"$netloc|vis"};
- return undef unless $t;
- (split(/;\s*/, $t))[1];
-}
-
-sub fresh_until {
- my ($self, $netloc, $fresh) = @_;
- my $old = $self->{'dbm'}{"$netloc|exp"};
- if ($old) {
- $old =~ s/;.*//; # remove cleartext
- }
- if (defined $fresh) {
- $fresh .= "; " . localtime($fresh);
- $self->{'dbm'}{"$netloc|exp"} = $fresh;
- }
- $old;
-}
-
-sub visit {
- my($self, $netloc, $time) = @_;
- $time ||= time;
-
- my $count = 0;
- my $old = $self->{'dbm'}{"$netloc|vis"};
- if ($old) {
- my $last;
- ($count,$last) = split(/;\s*/, $old);
- $time = $last if $last > $time;
- }
- $count++;
- $self->{'dbm'}{"$netloc|vis"} = "$count; $time; " . localtime($time);
-}
-
-sub push_rules {
- my($self, $netloc, @rules) = @_;
- my $cnt = 1;
- $cnt++ while $self->{'dbm'}{"$netloc|r$cnt"};
-
- foreach (@rules) {
- $self->{'dbm'}{"$netloc|r$cnt"} = $_;
- $cnt++;
- }
-}
-
-sub clear_rules {
- my($self, $netloc) = @_;
- my $cnt = 1;
- while ($self->{'dbm'}{"$netloc|r$cnt"}) {
- delete $self->{'dbm'}{"$netloc|r$cnt"};
- $cnt++;
- }
-}
-
-sub rules {
- my($self, $netloc) = @_;
- my @rules = ();
- my $cnt = 1;
- while (1) {
- my $rule = $self->{'dbm'}{"$netloc|r$cnt"};
- last unless $rule;
- push(@rules, $rule);
- $cnt++;
- }
- @rules;
-}
-
-sub dump
-{
-}
-
-1;
-
-=head1 SEE ALSO
-
-L<WWW::RobotRules>, L<LWP::RobotUA>
-
-=head1 AUTHORS
-
-Hakan Ardo E<lt>hakan@munin.ub2.lu.se>, Gisle Aas E<lt>aas@sn.no>
-
-=cut
-
the document specified by its URL argument:
use LWP::Simple;
- $doc = get 'http://www.linpro.no/lwp/';
+ $doc = get 'http://search.cpan.org/dist/libwww-perl/';
or, as a perl one-liner using the getprint() function:
- perl -MLWP::Simple -e 'getprint "http://www.linpro.no/lwp/"'
+ perl -MLWP::Simple -e 'getprint "http://search.cpan.org/dist/libwww-perl/"'
or, how about fetching the latest perl by running this command:
You will probably first want to find a CPAN site closer to you by
running something like the following command:
- perl -MLWP::Simple -e 'getprint "http://www.perl.com/perl/CPAN/CPAN.html"'
+ perl -MLWP::Simple -e 'getprint "http://www.cpan.org/SITES.html"'
Enough of this simple stuff! The LWP object oriented interface gives
you more control over the request sent to the server. Using this
$ua->agent("$0/0.1 " . $ua->agent);
# $ua->agent("Mozilla/8.0") # pretend we are very capable browser
- $req = HTTP::Request->new(GET => 'http://www.linpro.no/lwp');
+ $req = HTTP::Request->new(
+ GET => 'http://search.cpan.org/dist/libwww-perl/');
$req->header('Accept' => 'text/html');
# send request
use LWP::UserAgent;
$ua = LWP::UserAgent->new;
- my $req = HTTP::Request->new(POST => 'http://www.perl.com/cgi-bin/BugGlimpse');
+ my $req = HTTP::Request->new(
+ POST => 'http://rt.cpan.org/Public/Dist/Display.html');
$req->content_type('application/x-www-form-urlencoded');
- $req->content('match=www&errors=0');
+ $req->content('Status=Active&Name=libwww-perl');
my $res = $ua->request($req);
print $res->as_string;
use LWP::UserAgent;
$ua = LWP::UserAgent->new;
- my $req = POST 'http://www.perl.com/cgi-bin/BugGlimpse',
- [ search => 'www', errors => 0 ];
+ my $req = POST 'http://rt.cpan.org/Public/Dist/Display.html',
+ [ Status => 'Active', Name => 'libwww-perl' ];
print $ua->request($req)->as_string;
autosave => 1));
# and then send requests just as you used to do
- $res = $ua->request(HTTP::Request->new(GET => "http://www.yahoo.no"));
+ $res = $ua->request(HTTP::Request->new(GET => "http://no.yahoo.com/"));
print $res->status_line, "\n";
As you visit sites that send you cookies to keep, then the file
use LWP::Simple;
%mirrors = (
- 'http://www.sn.no/' => 'sn.html',
- 'http://www.perl.com/' => 'perl.html',
- 'http://www.sn.no/libwww-perl/' => 'lwp.html',
- 'gopher://gopher.sn.no/' => 'gopher.html',
+ 'http://www.sn.no/' => 'sn.html',
+ 'http://www.perl.com/' => 'perl.html',
+ 'http://search.cpan.org/distlibwww-perl/' => 'lwp.html',
+ 'gopher://gopher.sn.no/' => 'gopher.html',
);
while (($url, $localfile) = each(%mirrors)) {
$ua = LWP::UserAgent->new;
my $req = HTTP::Request->new(GET =>
- 'http://www.linpro.no/lwp/libwww-perl-5.46.tar.gz');
+ 'http://www.cpan.org/authors/Gisle_Aas/libwww-perl-6.02.tar.gz');
$res = $ua->request($req, "libwww-perl.tar.gz");
if ($res->is_success) {
print "ok\n";
getting that URL's content. If it works, then it'll return the
content; but if there's some error, it'll return undef.
- my $url = 'http://freshair.npr.org/dayFA.cfm?todayDate=current';
+ my $url = 'http://www.npr.org/programs/fa/?todayDate=current';
# Just an example: the URL for the most recent /Fresh Air/ show
use LWP::Simple;
one-liners. If it can get the page whose URL you provide, it sends it
to STDOUT; otherwise it complains to STDERR.
- % perl -MLWP::Simple -e "getprint 'http://cpan.org/RECENT'"
+ % perl -MLWP::Simple -e "getprint 'http://www.cpan.org/RECENT'"
That is the URL of a plain text file that lists new files in CPAN in
the past two weeks. You can easily make it part of a tidy little
shell command, like this one that mails you the list of new
C<Acme::> modules:
- % perl -MLWP::Simple -e "getprint 'http://cpan.org/RECENT'" \
+ % perl -MLWP::Simple -e "getprint 'http://www.cpan.org/RECENT'" \
| grep "/by-module/Acme" | mail -s "New Acme modules! Joy!" $USER
There are other useful functions in LWP::Simple, including one function
...
# Then later, whenever you need to make a get request:
- my $url = 'http://freshair.npr.org/dayFA.cfm?todayDate=current';
+ my $url = 'http://www.npr.org/programs/fa/?todayDate=current';
my $response = $browser->get( $url );
die "Can't get $url -- ", $response->status_line
use warnings;
use LWP 5.64;
my $browser = LWP::UserAgent->new;
-
+
my $word = 'tarragon';
-
- my $url = 'http://www.altavista.com/sites/search/web';
+
+ my $url = 'http://search.yahoo.com/yhs/search';
my $response = $browser->post( $url,
[ 'q' => $word, # the Altavista query string
- 'pg' => 'q', 'avkw' => 'tgz', 'kl' => 'XX',
+ 'fr' => 'altavista', 'pg' => 'q', 'avkw' => 'tgz', 'kl' => 'XX',
]
);
die "$url error: ", $response->status_line
die "Weird content type at $url -- ", $response->content_type
unless $response->content_is_html;
- if( $response->decoded_content =~ m{AltaVista found ([0-9,]+) results} ) {
- # The substring will be like "AltaVista found 2,345 results"
+ if( $response->decoded_content =~ m{([0-9,]+)(?:<.*?>)? results for} ) {
+ # The substring will be like "996,000</strong> results for"
print "$word: $1\n";
}
else {
Some HTML forms convey their form data not by sending the data
in an HTTP POST request, but by making a normal GET request with
the data stuck on the end of the URL. For example, if you went to
-C<imdb.com> and ran a search on "Blade Runner", the URL you'd see
+C<www.imdb.com> and ran a search on "Blade Runner", the URL you'd see
in your browser window would be:
- http://us.imdb.com/Tsearch?title=Blade%20Runner&restrict=Movies+and+TV
+ http://www.imdb.com/find?s=all&q=Blade+Runner
To run the same search with LWP, you'd use this idiom, which involves
the URI class:
use URI;
- my $url = URI->new( 'http://us.imdb.com/Tsearch' );
+ my $url = URI->new( 'http://www.imdb.com/find' );
# makes an object representing the URL
-
+
$url->query_form( # And here the form data pairs:
- 'title' => 'Blade Runner',
- 'restrict' => 'Movies and TV',
+ 'q' => 'Blade Runner',
+ 's' => 'all',
);
-
+
my $response = $browser->get($url);
See chapter 5 of I<Perl & LWP> for a longer discussion of HTML forms
=item *
The book I<Perl & LWP> by Sean M. Burke. O'Reilly & Associates,
-2002. ISBN: 0-596-00178-9, L<http://www.oreilly.com/catalog/perllwp/>. The
+2002. ISBN: 0-596-00178-9, L<http://oreilly.com/catalog/perllwp/>. The
whole book is also available free online:
L<http://lwp.interglacial.com>.
else {
@tests = (<base/*.t>, <html/*.t>, <robot/*.t>, <local/*.t>);
push(@tests, <live/*.t>) if -f "live/ENABLED";
+ push(@tests, <live/jigsaw/*.t>) if -f "live/jigsaw/ENABLED";
push(@tests, <net/*.t>) if -f "net/config.pl";
- @tests = grep !/jigsaw/, @tests; # service is not reliable any more
}
if ($formatter) {
+++ /dev/null
-#perl -w
-
-use Test;
-plan tests => 52;
-
-use HTTP::Request::Common;
-
-$r = GET 'http://www.sn.no/';
-print $r->as_string;
-
-ok($r->method, "GET");
-ok($r->uri, "http://www.sn.no/");
-
-$r = HEAD "http://www.sn.no/",
- If_Match => 'abc',
- From => 'aas@sn.no';
-print $r->as_string;
-
-ok($r->method, "HEAD");
-ok($r->uri->eq("http://www.sn.no"));
-
-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";
-
-ok($r->method, "PUT");
-ok($r->uri->host, "www.sn.no");
-
-ok(!defined($r->header("Content")));
-
-ok(${$r->content_ref}, "foo");
-ok($r->content, "foo");
-ok($r->content_length, 3);
-
-#--- Test POST requests ---
-
-$r = POST "http://www.sn.no", [foo => 'bar;baz',
- baz => [qw(a b c)],
- foo => 'zoo=&',
- "space " => " + ",
- ],
- bar => 'foo';
-print $r->as_string, "\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;
-
-ok($r->method, "POST");
-ok($r->header("Subject"), "Heisan");
-ok($r->content, "Howdy\n");
-ok($r->content_type, "text/plain");
-
-#
-# POST for File upload
-#
-$file = "test-$$";
-open(FILE, ">$file") or die "Can't create $file: $!";
-print FILE "foo\nbar\nbaz\n";
-close(FILE);
-
-$r = POST 'http://www.perl.org/survey.cgi',
- Content_Type => 'form-data',
- Content => [ name => 'Gisle Aas',
- email => 'gisle@aas.no',
- gender => 'm',
- born => '1964',
- file => [$file],
- ];
-#print $r->as_string;
-
-unlink($file) or warn "Can't unlink $file: $!";
-
-ok($r->method, "POST");
-ok($r->uri->path, "/survey.cgi");
-ok($r->content_type, "multipart/form-data");
-ok($r->header(Content_type) =~ /boundary="?([^"]+)"?/);
-$boundary = $1;
-
-$c = $r->content;
-$c =~ s/\r//g;
-@c = split(/--\Q$boundary/, $c);
-print "$c[5]\n";
-
-ok(@c == 7 and $c[6] =~ /^--\n/); # 5 parts + header & trailer
-
-ok($c[2] =~ /^Content-Disposition:\s*form-data;\s*name="email"/m);
-ok($c[2] =~ /^gisle\@aas.no$/m);
-
-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, "xxy\"", Content_type => "text/html", Content => "<h1>Hello, world!</h1>" ]],
- Content_type => 'multipart/form-data';
-print $r->as_string;
-
-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;
-
-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";
-ok($r->content =~ /foo=42/);
-ok($r->content =~ /bar=24/);
-ok($r->content_type, "application/x-www-form-urlencoded");
-ok($r->content_length, 13);
-
-
-#
-# POST for File upload
-#
-use HTTP::Request::Common qw($DYNAMIC_FILE_UPLOAD);
-
-$file = "test-$$";
-open(FILE, ">$file") or die "Can't create $file: $!";
-for (1..1000) {
- print FILE "a" .. "z";
-}
-close(FILE);
-
-$DYNAMIC_FILE_UPLOAD++;
-$r = POST 'http://www.perl.org/survey.cgi',
- Content_Type => 'form-data',
- Content => [ name => 'Gisle Aas',
- email => 'gisle@aas.no',
- gender => 'm',
- born => '1964',
- file => [$file],
- ];
-print $r->as_string, "\n";
-
-ok($r->method, "POST");
-ok($r->uri->path, "/survey.cgi");
-ok($r->content_type, "multipart/form-data");
-ok($r->header(Content_type) =~ /boundary="?([^"]+)"?/);
-$boundary = $1;
-ok(ref($r->content), "CODE");
-
-ok(length($boundary) > 10);
-
-$code = $r->content;
-my $chunk;
-my @chunks;
-while (defined($chunk = &$code) && length $chunk) {
- push(@chunks, $chunk);
-}
-
-unlink($file) or warn "Can't unlink $file: $!";
-
-$_ = join("", @chunks);
-
-print int(@chunks), " chunks, total size is ", length($_), " bytes\n";
-
-# should be close to expected size and number of chunks
-ok(abs(@chunks - 15 < 3));
-ok(abs(length($_) - 26589) < 20);
-
-$r = POST 'http://www.example.com';
-ok($r->as_string, <<EOT);
-POST http://www.example.com
-Content-Length: 0
-Content-Type: application/x-www-form-urlencoded
-
-EOT
-
-$r = POST 'http://www.example.com', Content_Type => 'form-data', Content => [];
-ok($r->as_string, <<EOT);
-POST http://www.example.com
-Content-Length: 0
-Content-Type: multipart/form-data; boundary=none
-
-EOT
-
-$r = POST 'http://www.example.com', Content_Type => 'form-data';
-#print $r->as_string;
-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");
-
-$r = HTTP::Request::Common::PUT 'http://www.example.com',
- 'Content-Type' => 'application/octet-steam',
- 'Content' => 'foobarbaz',
- 'Content-Length' => 12; # a slight lie
-ok($r->header('Content-Length'), 12);
+++ /dev/null
-#!perl -w
-
-use Test;
-plan tests => 66;
-
-use HTTP::Cookies;
-use HTTP::Request;
-use HTTP::Response;
-
-#-------------------------------------------------------------------
-# First we check that it works for the original example at
-# http://curl.haxx.se/rfc/cookie_spec.html
-
-# Client requests a document, and receives in the response:
-#
-# Set-Cookie: CUSTOMER=WILE_E_COYOTE; path=/; expires=Wednesday, 09-Nov-99 23:12:40 GMT
-#
-# When client requests a URL in path "/" on this server, it sends:
-#
-# Cookie: CUSTOMER=WILE_E_COYOTE
-#
-# Client requests a document, and receives in the response:
-#
-# Set-Cookie: PART_NUMBER=ROCKET_LAUNCHER_0001; path=/
-#
-# When client requests a URL in path "/" on this server, it sends:
-#
-# Cookie: CUSTOMER=WILE_E_COYOTE; PART_NUMBER=ROCKET_LAUNCHER_0001
-#
-# Client receives:
-#
-# Set-Cookie: SHIPPING=FEDEX; path=/fo
-#
-# When client requests a URL in path "/" on this server, it sends:
-#
-# Cookie: CUSTOMER=WILE_E_COYOTE; PART_NUMBER=ROCKET_LAUNCHER_0001
-#
-# When client requests a URL in path "/foo" on this server, it sends:
-#
-# Cookie: CUSTOMER=WILE_E_COYOTE; PART_NUMBER=ROCKET_LAUNCHER_0001; SHIPPING=FEDEX
-#
-# The last Cookie is buggy, because both specifications says that the
-# most specific cookie must be sent first. SHIPPING=FEDEX is the
-# most specific and should thus be first.
-
-my $year_plus_one = (localtime)[5] + 1900 + 1;
-
-$c = HTTP::Cookies->new;
-
-$req = HTTP::Request->new(GET => "http://1.1.1.1/");
-$req->header("Host", "www.acme.com:80");
-
-$res = HTTP::Response->new(200, "OK");
-$res->request($req);
-$res->header("Set-Cookie" => "CUSTOMER=WILE_E_COYOTE; path=/ ; expires=Wednesday, 09-Nov-$year_plus_one 23:12:40 GMT");
-#print $res->as_string;
-$c->extract_cookies($res);
-
-$req = HTTP::Request->new(GET => "http://www.acme.com/");
-$c->add_cookie_header($req);
-
-ok($req->header("Cookie"), "CUSTOMER=WILE_E_COYOTE");
-ok($req->header("Cookie2"), "\$Version=\"1\"");
-
-$res->request($req);
-$res->header("Set-Cookie" => "PART_NUMBER=ROCKET_LAUNCHER_0001; path=/");
-$c->extract_cookies($res);
-
-$req = HTTP::Request->new(GET => "http://www.acme.com/foo/bar");
-$c->add_cookie_header($req);
-
-$h = $req->header("Cookie");
-ok($h =~ /PART_NUMBER=ROCKET_LAUNCHER_0001/);
-ok($h =~ /CUSTOMER=WILE_E_COYOTE/);
-
-$res->request($req);
-$res->header("Set-Cookie", "SHIPPING=FEDEX; path=/foo");
-$c->extract_cookies($res);
-
-$req = HTTP::Request->new(GET => "http://www.acme.com/");
-$c->add_cookie_header($req);
-
-$h = $req->header("Cookie");
-ok($h =~ /PART_NUMBER=ROCKET_LAUNCHER_0001/);
-ok($h =~ /CUSTOMER=WILE_E_COYOTE/);
-ok($h !~ /SHIPPING=FEDEX/);
-
-
-$req = HTTP::Request->new(GET => "http://www.acme.com/foo/");
-$c->add_cookie_header($req);
-
-$h = $req->header("Cookie");
-ok($h =~ /PART_NUMBER=ROCKET_LAUNCHER_0001/);
-ok($h =~ /CUSTOMER=WILE_E_COYOTE/);
-ok($h =~ /^SHIPPING=FEDEX;/);
-
-print $c->as_string;
-
-
-# Second Example transaction sequence:
-#
-# Assume all mappings from above have been cleared.
-#
-# Client receives:
-#
-# Set-Cookie: PART_NUMBER=ROCKET_LAUNCHER_0001; path=/
-#
-# When client requests a URL in path "/" on this server, it sends:
-#
-# Cookie: PART_NUMBER=ROCKET_LAUNCHER_0001
-#
-# Client receives:
-#
-# Set-Cookie: PART_NUMBER=RIDING_ROCKET_0023; path=/ammo
-#
-# When client requests a URL in path "/ammo" on this server, it sends:
-#
-# Cookie: PART_NUMBER=RIDING_ROCKET_0023; PART_NUMBER=ROCKET_LAUNCHER_0001
-#
-# NOTE: There are two name/value pairs named "PART_NUMBER" due to
-# the inheritance of the "/" mapping in addition to the "/ammo" mapping.
-
-$c = HTTP::Cookies->new; # clear it
-
-$req = HTTP::Request->new(GET => "http://www.acme.com/");
-$res = HTTP::Response->new(200, "OK");
-$res->request($req);
-$res->header("Set-Cookie", "PART_NUMBER=ROCKET_LAUNCHER_0001; path=/");
-
-$c->extract_cookies($res);
-
-$req = HTTP::Request->new(GET => "http://www.acme.com/");
-$c->add_cookie_header($req);
-
-ok($req->header("Cookie"), "PART_NUMBER=ROCKET_LAUNCHER_0001");
-
-$res->request($req);
-$res->header("Set-Cookie", "PART_NUMBER=RIDING_ROCKET_0023; path=/ammo");
-$c->extract_cookies($res);
-
-$req = HTTP::Request->new(GET => "http://www.acme.com/ammo");
-$c->add_cookie_header($req);
-
-ok($req->header("Cookie") =~
- /^PART_NUMBER=RIDING_ROCKET_0023;\s*PART_NUMBER=ROCKET_LAUNCHER_0001/);
-
-print $c->as_string;
-undef($c);
-
-
-#-------------------------------------------------------------------
-# When there are no "Set-Cookie" header, then even responses
-# without any request URLs connected should be allowed.
-
-$c = HTTP::Cookies->new;
-$c->extract_cookies(HTTP::Response->new("200", "OK"));
-ok(count_cookies($c), 0);
-
-
-#-------------------------------------------------------------------
-# Then we test with the examples from RFC 2965.
-#
-# 5. EXAMPLES
-
-$c = HTTP::Cookies->new;
-
-#
-# 5.1 Example 1
-#
-# Most detail of request and response headers has been omitted. Assume
-# the user agent has no stored cookies.
-#
-# 1. User Agent -> Server
-#
-# POST /acme/login HTTP/1.1
-# [form data]
-#
-# User identifies self via a form.
-#
-# 2. Server -> User Agent
-#
-# HTTP/1.1 200 OK
-# Set-Cookie2: Customer="WILE_E_COYOTE"; Version="1"; Path="/acme"
-#
-# Cookie reflects user's identity.
-
-$cookie = interact($c, 'http://www.acme.com/acme/login',
- 'Customer="WILE_E_COYOTE"; Version="1"; Path="/acme"');
-ok(!$cookie);
-
-#
-# 3. User Agent -> Server
-#
-# POST /acme/pickitem HTTP/1.1
-# Cookie: $Version="1"; Customer="WILE_E_COYOTE"; $Path="/acme"
-# [form data]
-#
-# User selects an item for ``shopping basket.''
-#
-# 4. Server -> User Agent
-#
-# HTTP/1.1 200 OK
-# Set-Cookie2: Part_Number="Rocket_Launcher_0001"; Version="1";
-# Path="/acme"
-#
-# Shopping basket contains an item.
-
-$cookie = interact($c, 'http://www.acme.com/acme/pickitem',
- 'Part_Number="Rocket_Launcher_0001"; Version="1"; Path="/acme"');
-ok($cookie =~ m(^\$Version="?1"?; Customer="?WILE_E_COYOTE"?; \$Path="/acme"$));
-
-#
-# 5. User Agent -> Server
-#
-# POST /acme/shipping HTTP/1.1
-# Cookie: $Version="1";
-# Customer="WILE_E_COYOTE"; $Path="/acme";
-# Part_Number="Rocket_Launcher_0001"; $Path="/acme"
-# [form data]
-#
-# User selects shipping method from form.
-#
-# 6. Server -> User Agent
-#
-# HTTP/1.1 200 OK
-# Set-Cookie2: Shipping="FedEx"; Version="1"; Path="/acme"
-#
-# New cookie reflects shipping method.
-
-$cookie = interact($c, "http://www.acme.com/acme/shipping",
- 'Shipping="FedEx"; Version="1"; Path="/acme"');
-
-ok($cookie =~ /^\$Version="?1"?;/);
-ok($cookie =~ /Part_Number="?Rocket_Launcher_0001"?;\s*\$Path="\/acme"/);
-ok($cookie =~ /Customer="?WILE_E_COYOTE"?;\s*\$Path="\/acme"/);
-
-#
-# 7. User Agent -> Server
-#
-# POST /acme/process HTTP/1.1
-# Cookie: $Version="1";
-# Customer="WILE_E_COYOTE"; $Path="/acme";
-# Part_Number="Rocket_Launcher_0001"; $Path="/acme";
-# Shipping="FedEx"; $Path="/acme"
-# [form data]
-#
-# User chooses to process order.
-#
-# 8. Server -> User Agent
-#
-# HTTP/1.1 200 OK
-#
-# Transaction is complete.
-
-$cookie = interact($c, "http://www.acme.com/acme/process");
-print "FINAL COOKIE: $cookie\n";
-ok($cookie =~ /Shipping="?FedEx"?;\s*\$Path="\/acme"/);
-ok($cookie =~ /WILE_E_COYOTE/);
-
-#
-# The user agent makes a series of requests on the origin server, after
-# each of which it receives a new cookie. All the cookies have the same
-# Path attribute and (default) domain. Because the request URLs all have
-# /acme as a prefix, and that matches the Path attribute, each request
-# contains all the cookies received so far.
-
-print $c->as_string;
-
-
-# 5.2 Example 2
-#
-# This example illustrates the effect of the Path attribute. All detail
-# of request and response headers has been omitted. Assume the user agent
-# has no stored cookies.
-
-$c = HTTP::Cookies->new;
-
-# Imagine the user agent has received, in response to earlier requests,
-# the response headers
-#
-# Set-Cookie2: Part_Number="Rocket_Launcher_0001"; Version="1";
-# Path="/acme"
-#
-# and
-#
-# Set-Cookie2: Part_Number="Riding_Rocket_0023"; Version="1";
-# Path="/acme/ammo"
-
-interact($c, "http://www.acme.com/acme/ammo/specific",
- 'Part_Number="Rocket_Launcher_0001"; Version="1"; Path="/acme"',
- 'Part_Number="Riding_Rocket_0023"; Version="1"; Path="/acme/ammo"');
-
-# A subsequent request by the user agent to the (same) server for URLs of
-# the form /acme/ammo/... would include the following request header:
-#
-# Cookie: $Version="1";
-# Part_Number="Riding_Rocket_0023"; $Path="/acme/ammo";
-# Part_Number="Rocket_Launcher_0001"; $Path="/acme"
-#
-# Note that the NAME=VALUE pair for the cookie with the more specific Path
-# attribute, /acme/ammo, comes before the one with the less specific Path
-# attribute, /acme. Further note that the same cookie name appears more
-# than once.
-
-$cookie = interact($c, "http://www.acme.com/acme/ammo/...");
-ok($cookie =~ /Riding_Rocket_0023.*Rocket_Launcher_0001/);
-
-# A subsequent request by the user agent to the (same) server for a URL of
-# the form /acme/parts/ would include the following request header:
-#
-# Cookie: $Version="1"; Part_Number="Rocket_Launcher_0001"; $Path="/acme"
-#
-# Here, the second cookie's Path attribute /acme/ammo is not a prefix of
-# the request URL, /acme/parts/, so the cookie does not get forwarded to
-# the server.
-
-$cookie = interact($c, "http://www.acme.com/acme/parts/");
-ok($cookie =~ /Rocket_Launcher_0001/);
-ok($cookie !~ /Riding_Rocket_0023/);
-
-print $c->as_string;
-
-#-----------------------------------------------------------------------
-
-# Test rejection of Set-Cookie2 responses based on domain, path or port
-
-$c = HTTP::Cookies->new;
-
-# illegal domain (no embedded dots)
-$cookie = interact($c, "http://www.acme.com", 'foo=bar; domain=".com"');
-ok(count_cookies($c), 0);
-
-# legal domain
-$cookie = interact($c, "http://www.acme.com", 'foo=bar; domain="acme.com"');
-ok(count_cookies($c), 1);
-
-# illegal domain (host prefix "www.a" contains a dot)
-$cookie = interact($c, "http://www.a.acme.com", 'foo=bar; domain="acme.com"');
-ok(count_cookies($c), 1);
-
-# legal domain
-$cookie = interact($c, "http://www.a.acme.com", 'foo=bar; domain=".a.acme.com"');
-ok(count_cookies($c), 2);
-
-# can't use a IP-address as domain
-$cookie = interact($c, "http://125.125.125.125", 'foo=bar; domain="125.125.125"');
-ok(count_cookies($c), 2);
-
-# illegal path (must be prefix of request path)
-$cookie = interact($c, "http://www.sol.no", 'foo=bar; domain=".sol.no"; path="/foo"');
-ok(count_cookies($c), 2);
-
-# legal path
-$cookie = interact($c, "http://www.sol.no/foo/bar", 'foo=bar; domain=".sol.no"; path="/foo"');
-ok(count_cookies($c), 3);
-
-# illegal port (request-port not in list)
-$cookie = interact($c, "http://www.sol.no", 'foo=bar; domain=".sol.no"; port="90,100"');
-ok(count_cookies($c), 3);
-
-# legal port
-$cookie = interact($c, "http://www.sol.no", 'foo=bar; domain=".sol.no"; port="90,100, 80,8080"; max-age=100; Comment = "Just kidding! (\"|\\\\) "');
-ok(count_cookies($c), 4);
-
-# port attribute without any value (current port)
-$cookie = interact($c, "http://www.sol.no", 'foo9=bar; domain=".sol.no"; port; max-age=100;');
-ok(count_cookies($c), 5);
-
-# encoded path
-$cookie = interact($c, "http://www.sol.no/foo/", 'foo8=bar; path="/%66oo"');
-ok(count_cookies($c), 6);
-
-my $file = "lwp-cookies-$$.txt";
-$c->save($file);
-$old = $c->as_string;
-undef($c);
-
-$c = HTTP::Cookies->new;
-$c->load($file);
-unlink($file) || warn "Can't unlink $file: $!";
-
-ok($old, $c->as_string);
-
-undef($c);
-
-#
-# Try some URL encodings of the PATHs
-#
-$c = HTTP::Cookies->new;
-interact($c, "http://www.acme.com/foo%2f%25/%40%40%0Anew%E5/%E5", 'foo = bar; version = 1');
-print $c->as_string;
-
-$cookie = interact($c, "http://www.acme.com/foo%2f%25/@@%0anewå/æøå", "bar=baz; path=\"/foo/\"; version=1");
-ok($cookie =~ /foo=bar/);
-ok($cookie =~ /^\$version=\"?1\"?/i);
-
-$cookie = interact($c, "http://www.acme.com/foo/%25/@@%0anewå/æøå");
-ok(!$cookie);
-
-undef($c);
-
-#
-# Try to use the Netscape cookie file format for saving
-#
-$file = "cookies-$$.txt";
-$c = HTTP::Cookies::Netscape->new(file => $file);
-interact($c, "http://www.acme.com/", "foo1=bar; max-age=100");
-interact($c, "http://www.acme.com/", "foo2=bar; port=\"80\"; max-age=100; Discard; Version=1");
-interact($c, "http://www.acme.com/", "foo3=bar; secure; Version=1");
-$c->save;
-undef($c);
-
-$c = HTTP::Cookies::Netscape->new(file => $file);
-ok(count_cookies($c), 1); # 2 of them discarded on save
-
-ok($c->as_string =~ /foo1=bar/);
-undef($c);
-unlink($file);
-
-
-#
-# Some additional Netscape cookies test
-#
-$c = HTTP::Cookies->new;
-$req = HTTP::Request->new(POST => "http://foo.bar.acme.com/foo");
-
-# Netscape allows a host part that contains dots
-$res = HTTP::Response->new(200, "OK");
-$res->header(set_cookie => 'Customer=WILE_E_COYOTE; domain=.acme.com');
-$res->request($req);
-$c->extract_cookies($res);
-
-# and that the domain is the same as the host without adding a leading
-# dot to the domain. Should not quote even if strange chars are used
-# in the cookie value.
-$res = HTTP::Response->new(200, "OK");
-$res->header(set_cookie => 'PART_NUMBER=3,4; domain=foo.bar.acme.com');
-$res->request($req);
-$c->extract_cookies($res);
-
-print $c->as_string;
-
-require URI;
-$req = HTTP::Request->new(POST => URI->new("http://foo.bar.acme.com/foo"));
-$c->add_cookie_header($req);
-#print $req->as_string;
-ok($req->header("Cookie") =~ /PART_NUMBER=3,4/);
-ok($req->header("Cookie") =~ /Customer=WILE_E_COYOTE/);
-
-
-# Test handling of local intranet hostnames without a dot
-$c->clear;
-print "---\n";
-
-interact($c, "http://example/", "foo1=bar; PORT; Discard;");
-$_=interact($c, "http://example/", 'foo2=bar; domain=".local"');
-ok(/foo1=bar/);
-
-$_=interact($c, "http://example/", 'foo3=bar');
-$_=interact($c, "http://example/");
-print "Cookie: $_\n";
-ok(/foo2=bar/);
-ok(count_cookies($c), 3);
-print $c->as_string;
-
-# Test for empty path
-# Broken web-server ORION/1.3.38 returns to the client response like
-#
-# Set-Cookie: JSESSIONID=ABCDERANDOM123; Path=
-#
-# e.g. with Path set to nothing.
-# In this case routine extract_cookies() must set cookie to / (root)
-print "---\n";
-print "Test for empty path...\n";
-$c = HTTP::Cookies->new; # clear it
-
-$req = HTTP::Request->new(GET => "http://www.ants.com/");
-
-$res = HTTP::Response->new(200, "OK");
-$res->request($req);
-$res->header("Set-Cookie" => "JSESSIONID=ABCDERANDOM123; Path=");
-print $res->as_string;
-$c->extract_cookies($res);
-#print $c->as_string;
-
-$req = HTTP::Request->new(GET => "http://www.ants.com/");
-$c->add_cookie_header($req);
-#print $req->as_string;
-
-ok($req->header("Cookie"), "JSESSIONID=ABCDERANDOM123");
-ok($req->header("Cookie2"), "\$Version=\"1\"");
-
-
-# missing path in the request URI
-$req = HTTP::Request->new(GET => URI->new("http://www.ants.com:8080"));
-$c->add_cookie_header($req);
-#print $req->as_string;
-
-ok($req->header("Cookie"), "JSESSIONID=ABCDERANDOM123");
-ok($req->header("Cookie2"), "\$Version=\"1\"");
-
-# test mixing of Set-Cookie and Set-Cookie2 headers.
-# Example from http://www.trip.com/trs/trip/flighttracker/flight_tracker_home.xsl
-# which gives up these headers:
-#
-# HTTP/1.1 200 OK
-# Connection: close
-# Date: Fri, 20 Jul 2001 19:54:58 GMT
-# Server: Apache/1.3.19 (Unix) ApacheJServ/1.1.2
-# Content-Type: text/html
-# Content-Type: text/html; charset=iso-8859-1
-# Link: </trip/stylesheet.css>; rel="stylesheet"; type="text/css"
-# Servlet-Engine: Tomcat Web Server/3.2.1 (JSP 1.1; Servlet 2.2; Java 1.3.0; SunOS 5.8 sparc; java.vendor=Sun Microsystems Inc.)
-# Set-Cookie: trip.appServer=1111-0000-x-024;Domain=.trip.com;Path=/
-# Set-Cookie: JSESSIONID=fkumjm7nt1.JS24;Path=/trs
-# Set-Cookie2: JSESSIONID=fkumjm7nt1.JS24;Version=1;Discard;Path="/trs"
-# Title: TRIP.com Travel - FlightTRACKER
-# X-Meta-Description: Trip.com privacy policy
-# X-Meta-Keywords: privacy policy
-
-$req = HTTP::Request->new('GET', 'http://www.trip.com/trs/trip/flighttracker/flight_tracker_home.xsl');
-$res = HTTP::Response->new(200, "OK");
-$res->request($req);
-$res->push_header("Set-Cookie" => qq(trip.appServer=1111-0000-x-024;Domain=.trip.com;Path=/));
-$res->push_header("Set-Cookie" => qq(JSESSIONID=fkumjm7nt1.JS24;Path=/trs));
-$res->push_header("Set-Cookie2" => qq(JSESSIONID=fkumjm7nt1.JS24;Version=1;Discard;Path="/trs"));
-#print $res->as_string;
-
-$c = HTTP::Cookies->new; # clear it
-$c->extract_cookies($res);
-print $c->as_string;
-ok($c->as_string, <<'EOT');
-Set-Cookie3: trip.appServer=1111-0000-x-024; path="/"; domain=.trip.com; path_spec; discard; version=0
-Set-Cookie3: JSESSIONID=fkumjm7nt1.JS24; path="/trs"; domain=www.trip.com; path_spec; discard; version=1
-EOT
-
-#-------------------------------------------------------------------
-# Test if temporary cookies are deleted properly with
-# $jar->clear_temporary_cookies()
-
-$req = HTTP::Request->new('GET', 'http://www.perlmeister.com/scripts');
-$res = HTTP::Response->new(200, "OK");
-$res->request($req);
- # Set session/perm cookies and mark their values as "session" vs. "perm"
- # to recognize them later
-$res->push_header("Set-Cookie" => qq(s1=session;Path=/scripts));
-$res->push_header("Set-Cookie" => qq(p1=perm; Domain=.perlmeister.com;Path=/;expires=Fri, 02-Feb-$year_plus_one 23:24:20 GMT));
-$res->push_header("Set-Cookie" => qq(p2=perm;Path=/;expires=Fri, 02-Feb-$year_plus_one 23:24:20 GMT));
-$res->push_header("Set-Cookie" => qq(s2=session;Path=/scripts;Domain=.perlmeister.com));
-$res->push_header("Set-Cookie2" => qq(s3=session;Version=1;Discard;Path="/"));
-
-$c = HTTP::Cookies->new; # clear jar
-$c->extract_cookies($res);
-# How many session/permanent cookies do we have?
-my %counter = ("session_after" => 0);
-$c->scan( sub { $counter{"${_[2]}_before"}++ } );
-$c->clear_temporary_cookies();
-# How many now?
-$c->scan( sub { $counter{"${_[2]}_after"}++ } );
-ok($counter{"perm_after"}, $counter{"perm_before"}); # a permanent cookie got lost accidently
-ok($counter{"session_after"}, 0); # a session cookie hasn't been cleared
-ok($counter{"session_before"}, 3); # we didn't have session cookies in the first place
-#print $c->as_string;
-
-
-# Test handling of 'secure ' attribute for classic cookies
-$c = HTTP::Cookies->new;
-$req = HTTP::Request->new(GET => "https://1.1.1.1/");
-$req->header("Host", "www.acme.com:80");
-
-$res = HTTP::Response->new(200, "OK");
-$res->request($req);
-$res->header("Set-Cookie" => "CUSTOMER=WILE_E_COYOTE ; secure ; path=/");
-#print $res->as_string;
-$c->extract_cookies($res);
-
-$req = HTTP::Request->new(GET => "http://www.acme.com/");
-$c->add_cookie_header($req);
-
-ok(!$req->header("Cookie"));
-
-$req->uri->scheme("https");
-$c->add_cookie_header($req);
-
-ok($req->header("Cookie"), "CUSTOMER=WILE_E_COYOTE");
-
-#print $req->as_string;
-#print $c->as_string;
-
-
-$req = HTTP::Request->new(GET => "ftp://ftp.activestate.com/");
-$c->add_cookie_header($req);
-ok(!$req->header("Cookie"));
-
-$req = HTTP::Request->new(GET => "file:/etc/motd");
-$c->add_cookie_header($req);
-ok(!$req->header("Cookie"));
-
-$req = HTTP::Request->new(GET => "mailto:gisle\@aas.no");
-$c->add_cookie_header($req);
-ok(!$req->header("Cookie"));
-
-
-# Test cookie called 'exipres' <https://rt.cpan.org/Ticket/Display.html?id=8108>
-$c = HTTP::Cookies->new;
-$req = HTTP::Request->new("GET" => "http://example.com");
-$res = HTTP::Response->new(200, "OK");
-$res->request($req);
-$res->header("Set-Cookie" => "Expires=10101");
-$c->extract_cookies($res);
-#print $c->as_string;
-ok($c->as_string, <<'EOT');
-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;
-ok($c->as_string, <<'EOT');
-Set-Cookie3: CUSTOMER=WILE_E_COYOTE; path="/"; domain=example.com; path_spec; discard; version=0
-EOT
-
-# Test empty cookie part [RT#38480]
-$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;
-ok($c->as_string, <<'EOT');
-Set-Cookie3: CUSTOMER=WILE_E_COYOTE; path="/"; domain=example.com; path_spec; discard; version=0
-EOT
-
-# Test Set-Cookie with version set
-$c = HTTP::Cookies->new;
-$res->header("Set-Cookie" => "foo=\"bar\";version=1");
-#print $res->as_string;
-$c->extract_cookies($res);
-#print $c->as_string;
-$req = HTTP::Request->new(GET => "http://www.example.com/foo");
-$c->add_cookie_header($req);
-#print $req->as_string;
-ok($req->header("Cookie"), "foo=\"bar\"");
-
-# Test cookies that expire far into the future [RT#50147]
-$c = HTTP::Cookies->new;
-$res->header("Set-Cookie", "PREF=ID=cee18f7c4e977184:TM=1254583090:LM=1254583090:S=Pdb0-hy9PxrNj4LL; expires=Mon, 03-Oct-2211 15:18:10 GMT; path=/; domain=.example.com");
-$res->push_header("Set-Cookie", "expired1=1; expires=Mon, 03-Oct-2001 15:18:10 GMT; path=/; domain=.example.com");
-$res->push_header("Set-Cookie", "expired2=1; expires=Fri Jan 1 00:00:00 GMT 1970; path=/; domain=.example.com");
-$res->push_header("Set-Cookie", "expired3=1; expires=Fri Jan 1 00:00:01 GMT 1970; path=/; domain=.example.com");
-$res->push_header("Set-Cookie", "expired4=1; expires=Thu Dec 31 23:59:59 GMT 1969; path=/; domain=.example.com");
-$res->push_header("Set-Cookie", "expired5=1; expires=Fri Feb 2 00:00:00 GMT 1950; path=/; domain=.example.com");
-$c->extract_cookies($res);
-#print $res->as_string;
-#print "---\n";
-#print $c->as_string;
-$req = HTTP::Request->new(GET => "http://www.example.com/foo");
-$c->add_cookie_header($req);
-#print $req->as_string;
-ok($req->header("Cookie"), "PREF=ID=cee18f7c4e977184:TM=1254583090:LM=1254583090:S=Pdb0-hy9PxrNj4LL");
-
-$c->clear_temporary_cookies;
-$req = HTTP::Request->new(GET => "http://www.example.com/foo");
-$c->add_cookie_header($req);
-#print $req->as_string;
-ok($req->header("Cookie"), "PREF=ID=cee18f7c4e977184:TM=1254583090:LM=1254583090:S=Pdb0-hy9PxrNj4LL");
-
-# Test merging of cookies
-$c = HTTP::Cookies->new;
-$res->header("Set-Cookie", "foo=1; path=/");
-$c->extract_cookies($res);
-
-$req = HTTP::Request->new(GET => "http://www.example.com/foo");
-$req->header("Cookie", "x=bcd");
-$c->add_cookie_header($req);
-ok($req->header("Cookie"), "x=bcd; foo=1");
-$c->add_cookie_header($req);
-ok($req->header("Cookie"), "x=bcd; foo=1; foo=1");
-#print $req->as_string;
-
-
-#-------------------------------------------------------------------
-
-sub interact
-{
- my $c = shift;
- my $url = shift;
- my $req = HTTP::Request->new(POST => $url);
- $c->add_cookie_header($req);
- my $cookie = $req->header("Cookie");
- my $res = HTTP::Response->new(200, "OK");
- $res->request($req);
- for (@_) { $res->push_header("Set-Cookie2" => $_) }
- $c->extract_cookies($res);
- return $cookie;
-}
-
-sub count_cookies
-{
- my $c = shift;
- my $no = 0;
- $c->scan(sub { $no++ });
- $no;
-}
+++ /dev/null
-#!perl -w
-
-use strict;
-use Test;
-
-plan tests => 133;
-
-use HTTP::Date;
-
-require Time::Local if $^O eq "MacOS";
-my $offset = ($^O eq "MacOS") ? Time::Local::timegm(0,0,0,1,0,70) : 0;
-
-# test str2time for supported dates. Test cases with 2 digit year
-# will probably break in year 2044.
-my(@tests) =
-(
- 'Thu Feb 3 00:00:00 GMT 1994', # ctime format
- 'Thu Feb 3 00:00:00 1994', # same as ctime, except no TZ
-
- 'Thu, 03 Feb 1994 00:00:00 GMT', # proposed new HTTP format
- 'Thursday, 03-Feb-94 00:00:00 GMT', # old rfc850 HTTP format
- 'Thursday, 03-Feb-1994 00:00:00 GMT', # broken rfc850 HTTP format
-
- '03/Feb/1994:00:00:00 0000', # common logfile format
- '03/Feb/1994:01:00:00 +0100', # common logfile format
- '02/Feb/1994:23:00:00 -0100', # common logfile format
-
- '03 Feb 1994 00:00:00 GMT', # HTTP format (no weekday)
- '03-Feb-94 00:00:00 GMT', # old rfc850 (no weekday)
- '03-Feb-1994 00:00:00 GMT', # broken rfc850 (no weekday)
- '03-Feb-1994 00:00 GMT', # broken rfc850 (no weekday, no seconds)
- '03-Feb-1994 00:00', # VMS dir listing format
-
- '03-Feb-94', # old rfc850 HTTP format (no weekday, no time)
- '03-Feb-1994', # broken rfc850 HTTP format (no weekday, no time)
- '03 Feb 1994', # proposed new HTTP format (no weekday, no time)
- '03/Feb/1994', # common logfile format (no time, no offset)
-
- #'Feb 3 00:00', # Unix 'ls -l' format (can't really test it here)
- 'Feb 3 1994', # Unix 'ls -l' format
-
- "02-03-94 12:00AM", # Windows 'dir' format
-
- # ISO 8601 formats
- '1994-02-03 00:00:00 +0000',
- '1994-02-03',
- '19940203',
- '1994-02-03T00:00:00+0000',
- '1994-02-02T23:00:00-0100',
- '1994-02-02T23:00:00-01:00',
- '1994-02-03T00:00:00 Z',
- '19940203T000000Z',
- '199402030000',
-
- # A few tests with extra space at various places
- ' 03/Feb/1994 ',
- ' 03 Feb 1994 0:00 ',
-);
-
-my $time = (760233600 + $offset); # assume broken POSIX counting of seconds
-for (@tests) {
- my $t;
- if (/GMT/i) {
- $t = str2time($_);
- }
- else {
- $t = str2time($_, "GMT");
- }
- my $t2 = str2time(lc($_), "GMT");
- my $t3 = str2time(uc($_), "GMT");
-
- print "\n# '$_'\n";
-
- ok($t, $time);
- ok($t2, $time);
- ok($t3, $time);
-}
-
-# test time2str
-ok(time2str($time), 'Thu, 03 Feb 1994 00:00:00 GMT');
-
-# test the 'ls -l' format with missing year$
-# round to nearest minute 3 days ago.
-$time = int((time - 3 * 24*60*60) /60)*60;
-my ($min, $hr, $mday, $mon) = (localtime $time)[1,2,3,4];
-$mon = (qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec))[$mon];
-my $str = sprintf("$mon %02d %02d:%02d", $mday, $hr, $min);
-my $t = str2time($str);
-ok($t, $time);
-
-# try some garbage.
-for (undef, '', 'Garbage',
- 'Mandag 16. September 1996',
- '12 Arp 2003',
-# 'Thu Feb 3 00:00:00 CET 1994',
-# 'Thu, 03 Feb 1994 00:00:00 CET',
-# 'Wednesday, 31-Dec-69 23:59:59 GMT',
-
- '1980-00-01',
- '1980-13-01',
- '1980-01-00',
- '1980-01-32',
- '1980-01-01 25:00:00',
- '1980-01-01 00:61:00',
- '1980-01-01 00:00:61',
- )
-{
- my $bad = 0;
- eval {
- if (defined str2time $_) {
- print "str2time($_) is not undefined\n";
- $bad++;
- }
- };
- print defined($_) ? "\n# '$_'\n" : "\n# undef\n";
- ok(!$@);
- ok(!$bad);
-}
-
-print "Testing AM/PM gruff...\n";
-
-# Test the str2iso routines
-use HTTP::Date qw(time2iso time2isoz);
-
-print "Testing time2iso functions\n";
-
-$t = time2iso(str2time("11-12-96 0:00AM"));
-ok($t, "1996-11-12 00:00:00");
-
-$t = time2iso(str2time("11-12-96 12:00AM"));
-ok($t, "1996-11-12 00:00:00");
-
-$t = time2iso(str2time("11-12-96 0:00PM"));
-ok($t, "1996-11-12 12:00:00");
-
-$t = time2iso(str2time("11-12-96 12:00PM"));
-ok($t, "1996-11-12 12:00:00");
-
-
-$t = time2iso(str2time("11-12-96 1:05AM"));
-ok($t, "1996-11-12 01:05:00");
-
-$t = time2iso(str2time("11-12-96 12:05AM"));
-ok($t, "1996-11-12 00:05:00");
-
-$t = time2iso(str2time("11-12-96 1:05PM"));
-ok($t, "1996-11-12 13:05:00");
-
-$t = time2iso(str2time("11-12-96 12:05PM"));
-ok($t, "1996-11-12 12:05:00");
-
-$t = str2time("2000-01-01 00:00:01.234");
-print "FRAC $t = ", time2iso($t), "\n";
-ok(abs(($t - int($t)) - 0.234) < 0.000001);
-
-$a = time2iso;
-$b = time2iso(500000);
-print "LOCAL $a $b\n";
-my $az = time2isoz;
-my $bz = time2isoz(500000);
-print "GMT $az $bz\n";
-
-for ($a, $b) { ok(/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d$/); }
-for ($az, $bz) { ok(/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\dZ$/); }
-
-# Test the parse_date interface
-use HTTP::Date qw(parse_date);
-
-my @d = parse_date("Jan 1 2001");
-
-ok(!defined(pop(@d)));
-ok("@d", "2001 1 1 0 0 0");
-
-# This test will break around year 2070
-ok(parse_date("03-Feb-20"), "2020-02-03 00:00:00");
-
-# This test will break around year 2048
-ok(parse_date("03-Feb-98"), "1998-02-03 00:00:00");
-
-print "HTTP::Date $HTTP::Date::VERSION\n";
+++ /dev/null
-#!perl -w
-
-use strict;
-use Test;
-
-plan tests => 6;
-
-use HTTP::Response;
-use HTTP::Headers::Auth;
-
-my $res = HTTP::Response->new(401);
-$res->push_header(WWW_Authenticate => qq(Foo realm="WallyWorld", foo=bar, Bar realm="WallyWorld2"));
-$res->push_header(WWW_Authenticate => qq(Basic Realm="WallyWorld", foo=bar, bar=baz));
-
-print $res->as_string;
-
-my %auth = $res->www_authenticate;
-
-ok(keys(%auth), 3);
-
-ok($auth{basic}{realm}, "WallyWorld");
-ok($auth{bar}{realm}, "WallyWorld2");
-
-$a = $res->www_authenticate;
-ok($a, 'Foo realm="WallyWorld", foo=bar, Bar realm="WallyWorld2", Basic Realm="WallyWorld", foo=bar, bar=baz');
-
-$res->www_authenticate("Basic realm=foo1");
-print $res->as_string;
-
-$res->www_authenticate(Basic => {realm => "foo2"});
-print $res->as_string;
-
-$res->www_authenticate(Basic => [realm => "foo3", foo=>33],
- Digest => {nonce=>"bar", foo=>'foo'});
-print $res->as_string;
-
-$_ = $res->as_string;
-
-ok(/WWW-Authenticate: Basic realm="foo3", foo=33/);
-ok(/WWW-Authenticate: Digest nonce=bar, foo=foo/ ||
- /WWW-Authenticate: Digest foo=foo, nonce=bar/);
-
+++ /dev/null
-#!perl -w
-
-use strict;
-use Test;
-
-plan tests => 4;
-
-require HTTP::Headers::ETag;
-
-my $h = HTTP::Headers->new;
-
-$h->etag("tag1");
-ok($h->etag, qq("tag1"));
-
-$h->etag("w/tag2");
-ok($h->etag, qq(W/"tag2"));
-
-$h->if_match(qq(W/"foo", bar, baz), "bar");
-$h->if_none_match(333);
-
-$h->if_range("tag3");
-ok($h->if_range, qq("tag3"));
-
-my $t = time;
-$h->if_range($t);
-ok($h->if_range, $t);
-
-print $h->as_string;
-
+++ /dev/null
-#!perl -w
-
-use strict;
-use Test;
-
-use HTTP::Headers::Util qw(split_header_words join_header_words);
-
-my @s_tests = (
-
- ["foo" => "foo"],
- ["foo=bar" => "foo=bar"],
- [" foo " => "foo"],
- ["foo=" => 'foo=""'],
- ["foo=bar bar=baz" => "foo=bar; bar=baz"],
- ["foo=bar;bar=baz" => "foo=bar; bar=baz"],
- ['foo bar baz' => "foo; bar; baz"],
- ['foo="\"" bar="\\\\"' => 'foo="\""; bar="\\\\"'],
- ['foo,,,bar' => 'foo, bar'],
- ['foo=bar,bar=baz' => 'foo=bar, bar=baz'],
-
- ['TEXT/HTML; CHARSET=ISO-8859-1' =>
- 'text/html; charset=ISO-8859-1'],
-
- ['foo="bar"; port="80,81"; discard, bar=baz' =>
- 'foo=bar; port="80,81"; discard, bar=baz'],
-
- ['Basic realm="\"foo\\\\bar\""' =>
- 'basic; realm="\"foo\\\\bar\""'],
-);
-
-plan tests => @s_tests + 2;
-
-for (@s_tests) {
- my($arg, $expect) = @$_;
- my @arg = ref($arg) ? @$arg : $arg;
-
- my $res = join_header_words(split_header_words(@arg));
- ok($res, $expect);
-}
-
-
-print "# Extra tests\n";
-# some extra tests
-ok(join_header_words("foo" => undef, "bar" => "baz"), "foo; bar=baz");
-ok(join_header_words(), "");
+++ /dev/null
-#!perl -w
-
-use strict;
-use Test qw(plan ok);
-
-plan tests => 164;
-
-my($h, $h2);
-sub j { join("|", @_) }
-
-
-require HTTP::Headers;
-$h = HTTP::Headers->new;
-ok($h);
-ok(ref($h), "HTTP::Headers");
-ok($h->as_string, "");
-
-$h = HTTP::Headers->new(foo => "bar", foo => "baaaaz", Foo => "baz");
-ok($h->as_string, "Foo: bar\nFoo: baaaaz\nFoo: baz\n");
-
-$h = HTTP::Headers->new(foo => ["bar", "baz"]);
-ok($h->as_string, "Foo: bar\nFoo: baz\n");
-
-$h = HTTP::Headers->new(foo => 1, bar => 2, foo_bar => 3);
-ok($h->as_string, "Bar: 2\nFoo: 1\nFoo-Bar: 3\n");
-ok($h->as_string(";"), "Bar: 2;Foo: 1;Foo-Bar: 3;");
-
-ok($h->header("Foo"), 1);
-ok($h->header("FOO"), 1);
-ok(j($h->header("foo")), 1);
-ok($h->header("foo-bar"), 3);
-ok($h->header("foo_bar"), 3);
-ok($h->header("Not-There"), undef);
-ok(j($h->header("Not-There")), "");
-ok(eval { $h->header }, undef);
-ok($@);
-
-ok($h->header("Foo", 11), 1);
-ok($h->header("Foo", [1, 1]), 11);
-ok($h->header("Foo"), "1, 1");
-ok(j($h->header("Foo")), "1|1");
-ok($h->header(foo => 11, Foo => 12, bar => 22), 2);
-ok($h->header("Foo"), "11, 12");
-ok($h->header("Bar"), 22);
-ok($h->header("Bar", undef), 22);
-ok(j($h->header("bar", 22)), "");
-
-$h->push_header(Bar => 22);
-ok($h->header("Bar"), "22, 22");
-$h->push_header(Bar => [23 .. 25]);
-ok($h->header("Bar"), "22, 22, 23, 24, 25");
-ok(j($h->header("Bar")), "22|22|23|24|25");
-
-$h->clear;
-$h->header(Foo => 1);
-ok($h->as_string, "Foo: 1\n");
-$h->init_header(Foo => 2);
-$h->init_header(Bar => 2);
-ok($h->as_string, "Bar: 2\nFoo: 1\n");
-$h->init_header(Foo => [2, 3]);
-$h->init_header(Baz => [2, 3]);
-ok($h->as_string, "Bar: 2\nBaz: 2\nBaz: 3\nFoo: 1\n");
-
-eval { $h->init_header(A => 1, B => 2, C => 3) };
-ok($@);
-ok($h->as_string, "Bar: 2\nBaz: 2\nBaz: 3\nFoo: 1\n");
-
-ok($h->clone->remove_header("Foo"), 1);
-ok($h->clone->remove_header("Bar"), 1);
-ok($h->clone->remove_header("Baz"), 2);
-ok($h->clone->remove_header(qw(Foo Bar Baz Not-There)), 4);
-ok($h->clone->remove_header("Not-There"), 0);
-ok(j($h->clone->remove_header("Foo")), 1);
-ok(j($h->clone->remove_header("Bar")), 2);
-ok(j($h->clone->remove_header("Baz")), "2|3");
-ok(j($h->clone->remove_header(qw(Foo Bar Baz Not-There))), "1|2|2|3");
-ok(j($h->clone->remove_header("Not-There")), "");
-
-$h = HTTP::Headers->new(
- allow => "GET",
- content => "none",
- content_type => "text/html",
- content_md5 => "dummy",
- content_encoding => "gzip",
- content_foo => "bar",
- last_modified => "yesterday",
- expires => "tomorrow",
- etag => "abc",
- date => "today",
- user_agent => "libwww-perl",
- zoo => "foo",
- );
-ok($h->as_string, <<EOT);
-Date: today
-User-Agent: libwww-perl
-ETag: abc
-Allow: GET
-Content-Encoding: gzip
-Content-MD5: dummy
-Content-Type: text/html
-Expires: tomorrow
-Last-Modified: yesterday
-Content: none
-Content-Foo: bar
-Zoo: foo
-EOT
-
-$h2 = $h->clone;
-ok($h->as_string, $h2->as_string);
-
-ok($h->remove_content_headers->as_string, <<EOT);
-Allow: GET
-Content-Encoding: gzip
-Content-MD5: dummy
-Content-Type: text/html
-Expires: tomorrow
-Last-Modified: yesterday
-Content-Foo: bar
-EOT
-
-ok($h->as_string, <<EOT);
-Date: today
-User-Agent: libwww-perl
-ETag: abc
-Content: none
-Zoo: foo
-EOT
-
-# separate code path for the void context case, so test it as well
-$h2->remove_content_headers;
-ok($h->as_string, $h2->as_string);
-
-$h->clear;
-ok($h->as_string, "");
-undef($h2);
-
-$h = HTTP::Headers->new;
-ok($h->header_field_names, 0);
-ok(j($h->header_field_names), "");
-
-$h = HTTP::Headers->new( etag => 1, foo => [2,3],
- content_type => "text/plain");
-ok($h->header_field_names, 3);
-ok(j($h->header_field_names), "ETag|Content-Type|Foo");
-
-{
- my @tmp;
- $h->scan(sub { push(@tmp, @_) });
- ok(j(@tmp), "ETag|1|Content-Type|text/plain|Foo|2|Foo|3");
-
- @tmp = ();
- eval { $h->scan(sub { push(@tmp, @_); die if $_[0] eq "Content-Type" }) };
- ok($@);
- ok(j(@tmp), "ETag|1|Content-Type|text/plain");
-
- @tmp = ();
- $h->scan(sub { push(@tmp, @_) });
- ok(j(@tmp), "ETag|1|Content-Type|text/plain|Foo|2|Foo|3");
-}
-
-# CONVENIENCE METHODS
-
-$h = HTTP::Headers->new;
-ok($h->date, undef);
-ok($h->date(time), undef);
-ok(j($h->header_field_names), "Date");
-ok($h->header("Date") =~ /^[A-Z][a-z][a-z], \d\d .* GMT$/);
-{
- my $off = time - $h->date;
- ok($off == 0 || $off == 1);
-}
-
-if ($] < 5.006) {
- Test::skip("Can't call variable method", 1) for 1..13;
-}
-else {
-# other date fields
-for my $field (qw(expires if_modified_since if_unmodified_since
- last_modified))
-{
- eval <<'EOT'; die $@ if $@;
- ok($h->$field, undef);
- ok($h->$field(time), undef);
- ok((time - $h->$field) =~ /^[01]$/);
-EOT
-}
-ok(j($h->header_field_names), "Date|If-Modified-Since|If-Unmodified-Since|Expires|Last-Modified");
-}
-
-$h->clear;
-ok($h->content_type, "");
-ok($h->content_type("text/html"), "");
-ok($h->content_type, "text/html");
-ok($h->content_type(" TEXT / HTML ") , "text/html");
-ok($h->content_type, "text/html");
-ok(j($h->content_type), "text/html");
-ok($h->content_type("text/html;\n charSet = \"ISO-8859-1\"; Foo=1 "), "text/html");
-ok($h->content_type, "text/html");
-ok(j($h->content_type), "text/html|charSet = \"ISO-8859-1\"; Foo=1 ");
-ok($h->header("content_type"), "text/html;\n charSet = \"ISO-8859-1\"; Foo=1 ");
-ok($h->content_is_html);
-ok(!$h->content_is_xhtml);
-ok(!$h->content_is_xml);
-$h->content_type("application/xhtml+xml");
-ok($h->content_is_html);
-ok($h->content_is_xhtml);
-ok($h->content_is_xml);
-ok($h->content_type("text/html;\n charSet = \"ISO-8859-1\"; Foo=1 "), "application/xhtml+xml");
-
-ok($h->content_encoding, undef);
-ok($h->content_encoding("gzip"), undef);
-ok($h->content_encoding, "gzip");
-ok(j($h->header_field_names), "Content-Encoding|Content-Type");
-
-ok($h->content_language, undef);
-ok($h->content_language("no"), undef);
-ok($h->content_language, "no");
-
-ok($h->title, undef);
-ok($h->title("This is a test"), undef);
-ok($h->title, "This is a test");
-
-ok($h->user_agent, undef);
-ok($h->user_agent("Mozilla/1.2"), undef);
-ok($h->user_agent, "Mozilla/1.2");
-
-ok($h->server, undef);
-ok($h->server("Apache/2.1"), undef);
-ok($h->server, "Apache/2.1");
-
-ok($h->from("Gisle\@ActiveState.com"), undef);
-ok($h->header("from", "Gisle\@ActiveState.com"));
-
-ok($h->referer("http://www.example.com"), undef);
-ok($h->referer, "http://www.example.com");
-ok($h->referrer, "http://www.example.com");
-ok($h->referer("http://www.example.com/#bar"), "http://www.example.com");
-ok($h->referer, "http://www.example.com/");
-{
- require URI;
- my $u = URI->new("http://www.example.com#bar");
- $h->referer($u);
- ok($u->as_string, "http://www.example.com#bar");
- ok($h->referer->fragment, undef);
- ok($h->referrer->as_string, "http://www.example.com");
-}
-
-ok($h->as_string, <<EOT);
-From: Gisle\@ActiveState.com
-Referer: http://www.example.com
-User-Agent: Mozilla/1.2
-Server: Apache/2.1
-Content-Encoding: gzip
-Content-Language: no
-Content-Type: text/html;
- charSet = "ISO-8859-1"; Foo=1
-Title: This is a test
-EOT
-
-$h->clear;
-ok($h->www_authenticate("foo"), undef);
-ok($h->www_authenticate("bar"), "foo");
-ok($h->www_authenticate, "bar");
-ok($h->proxy_authenticate("foo"), undef);
-ok($h->proxy_authenticate("bar"), "foo");
-ok($h->proxy_authenticate, "bar");
-
-ok($h->authorization_basic, undef);
-ok($h->authorization_basic("u"), undef);
-ok($h->authorization_basic("u", "p"), "u:");
-ok($h->authorization_basic, "u:p");
-ok(j($h->authorization_basic), "u|p");
-ok($h->authorization, "Basic dTpw");
-
-ok(eval { $h->authorization_basic("u2:p") }, undef);
-ok($@);
-ok(j($h->authorization_basic), "u|p");
-
-ok($h->proxy_authorization_basic("u2", "p2"), undef);
-ok(j($h->proxy_authorization_basic), "u2|p2");
-ok($h->proxy_authorization, "Basic dTI6cDI=");
-
-ok($h->as_string, <<EOT);
-Authorization: Basic dTpw
-Proxy-Authorization: Basic dTI6cDI=
-Proxy-Authenticate: bar
-WWW-Authenticate: bar
-EOT
-
-
-
-#---- old tests below -----
-
-$h = new HTTP::Headers
- mime_version => "1.0",
- content_type => "text/html";
-$h->header(URI => "http://www.oslonett.no/");
-
-ok($h->header("MIME-Version"), "1.0");
-ok($h->header('Uri'), "http://www.oslonett.no/");
-
-$h->header("MY-header" => "foo",
- "Date" => "somedate",
- "Accept" => ["text/plain", "image/*"],
- );
-$h->push_header("accept" => "audio/basic");
-
-ok($h->header("date"), "somedate");
-
-my @accept = $h->header("accept");
-ok(@accept, 3);
-
-$h->remove_header("uri", "date");
-
-my $str = $h->as_string;
-my $lines = ($str =~ tr/\n/\n/);
-ok($lines, 6);
-
-$h2 = $h->clone;
-
-$h->header("accept", "*/*");
-$h->remove_header("my-header");
-
-@accept = $h2->header("accept");
-ok(@accept, 3);
-
-@accept = $h->header("accept");
-ok(@accept, 1);
-
-# Check order of headers, but first remove this one
-$h2->remove_header('mime_version');
-
-# and add this general header
-$h2->header(Connection => 'close');
-
-my @x = ();
-$h2->scan(sub {push(@x, shift);});
-ok(join(";", @x), "Connection;Accept;Accept;Accept;Content-Type;MY-Header");
-
-# Check headers with embedded newlines:
-$h = HTTP::Headers->new(
- a => "foo\n\n",
- b => "foo\nbar",
- c => "foo\n\nbar\n\n",
- d => "foo\n\tbar",
- e => "foo\n bar ",
- f => "foo\n bar\n baz\nbaz",
- );
-ok($h->as_string("<<\n"), <<EOT);
-A: foo<<
-B: foo<<
- bar<<
-C: foo<<
- bar<<
-D: foo<<
-\tbar<<
-E: foo<<
- bar<<
-F: foo<<
- bar<<
- baz<<
- baz<<
-EOT
-
-# Check for attempt to send a body
-$h = HTTP::Headers->new(
- a => "foo\r\n\r\nevil body" ,
- b => "foo\015\012\015\012evil body" ,
- c => "foo\x0d\x0a\x0d\x0aevil body" ,
-);
-ok (
- $h->as_string(),
- "A: foo\r\n evil body\n".
- "B: foo\015\012 evil body\n" .
- "C: foo\x0d\x0a evil body\n" ,
- "embedded CRLF are stripped out");
-
-# Check with FALSE $HTML::Headers::TRANSLATE_UNDERSCORE
-{
- local($HTTP::Headers::TRANSLATE_UNDERSCORE);
- $HTTP::Headers::TRANSLATE_UNDERSCORE = undef; # avoid -w warning
-
- $h = HTTP::Headers->new;
- $h->header(abc_abc => "foo");
- $h->header("abc-abc" => "bar");
-
- ok($h->header("ABC_ABC"), "foo");
- ok($h->header("ABC-ABC"),"bar");
- ok($h->remove_header("Abc_Abc"));
- ok(!defined($h->header("abc_abc")));
- ok($h->header("ABC-ABC"), "bar");
-}
-
-# Check if objects as header values works
-require URI;
-$h->header(URI => URI->new("http://www.perl.org"));
-
-ok($h->header("URI")->scheme, "http");
-
-$h->clear;
-ok($h->as_string, "");
-
-$h->content_type("text/plain");
-$h->header(content_md5 => "dummy");
-$h->header("Content-Foo" => "foo");
-$h->header(Location => "http:", xyzzy => "plugh!");
-
-ok($h->as_string, <<EOT);
-Location: http:
-Content-MD5: dummy
-Content-Type: text/plain
-Content-Foo: foo
-Xyzzy: plugh!
-EOT
-
-my $c = $h->remove_content_headers;
-ok($h->as_string, <<EOT);
-Location: http:
-Xyzzy: plugh!
-EOT
-
-ok($c->as_string, <<EOT);
-Content-MD5: dummy
-Content-Type: text/plain
-Content-Foo: foo
-EOT
-
-$h = HTTP::Headers->new;
-$h->content_type("text/plain");
-$h->header(":foo_bar", 1);
-$h->push_header(":content_type", "text/html");
-ok(j($h->header_field_names), "Content-Type|:content_type|:foo_bar");
-ok($h->header('Content-Type'), "text/plain");
-ok($h->header(':Content_Type'), undef);
-ok($h->header(':content_type'), "text/html");
-ok($h->as_string, <<EOT);
-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");
+++ /dev/null
-#!perl -w
-
-use strict;
-use Test;
-plan tests => 14;
-
-use HTTP::Config;
-
-sub j { join("|", @_) }
-
-my $conf = HTTP::Config->new;
-ok($conf->empty);
-$conf->add_item(42);
-ok(!$conf->empty);
-ok(j($conf->matching_items("http://www.example.com/foo")), 42);
-ok(j($conf->remove_items), 42);
-ok($conf->matching_items("http://www.example.com/foo"), 0);
-
-$conf = HTTP::Config->new;
-
-$conf->add_item("always");
-$conf->add_item("GET", m_method => ["GET", "HEAD"]);
-$conf->add_item("POST", m_method => "POST");
-$conf->add_item(".com", m_domain => ".com");
-$conf->add_item("secure", m_secure => 1);
-$conf->add_item("not secure", m_secure => 0);
-$conf->add_item("slash", m_host_port => "www.example.com:80", m_path_prefix => "/");
-$conf->add_item("u:p", m_host_port => "www.example.com:80", m_path_prefix => "/foo");
-$conf->add_item("success", m_code => "2xx");
-
-use HTTP::Request;
-my $request = HTTP::Request->new(HEAD => "http://www.example.com/foo/bar");
-$request->header("User-Agent" => "Moz/1.0");
-
-ok(j($conf->matching_items($request)), "u:p|slash|.com|GET|not secure|always");
-
-$request->method("HEAD");
-$request->uri->scheme("https");
-
-ok(j($conf->matching_items($request)), ".com|GET|secure|always");
-
-ok(j($conf->matching_items("http://activestate.com")), ".com|not secure|always");
-
-use HTTP::Response;
-my $response = HTTP::Response->new(200 => "OK");
-$response->content_type("text/plain");
-$response->content("Hello, world!\n");
-$response->request($request);
-
-ok(j($conf->matching_items($response)), ".com|success|GET|secure|always");
-
-$conf->remove_items(m_secure => 1);
-$conf->remove_items(m_domain => ".com");
-ok(j($conf->matching_items($response)), "success|GET|always");
-
-$conf->remove_items; # start fresh
-ok(j($conf->matching_items($response)), "");
-
-$conf->add_item("any", "m_media_type" => "*/*");
-$conf->add_item("text", m_media_type => "text/*");
-$conf->add_item("html", m_media_type => "html");
-$conf->add_item("HTML", m_media_type => "text/html");
-$conf->add_item("xhtml", m_media_type => "xhtml");
-
-ok(j($conf->matching_items($response)), "text|any");
-
-$response->content_type("application/xhtml+xml");
-ok(j($conf->matching_items($response)), "xhtml|html|any");
-
-$response->content_type("text/html");
-ok(j($conf->matching_items($response)), "HTML|html|text|any");
+++ /dev/null
-#!perl -w
-
-use strict;
-use Test;
-
-plan tests => 34;
-#use Data::Dump ();
-
-my $CRLF = "\015\012";
-my $LF = "\012";
-
-{
- package HTTP;
- use vars qw(@ISA);
- require Net::HTTP::Methods;
- @ISA=qw(Net::HTTP::Methods);
-
- my %servers = (
- a => { "/" => "HTTP/1.0 200 OK${CRLF}Content-Type: text/plain${CRLF}Content-Length: 6${CRLF}${CRLF}Hello\n",
- "/bad1" => "HTTP/1.0 200 OK${LF}Server: foo${LF}HTTP/1.0 200 OK${LF}Content-type: text/foo${LF}${LF}abc\n",
- "/09" => "Hello${CRLF}World!${CRLF}",
- "/chunked" => "HTTP/1.1 200 OK${CRLF}Transfer-Encoding: chunked${CRLF}${CRLF}0002; foo=3; bar${CRLF}He${CRLF}1${CRLF}l${CRLF}2${CRLF}lo${CRLF}0000${CRLF}Content-MD5: xxx${CRLF}${CRLF}",
- "/head" => "HTTP/1.1 200 OK${CRLF}Content-Length: 16${CRLF}Content-Type: text/plain${CRLF}${CRLF}",
- "/colon-header" => "HTTP/1.1 200 OK${CRLF}Content-Type: text/plain${CRLF}Content-Length: 6${CRLF}Bad-Header: :foo${CRLF}${CRLF}Hello\n",
- },
- );
-
- sub http_connect {
- my($self, $cnf) = @_;
- my $server = $servers{$cnf->{PeerAddr}} || return undef;
- ${*$self}{server} = $server;
- ${*$self}{read_chunk_size} = $cnf->{ReadChunkSize};
- return $self;
- }
-
- sub print {
- my $self = shift;
- #Data::Dump::dump("PRINT", @_);
- my $in = shift;
- my($method, $uri) = split(' ', $in);
-
- my $out;
- if ($method eq "TRACE") {
- my $len = length($in);
- $out = "HTTP/1.0 200 OK${CRLF}Content-Length: $len${CRLF}" .
- "Content-Type: message/http${CRLF}${CRLF}" .
- $in;
- }
- else {
- $out = ${*$self}{server}{$uri};
- $out = "HTTP/1.0 404 Not found${CRLF}${CRLF}" unless defined $out;
- }
-
- ${*$self}{out} .= $out;
- return 1;
- }
-
- sub sysread {
- my $self = shift;
- #Data::Dump::dump("SYSREAD", @_);
- my $length = $_[1];
- my $offset = $_[2] || 0;
-
- if (my $read_chunk_size = ${*$self}{read_chunk_size}) {
- $length = $read_chunk_size if $read_chunk_size < $length;
- }
-
- my $data = substr(${*$self}{out}, 0, $length, "");
- return 0 unless length($data);
-
- $_[0] = "" unless defined $_[0];
- substr($_[0], $offset) = $data;
- return length($data);
- }
-
- # ----------------
-
- sub request {
- my($self, $method, $uri, $headers, $opt) = @_;
- $headers ||= [];
- $opt ||= {};
-
- my($code, $message, @h);
- my $buf = "";
- eval {
- $self->write_request($method, $uri, @$headers) || die "Can't write request";
- ($code, $message, @h) = $self->read_response_headers(%$opt);
-
- my $tmp;
- my $n;
- while ($n = $self->read_entity_body($tmp, 32)) {
- #Data::Dump::dump($tmp, $n);
- $buf .= $tmp;
- }
-
- push(@h, $self->get_trailers);
-
- };
-
- my %res = ( code => $code,
- message => $message,
- headers => \@h,
- content => $buf,
- );
-
- if ($@) {
- $res{error} = $@;
- }
-
- return \%res;
- }
-}
-
-# Start testing
-my $h;
-my $res;
-
-$h = HTTP->new(Host => "a", KeepAlive => 1) || die;
-$res = $h->request(GET => "/");
-
-#Data::Dump::dump($res);
-
-ok($res->{code}, 200);
-ok($res->{content}, "Hello\n");
-
-$res = $h->request(GET => "/404");
-ok($res->{code}, 404);
-
-$res = $h->request(TRACE => "/foo");
-ok($res->{code}, 200);
-ok($res->{content}, "TRACE /foo HTTP/1.1${CRLF}Keep-Alive: 300${CRLF}Connection: Keep-Alive${CRLF}Host: a${CRLF}${CRLF}");
-
-# try to turn off keep alive
-$h->keep_alive(0);
-$res = $h->request(TRACE => "/foo");
-ok($res->{code}, "200");
-ok($res->{content}, "TRACE /foo HTTP/1.1${CRLF}Connection: close${CRLF}Host: a${CRLF}${CRLF}");
-
-# try a bad one
-$res = $h->request(GET => "/bad1", [], {laxed => 1});
-ok($res->{code}, "200");
-ok($res->{message}, "OK");
-ok("@{$res->{headers}}", "Server foo Content-type text/foo");
-ok($res->{content}, "abc\n");
-
-$res = $h->request(GET => "/bad1");
-ok($res->{error} =~ /Bad header/);
-ok(!$res->{code});
-$h = undef; # it is in a bad state now
-
-$h = HTTP->new("a") || die; # reconnect
-$res = $h->request(GET => "/09", [], {laxed => 1});
-ok($res->{code}, "200");
-ok($res->{message}, "Assumed OK");
-ok($res->{content}, "Hello${CRLF}World!${CRLF}");
-ok($h->peer_http_version, "0.9");
-
-$res = $h->request(GET => "/09");
-ok($res->{error} =~ /^Bad response status line: 'Hello'/);
-$h = undef; # it's in a bad state again
-
-$h = HTTP->new(Host => "a", KeepAlive => 1, ReadChunkSize => 1) || die; # reconnect
-$res = $h->request(GET => "/chunked");
-ok($res->{code}, 200);
-ok($res->{content}, "Hello");
-ok("@{$res->{headers}}", "Transfer-Encoding chunked Content-MD5 xxx");
-
-# once more
-$res = $h->request(GET => "/chunked");
-ok($res->{code}, "200");
-ok($res->{content}, "Hello");
-ok("@{$res->{headers}}", "Transfer-Encoding chunked Content-MD5 xxx");
-
-# test head
-$res = $h->request(HEAD => "/head");
-ok($res->{code}, "200");
-ok($res->{content}, "");
-ok("@{$res->{headers}}", "Content-Length 16 Content-Type text/plain");
-
-$res = $h->request(GET => "/");
-ok($res->{code}, "200");
-ok($res->{content}, "Hello\n");
-
-$h = HTTP->new(Host => undef, PeerAddr => "a", );
-$h->http_version("1.0");
-ok(!defined $h->host);
-$res = $h->request(TRACE => "/");
-ok($res->{code}, "200");
-ok($res->{content}, "TRACE / HTTP/1.0\r\n\r\n");
-
-# check that headers with colons at the start of values don't break
-$res = $h->request(GET => '/colon-header');
-ok("@{$res->{headers}}", "Content-Type text/plain Content-Length 6 Bad-Header :foo");
-
-require Net::HTTP;
-eval {
- $h = Net::HTTP->new;
-};
-print "# $@";
-ok($@);
-
+++ /dev/null
-#!perl -w
-
-use Test;
-plan tests => 10;
-
-use File::Listing;
-
-$dir = <<'EOL';
-total 68
-drwxr-xr-x 4 aas users 1024 Mar 16 15:47 .
-drwxr-xr-x 11 aas users 1024 Mar 15 19:22 ..
-drwxr-xr-x 2 aas users 1024 Mar 16 15:47 CVS
--rw-r--r-- 1 aas users 2384 Feb 26 21:14 Debug.pm
--rw-r--r-- 1 aas users 2145 Feb 26 20:09 IO.pm
--rw-r--r-- 1 aas users 3960 Mar 15 18:05 MediaTypes.pm
--rw-r--r-- 1 aas users 792 Feb 26 20:12 MemberMixin.pm
-drwxr-xr-x 3 aas users 1024 Mar 15 18:05 Protocol
--rw-r--r-- 1 aas users 5613 Feb 26 20:16 Protocol.pm
--rw-r--r-- 1 aas users 5963 Feb 26 21:27 RobotUA.pm
--rw-r--r-- 1 aas users 5071 Mar 16 12:25 Simple.pm
--rw-r--r-- 1 aas users 8817 Mar 15 18:05 Socket.pm
--rw-r--r-- 1 aas users 2121 Feb 5 14:22 TkIO.pm
--rw-r--r-- 1 aas users 19628 Mar 15 18:05 UserAgent.pm
--rw-r--r-- 1 aas users 2841 Feb 5 19:06 media.types
-
-CVS:
-total 5
-drwxr-xr-x 2 aas users 1024 Mar 16 15:47 .
-drwxr-xr-x 4 aas users 1024 Mar 16 15:47 ..
--rw-r--r-- 1 aas users 545 Mar 16 15:47 Entries
--rw-r--r-- 1 aas users 39 Mar 10 09:05 Repository
--rw-r--r-- 1 aas users 19 Mar 10 09:05 Root
-
-Protocol:
-total 37
-drwxr-xr-x 3 aas users 1024 Mar 15 18:05 .
-drwxr-xr-x 4 aas users 1024 Mar 16 15:47 ..
-drwxr-xr-x 2 aas users 1024 Mar 15 18:05 CVS
--rw-r--r-- 1 aas users 4646 Feb 26 20:13 file.pm
--rw-r--r-- 1 aas users 13006 Mar 15 18:05 ftp.pm
--rw-r--r-- 1 aas users 5935 Mar 6 10:29 gopher.pm
--rw-r--r-- 1 aas users 5453 Mar 6 10:29 http.pm
--rw-r--r-- 1 aas users 2365 Feb 26 20:13 mailto.pm
-
-Protocol/CVS:
-total 5
-drwxr-xr-x 2 aas users 1024 Mar 15 18:05 .
-drwxr-xr-x 3 aas users 1024 Mar 15 18:05 ..
--rw-r--r-- 1 aas users 238 Mar 15 18:05 Entries
--rw-r--r-- 1 aas users 48 Mar 10 09:05 Repository
--rw-r--r-- 1 aas users 19 Mar 10 09:05 Root
-EOL
-
-@dir = parse_dir($dir, undef, 'unix');
-
-ok(@dir, 25);
-
-for (@dir) {
- ($name, $type, $size, $mtime, $mode) = @$_;
- $size ||= 0; # ensure that it is defined
- printf "# %-25s $type %6d ", $name, $size;
- print scalar(localtime($mtime));
- printf " %06o", $mode;
- print "\n";
-}
-
-# Pick out the Socket.pm line as the sample we check carefully
-($name, $type, $size, $mtime, $mode) = @{$dir[9]};
-
-ok($name, "Socket.pm");
-ok($type, "f");
-ok($size, 8817);
-
-# Must be careful when checking the time stamps because we don't know
-# which year if this script lives for a long time.
-$timestring = scalar(localtime($mtime));
-ok($timestring =~ /Mar\s+15\s+18:05/);
-
-ok($mode, 0100644);
-
-@dir = parse_dir(<<'EOT');
-drwxr-xr-x 21 root root 704 2007-03-22 21:48 dir
-EOT
-
-ok(@dir, 1);
-ok($dir[0][0], "dir");
-ok($dir[0][1], "d");
-
-$timestring = scalar(localtime($dir[0][3]));
-print "# $timestring\n";
-ok($timestring =~ /^Thu Mar 22 21:48/);
+++ /dev/null
-#!perl -w
-
-use Test;
-
-use LWP::MediaTypes;
-
-require URI::URL;
-
-$url1 = new URI::URL 'http://www/foo/test.gif?search+x#frag';
-$url2 = new URI::URL 'http:test';
-
-my $pwd if $^O eq "MacOS";
-
-unless ($^O eq "MacOS") {
- $file = "/etc/passwd";
- -r $file or $file = "./README";
-}
-else {
- require Mac::Files;
- $pwd = `pwd`;
- chomp($pwd);
- my $dir = Mac::Files::FindFolder(Mac::Files::kOnSystemDisk(),
- Mac::Files::kDesktopFolderType());
- chdir($dir);
- $file = "README";
- open(README,">$file") or die "Unable to open $file";
- print README "This is a dummy file for LWP testing purposes\n";
- close README;
- open(README,">/dev/null") or die "Unable to open /dev/null";
- print README "This is a dummy file for LWP testing purposes\n";
- close README;
-}
-
-@tests =
-(
- ["/this.dir/file.html" => "text/html",],
- ["test.gif.htm" => "text/html",],
- ["test.txt.gz" => "text/plain", "gzip"],
- ["gif.foo" => "application/octet-stream",],
- ["lwp-0.03.tar.Z" => "application/x-tar", "compress"],
- [$file => "text/plain",],
- ["/random/file" => "application/octet-stream",],
- [($^O eq 'VMS'? "nl:" : "/dev/null") => "text/plain",],
- [$url1 => "image/gif",],
- [$url2 => "application/octet-stream",],
- ["x.ppm.Z.UU" => "image/x-portable-pixmap","compress","x-uuencode",],
-);
-
-plan tests => @tests * 3 + 6;
-
-if ($ENV{HOME} and -f "$ENV{HOME}/.mime.types") {
- warn "
-The MediaTypes test might fail because you have a private ~/.mime.types file
-If you get a failed test, try to move it away while testing.
-";
-}
-
-
-for (@tests) {
- ($file, $expectedtype, @expectedEnc) = @$_;
- $type1 = guess_media_type($file);
- ($type, @enc) = guess_media_type($file);
- ok($type1, $type);
- ok($type, $expectedtype);
- ok("@enc", "@expectedEnc");
-}
-
-@imgSuffix = media_suffix('image/*');
-print "# Image suffixes: @imgSuffix\n";
-ok(grep $_ eq "gif", @imgSuffix);
-
-@audioSuffix = media_suffix('AUDIO/*');
-print "# Audio suffixes: @audioSuffix\n";
-ok(grep $_ eq 'oga', @audioSuffix);
-ok(media_suffix('audio/OGG'), 'oga');
-
-require HTTP::Response;
-$r = new HTTP::Response 200, "Document follows";
-$r->title("file.tar.gz.uu");
-guess_media_type($r->title, $r);
-#print $r->as_string;
-
-ok($r->content_type, "application/x-tar");
-
-@enc = $r->header("Content-Encoding");
-ok("@enc", "gzip x-uuencode");
-
-#
-use LWP::MediaTypes qw(add_type add_encoding);
-add_type("x-world/x-vrml", qw(wrl vrml));
-add_encoding("x-gzip" => "gz");
-add_encoding(rot13 => "r13");
-
-@x = guess_media_type("foo.vrml.r13.gz");
-#print "@x\n";
-ok("@x", "x-world/x-vrml rot13 x-gzip");
-
-#print LWP::MediaTypes::_dump();
-
-if($^O eq "MacOS") {
- unlink "README";
- unlink "/dev/null";
- chdir($pwd);
-}
-
+++ /dev/null
-#!perl -w
-
-use strict;
-
-BEGIN {
- eval {
- require Encode;
- Encode::find_encoding("UTF-16-BE") || die "Need a version of Encode that supports UTF-16-BE";
- };
- if ($@) {
- print "1..0 # Skipped: Encode not available\n";
- print $@;
- exit;
- }
-}
-
-use Test;
-plan tests => 36;
-
-use HTTP::Response;
-my $r = HTTP::Response->new(200, "OK");
-ok($r->content_charset, undef);
-ok($r->content_type_charset, undef);
-
-$r->content_type("text/plain");
-ok($r->content_charset, undef);
-
-$r->content("abc");
-ok($r->content_charset, "US-ASCII");
-
-$r->content("f\xE5rep\xF8lse\n");
-ok($r->content_charset, "ISO-8859-1");
-
-$r->content("f\xC3\xA5rep\xC3\xB8lse\n");
-ok($r->content_charset, "UTF-8");
-
-$r->content_type("text/html");
-$r->content(<<'EOT');
-<meta charset="UTF-8">
-EOT
-ok($r->content_charset, "UTF-8");
-
-$r->content(<<'EOT');
-<body>
-<META CharSet="Utf-16-LE">
-<meta charset="ISO-8859-1">
-EOT
-ok($r->content_charset, "UTF-8");
-
-$r->content(<<'EOT');
-<!-- <meta charset="UTF-8">
-EOT
-ok($r->content_charset, "US-ASCII");
-
-$r->content(<<'EOT');
-<meta content="text/plain; charset=UTF-8">
-EOT
-ok($r->content_charset, "UTF-8");
-
-$r->content_type('text/plain; charset="iso-8859-1"');
-ok($r->content_charset, "ISO-8859-1");
-ok($r->content_type_charset, "ISO-8859-1");
-
-$r->content_type("application/xml");
-$r->content("<foo>..</foo>");
-ok($r->content_charset, "UTF-8");
-
-require Encode;
-for my $enc ("UTF-16-BE", "UTF-16-LE", "UTF-32-BE", "UTF-32-LE") {
- $r->content(Encode::encode($enc, "<foo>..</foo>"));
- ok($r->content_charset, $enc);
-}
-
-$r->content(<<'EOT');
-<?xml version="1.0" encoding="utf8" ?>
-EOT
-ok($r->content_charset, "utf8");
-
-$r->content(<<'EOT');
-<?xml version="1.0" encoding=" "?>
-EOT
-ok($r->content_charset, "UTF-8");
-
-$r->content(<<'EOT');
-<?xml version="1.0" encoding=" ISO-8859-1 "?>
-EOT
-ok($r->content_charset, "ISO-8859-1");
-
-$r->content(<<'EOT');
-<?xml version="1.0"
-encoding="US-ASCII" ?>
-EOT
-ok($r->content_charset, "US-ASCII");
-
-{
- sub TIESCALAR{bless[]}
- tie $_, "";
- my $fail = 0;
- sub STORE{ ++$fail }
- sub FETCH{}
- $r->content_charset;
- ok($fail, 0, 'content_charset leaves $_ alone');
-}
-
-$r->remove_content_headers;
-$r->content_type("text/plain; charset=UTF-8");
-$r->content("abc");
-ok($r->decoded_content, "abc");
-
-$r->content("\xc3\xa5");
-ok($r->decoded_content, chr(0xE5));
-ok($r->decoded_content(charset => "none"), "\xC3\xA5");
-ok($r->decoded_content(alt_charset => "UTF-8"), chr(0xE5));
-ok($r->decoded_content(alt_charset => "none"), chr(0xE5));
-
-$r->content_type("text/plain; charset=UTF");
-ok($r->decoded_content, undef);
-ok($r->decoded_content(charset => "UTF-8"), chr(0xE5));
-ok($r->decoded_content(charset => "none"), "\xC3\xA5");
-ok($r->decoded_content(alt_charset => "UTF-8"), chr(0xE5));
-ok($r->decoded_content(alt_charset => "none"), "\xC3\xA5");
-
-$r->content_type("text/plain");
-ok($r->decoded_content, chr(0xE5));
-ok($r->decoded_content(charset => "none"), "\xC3\xA5");
-ok($r->decoded_content(default_charset => "ISO-8859-1"), "\xC3\xA5");
-ok($r->decoded_content(default_charset => "latin1"), "\xC3\xA5");
+++ /dev/null
-#!perl -w
-
-# This is the old message.t test. It is not maintained any more,
-# but kept around in case it happens to catch any mistakes. Please
-# add new tests to message.t instead.
-
-use strict;
-use Test qw(plan ok);
-
-plan tests => 20;
-
-require HTTP::Request;
-require HTTP::Response;
-
-require Time::Local if $^O eq "MacOS";
-my $offset = ($^O eq "MacOS") ? Time::Local::timegm(0,0,0,1,0,70) : 0;
-
-my $req = HTTP::Request->new(GET => "http://www.sn.no/");
-$req->header(
- "if-modified-since" => "Thu, 03 Feb 1994 00:00:00 GMT",
- "mime-version" => "1.0");
-
-ok($req->as_string =~ /^GET/m);
-ok($req->header("MIME-Version"), "1.0");
-ok($req->if_modified_since, ((760233600 + $offset) || 0));
-
-$req->content("gisle");
-$req->add_content(" aas");
-$req->add_content(\ " old interface is depreciated");
-${$req->content_ref} =~ s/\s+is\s+depreciated//;
-
-ok($req->content, "gisle aas old interface");
-
-my $time = time;
-$req->date($time);
-my $timestr = gmtime($time);
-my($month) = ($timestr =~ /^\S+\s+(\S+)/); # extract month;
-#print "These should represent the same time:\n\t", $req->header('Date'), "\n\t$timestr\n";
-ok($req->header('Date') =~ /\Q$month/);
-
-$req->authorization_basic("gisle", "passwd");
-ok($req->header("Authorization"), "Basic Z2lzbGU6cGFzc3dk");
-
-my($user, $pass) = $req->authorization_basic;
-ok($user, "gisle");
-ok($pass, "passwd");
-
-# Check the response
-my $res = HTTP::Response->new(200, "This message");
-ok($res->is_success);
-
-my $html = $res->error_as_HTML;
-ok($html =~ /<head>/i && $html =~ /This message/);
-
-$res->content_type("text/html;version=3.0");
-$res->content("<html>...</html>\n");
-
-my $res2 = $res->clone;
-ok($res2->code, 200);
-ok($res2->header("cOntent-TYPE"), "text/html;version=3.0");
-ok($res2->content =~ />\.\.\.</);
-
-# Check the base method:
-$res = HTTP::Response->new(200, "This message");
-ok($res->base, undef);
-$res->request($req);
-$res->content_type("image/gif");
-
-ok($res->base, "http://www.sn.no/");
-$res->header('Base', 'http://www.sn.no/xxx/');
-ok($res->base, "http://www.sn.no/xxx/");
-
-# Check the AUTLOAD delegate method with regular expressions
-"This string contains text/html" =~ /(\w+\/\w+)/;
-$res->content_type($1);
-ok($res->content_type, "text/html");
-
-# Check what happens when passed a new URI object
-require URI;
-$req = HTTP::Request->new(GET => URI->new("http://localhost"));
-ok($req->uri, "http://localhost");
-
-$req = HTTP::Request->new(GET => "http://www.example.com",
- [ Foo => 1, bar => 2 ], "FooBar\n");
-ok($req->as_string, <<EOT);
-GET http://www.example.com
-Bar: 2
-Foo: 1
-
-FooBar
-EOT
-
-$req->clear;
-ok($req->as_string, <<EOT);
-GET http://www.example.com
-
-EOT
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use Test qw(plan ok);
-plan tests => 39;
-
-use HTTP::Message;
-use HTTP::Request::Common qw(POST);
-
-my $m = HTTP::Message->new;
-
-ok(ref($m->headers), "HTTP::Headers");
-ok($m->headers_as_string, "");
-ok($m->content, "");
-ok(j($m->parts), "");
-ok($m->as_string, "\n");
-
-my $m_clone = $m->clone;
-$m->push_header("Foo", 1);
-$m->add_content("foo");
-
-ok($m_clone->as_string, "\n");
-ok($m->headers_as_string, "Foo: 1\n");
-ok($m->header("Foo"), 1);
-ok($m->as_string, "Foo: 1\n\nfoo\n");
-ok($m->as_string("\r\n"), "Foo: 1\r\n\r\nfoo");
-ok(j($m->parts), "");
-
-$m->content_type("message/foo");
-$m->content(<<EOT);
-H1: 1
-H2: 2
- 3
-H3: abc
-
-FooBar
-EOT
-
-my @parts = $m->parts;
-ok(@parts, 1);
-my $m2 = $parts[0];
-ok(ref($m2), "HTTP::Message");
-
-ok($m2->header("h1"), 1);
-ok($m2->header("h2"), "2\n 3");
-ok($m2->header("h3"), " abc");
-ok($m2->content, "FooBar\n");
-ok($m2->as_string, $m->content);
-ok(j($m2->parts), "");
-
-$m = POST("http://www.example.com",
- Content_Type => 'form-data',
- Content => [ foo => 1, bar => 2 ]);
-ok($m->content_type, "multipart/form-data");
-@parts = $m->parts;
-ok(@parts, 2);
-ok($parts[0]->header("Content-Disposition"), 'form-data; name="foo"');
-ok($parts[0]->content, 1);
-ok($parts[1]->header("Content-Disposition"), 'form-data; name="bar"');
-ok($parts[1]->content, 2);
-
-$m = HTTP::Message->new;
-$m->content_type("message/http");
-$m->content(<<EOT);
-GET / HTTP/1.0
-Host: example.com
-
-How is this?
-EOT
-
-@parts = $m->parts;
-ok(@parts, 1);
-ok($parts[0]->method, "GET");
-ok($parts[0]->uri, "/");
-ok($parts[0]->protocol, "HTTP/1.0");
-ok($parts[0]->header("Host"), "example.com");
-ok($parts[0]->content, "How is this?\n");
-
-$m = HTTP::Message->new;
-$m->content_type("message/http");
-$m->content(<<EOT);
-HTTP/1.1 200 OK
-Content-Type : text/html
-
-<H1>Hello world!</H1>
-EOT
-
-@parts = $m->parts;
-ok(@parts, 1);
-ok($parts[0]->code, 200);
-ok($parts[0]->message, "OK");
-ok($parts[0]->protocol, "HTTP/1.1");
-ok($parts[0]->content_type, "text/html");
-ok($parts[0]->content, "<H1>Hello world!</H1>\n");
-
-$m->parts(HTTP::Request->new("GET", "http://www.example.com"));
-ok($m->as_string, "Content-Type: message/http\n\nGET http://www.example.com\r\n\r\n");
-
-$m = HTTP::Request->new("PUT", "http://www.example.com");
-$m->parts(HTTP::Message->new([Foo => 1], "abc\n"));
-ok($m->as_string, <<EOT);
-PUT http://www.example.com
-Content-Type: multipart/mixed; boundary=xYzZY
-
---xYzZY\r
-Foo: 1\r
-\r
-abc
-\r
---xYzZY--\r
-EOT
-
-sub j { join(":", @_) }
+++ /dev/null
-#!perl -w
-
-use strict;
-use Test qw(plan ok skip);
-
-plan tests => 125;
-
-require HTTP::Message;
-use Config qw(%Config);
-
-my($m, $m2, @parts);
-
-$m = HTTP::Message->new;
-ok($m);
-ok(ref($m), "HTTP::Message");
-ok(ref($m->headers), "HTTP::Headers");
-ok($m->as_string, "\n");
-ok($m->headers->as_string, "");
-ok($m->headers_as_string, "");
-ok($m->content, "");
-
-$m->header("Foo", 1);
-ok($m->as_string, "Foo: 1\n\n");
-
-$m2 = HTTP::Message->new($m->headers);
-$m2->header(bar => 2);
-ok($m->as_string, "Foo: 1\n\n");
-ok($m2->as_string, "Bar: 2\nFoo: 1\n\n");
-ok($m2->dump, "Bar: 2\nFoo: 1\n\n(no content)\n");
-
-$m2 = HTTP::Message->new($m->headers, "foo");
-ok($m2->as_string, "Foo: 1\n\nfoo\n");
-ok($m2->as_string("<<\n"), "Foo: 1<<\n<<\nfoo");
-$m2 = HTTP::Message->new($m->headers, "foo\n");
-ok($m2->as_string, "Foo: 1\n\nfoo\n");
-
-$m = HTTP::Message->new([a => 1, b => 2], "abc");
-ok($m->as_string, "A: 1\nB: 2\n\nabc\n");
-
-$m = HTTP::Message->parse("");
-ok($m->as_string, "\n");
-$m = HTTP::Message->parse("\n");
-ok($m->as_string, "\n");
-$m = HTTP::Message->parse("\n\n");
-ok($m->as_string, "\n\n");
-ok($m->content, "\n");
-
-$m = HTTP::Message->parse("foo");
-ok($m->as_string, "\nfoo\n");
-$m = HTTP::Message->parse("foo: 1");
-ok($m->as_string, "Foo: 1\n\n");
-$m = HTTP::Message->parse("foo_bar: 1");
-ok($m->as_string, "Foo_bar: 1\n\n");
-$m = HTTP::Message->parse("foo: 1\n\nfoo");
-ok($m->as_string, "Foo: 1\n\nfoo\n");
-$m = HTTP::Message->parse(<<EOT);
-FOO : 1
- 2
- 3
- 4
-bar:
- 1
-Baz: 1
-
-foobarbaz
-EOT
-ok($m->as_string, <<EOT);
-Bar:
- 1
-Baz: 1
-Foo: 1
- 2
- 3
- 4
-
-foobarbaz
-EOT
-
-$m = HTTP::Message->parse(<<EOT);
-Date: Fri, 18 Feb 2005 18:33:46 GMT
-Connection: close
-Content-Type: text/plain
-
-foo:bar
-second line
-EOT
-ok($m->content(""), <<EOT);
-foo:bar
-second line
-EOT
-ok($m->as_string, <<EOT);
-Connection: close
-Date: Fri, 18 Feb 2005 18:33:46 GMT
-Content-Type: text/plain
-
-EOT
-
-$m = HTTP::Message->parse(" abc\nfoo: 1\n");
-ok($m->as_string, "\n abc\nfoo: 1\n");
-$m = HTTP::Message->parse(" foo : 1\n");
-ok($m->as_string, "\n foo : 1\n");
-$m = HTTP::Message->parse("\nfoo: bar\n");
-ok($m->as_string, "\nfoo: bar\n");
-
-$m = HTTP::Message->new([a => 1, b => 2], "abc");
-ok($m->content("foo\n"), "abc");
-ok($m->content, "foo\n");
-
-$m->add_content("bar");
-ok($m->content, "foo\nbar");
-$m->add_content(\"\n");
-ok($m->content, "foo\nbar\n");
-
-ok(ref($m->content_ref), "SCALAR");
-ok(${$m->content_ref}, "foo\nbar\n");
-${$m->content_ref} =~ s/[ao]/i/g;
-ok($m->content, "fii\nbir\n");
-
-$m->clear;
-ok($m->headers->header_field_names, 0);
-ok($m->content, "");
-
-ok($m->parts, undef);
-$m->parts(HTTP::Message->new,
- HTTP::Message->new([a => 1], "foo"),
- HTTP::Message->new(undef, "bar\n"),
- );
-ok($m->parts->as_string, "\n");
-
-my $str = $m->as_string;
-$str =~ s/\r/<CR>/g;
-ok($str, <<EOT);
-Content-Type: multipart/mixed; boundary=xYzZY
-
---xYzZY<CR>
-<CR>
-<CR>
---xYzZY<CR>
-A: 1<CR>
-<CR>
-foo<CR>
---xYzZY<CR>
-<CR>
-bar
-<CR>
---xYzZY--<CR>
-EOT
-
-$m2 = HTTP::Message->new;
-$m2->parts($m);
-
-$str = $m2->as_string;
-$str =~ s/\r/<CR>/g;
-ok($str =~ /boundary=(\S+)/);
-
-
-ok($str, <<EOT);
-Content-Type: multipart/mixed; boundary=$1
-
---$1<CR>
-Content-Type: multipart/mixed; boundary=xYzZY<CR>
-<CR>
---xYzZY<CR>
-<CR>
-<CR>
---xYzZY<CR>
-A: 1<CR>
-<CR>
-foo<CR>
---xYzZY<CR>
-<CR>
-bar
-<CR>
---xYzZY--<CR>
-<CR>
---$1--<CR>
-EOT
-
-@parts = $m2->parts;
-ok(@parts, 1);
-
-@parts = $parts[0]->parts;
-ok(@parts, 3);
-ok($parts[1]->header("A"), 1);
-
-$m2->parts([HTTP::Message->new]);
-@parts = $m2->parts;
-ok(@parts, 1);
-
-$m2->parts([]);
-@parts = $m2->parts;
-ok(@parts, 0);
-
-$m->clear;
-$m2->clear;
-
-$m = HTTP::Message->new([content_type => "message/http; boundary=aaa",
- ],
- <<EOT);
-GET / HTTP/1.1
-Host: www.example.com:8008
-
-EOT
-
-@parts = $m->parts;
-ok(@parts, 1);
-$m2 = $parts[0];
-ok(ref($m2), "HTTP::Request");
-ok($m2->method, "GET");
-ok($m2->uri, "/");
-ok($m2->protocol, "HTTP/1.1");
-ok($m2->header("Host"), "www.example.com:8008");
-ok($m2->content, "");
-
-$m->content(<<EOT);
-HTTP/1.0 200 OK
-Content-Type: text/plain
-
-Hello
-EOT
-
-$m2 = $m->parts;
-ok(ref($m2), "HTTP::Response");
-ok($m2->protocol, "HTTP/1.0");
-ok($m2->code, "200");
-ok($m2->message, "OK");
-ok($m2->content_type, "text/plain");
-ok($m2->content, "Hello\n");
-
-eval { $m->parts(HTTP::Message->new, HTTP::Message->new) };
-ok($@);
-
-$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>
-Content-Type: message/http; boundary=aaa<CR>
-<CR>
-HTTP/1.0 200 OK
-Content-Type: text/plain
-
-Hello
-<CR>
---xYzZY<CR>
-A: 1<CR>
-A: 2<CR>
-A: 3<CR>
-<CR>
-a<CR>
---xYzZY--<CR>
-EOT
-
-$m->add_part(HTTP::Message->new([b=>[1..3]], "b"));
-
-$str = $m->as_string;
-$str =~ s/\r/<CR>/g;
-ok($str, <<EOT);
-Content-Type: multipart/mixed; boundary=xYzZY
-
---xYzZY<CR>
-Content-Type: message/http; boundary=aaa<CR>
-<CR>
-HTTP/1.0 200 OK
-Content-Type: text/plain
-
-Hello
-<CR>
---xYzZY<CR>
-A: 1<CR>
-A: 2<CR>
-A: 3<CR>
-<CR>
-a<CR>
---xYzZY<CR>
-B: 1<CR>
-B: 2<CR>
-B: 3<CR>
-<CR>
-b<CR>
---xYzZY--<CR>
-EOT
-
-$m = HTTP::Message->new;
-$m->add_part(HTTP::Message->new([a=>[1..3]], "a"));
-ok($m->header("Content-Type"), "multipart/mixed; boundary=xYzZY");
-$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";
-ok($m->content, "foo");
-$m->add_content("bar");
-ok($foo, "foobar");
-ok($m->as_string, "\nfoobar\n");
-$m->content_type("message/foo");
-$m->parts(HTTP::Message->new(["h", "v"], "C"));
-ok($foo, "H: v\r\n\r\nC");
-$foo =~ s/C/c/;
-$m2 = $m->parts;
-ok($m2->content, "c");
-
-$m = HTTP::Message->new;
-$foo = [];
-$m->content($foo);
-ok($m->content, $foo);
-ok(${$m->content_ref}, $foo);
-ok(${$m->content_ref([])}, $foo);
-ok($m->content_ref != $foo);
-eval {$m->add_content("x")};
-ok($@ && $@ =~ /^Can't append to ARRAY content/);
-
-$foo = sub { "foo" };
-$m->content($foo);
-ok($m->content, $foo);
-ok(${$m->content_ref}, $foo);
-
-$m->content_ref($foo);
-ok($m->content, $foo);
-ok($m->content_ref, $foo);
-
-eval {$m->content_ref("foo")};
-ok($@ && $@ =~ /^Setting content_ref to a non-ref/);
-
-$m->content_ref(\"foo");
-eval {$m->content("bar")};
-ok($@ && $@ =~ /^Modification of a read-only value/);
-
-$foo = "foo";
-$m->content_ref(\$foo);
-ok($m->content("bar"), "foo");
-ok($foo, "bar");
-ok($m->content, "bar");
-ok($m->content_ref, \$foo);
-
-$m = HTTP::Message->new;
-$m->content("fo=6F");
-ok($m->decoded_content, "fo=6F");
-$m->header("Content-Encoding", "quoted-printable");
-ok($m->decoded_content, "foo");
-
-$m = HTTP::Message->new;
-$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($NO_ENCODE, sub { eval { $m->decoded_content } }, "\x{FEFF}Hi there \x{263A}\n");
-ok($@ || "", "");
-ok($m->content, "H4sICFWAq0ECA3h4eAB7v3u/R6ZCSUZqUarCoxm7uAAZKHXiEAAAAA==\n");
-
-$m2 = $m->clone;
-ok($m2->decode);
-ok($m2->header("Content-Encoding"), undef);
-ok($m2->content, qr/Hi there/);
-
-ok(grep { $_ eq "gzip" } $m->decodable);
-
-my $tmp = MIME::Base64::decode($m->content);
-$m->content($tmp);
-$m->header("Content-Encoding", "gzip");
-$@ = "";
-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");
-
-my $BAD_ENCODE = $NO_ENCODE || !(eval { require Encode; defined(Encode::decode("UTF-8", "\xff")) });
-
-skip($BAD_ENCODE, sub { $m->decoded_content }, "a\x{FFFD}");
-skip($BAD_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'/);
-
-my $err = 0;
-eval {
- $m->decoded_content(raise_error => 1);
- $err++;
-};
-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;
-}
-
-$m = HTTP::Message->new([
- "Content-Type", "text/plain",
- ],
- "Hello world!"
-);
-$m->content_length(length $m->content);
-$m->encode("deflate");
-$m->dump(prefix => "# ");
-ok($m->dump(prefix => "| "), <<'EOT');
-| Content-Encoding: deflate
-| Content-Type: text/plain
-|
-| x\x9C\xF3H\xCD\xC9\xC9W(\xCF/\xCAIQ\4\0\35\t\4^
-EOT
-$m->encode("base64", "identity");
-ok($m->as_string, <<'EOT');
-Content-Encoding: deflate, base64, identity
-Content-Type: text/plain
-
-eJzzSM3JyVcozy/KSVEEAB0JBF4=
-EOT
-if (eval { require Encode; 1 }) {
- ok($m->decoded_content, "Hello world!");
-} else {
- skip('Needs Encode.pm for this test', undef);
-}
-
-# Raw RFC 1951 deflate
-$m = HTTP::Message->new([
- "Content-Type" => "text/plain",
- "Content-Encoding" => "deflate, base64",
- ],
- "80jNyclXCM8vyklRBAA="
- );
-ok($m->decoded_content, "Hello World!");
-ok(!$m->header("Client-Warning"));
-
-
-if (eval "require IO::Uncompress::Bunzip2") {
- $m = HTTP::Message->new([
- "Content-Type" => "text/plain",
- "Content-Encoding" => "x-bzip2, base64",
- ],
- "QlpoOTFBWSZTWcvLx0QAAAHVgAAQYAAAQAYEkIAgADEAMCBoYlnQeSEMvxdyRThQkMvLx0Q=\n"
- );
- ok($m->decoded_content, "Hello world!\n");
- ok($m->decode);
- ok($m->content, "Hello world!\n");
-
- if (eval "require IO::Compress::Bzip2") {
- $m = HTTP::Message->new([
- "Content-Type" => "text/plain",
- ],
- "Hello world!"
- );
- ok($m->encode("x-bzip2"));
- ok($m->header("Content-Encoding"), "x-bzip2");
- ok($m->content =~ /^BZh.*\0/);
- ok($m->decoded_content, "Hello world!");
- ok($m->decode);
- ok($m->content, "Hello world!");
- }
- else {
- skip("Need IO::Compress::Bzip2", undef) for 1..6;
- }
-}
-else {
- skip("Need IO::Uncompress::Bunzip2", undef) for 1..9;
-}
-
-# test decoding of XML content
-if ($] >= 5.008001) {
- $m = HTTP::Message->new(["Content-Type", "application/xml"], "\xFF\xFE<\0?\0x\0m\0l\0 \0v\0e\0r\0s\0i\0o\0n\0=\0\"\x001\0.\x000\0\"\0 \0e\0n\0c\0o\0d\0i\0n\0g\0=\0\"\0U\0T\0F\0-\x001\x006\0l\0e\0\"\0?\0>\0\n\0<\0r\0o\0o\0t\0>\0\xC9\0r\0i\0c\0<\0/\0r\0o\0o\0t\0>\0\n\0");
- ok($m->decoded_content, "<?xml version=\"1.0\"?>\n<root>\xC9ric</root>\n");
-}
-else {
- skip("Need perl-5.8", undef) for 1..1;
-}
+++ /dev/null
-#!perl -w
-
-use Test;
-plan tests => 5;
-
-use HTTP::Request;
-use HTTP::Negotiate;
-
-
- # ID QS Content-Type Encoding Char-Set Lang Size
- $variants =
- [
- ['var1', 0.950, 'text/plain', ['uuencode',
- 'compress'], 'iso-8859-2', 'se', 400],
- ['var2', 1.000, 'text/html;version=2.0', 'gzip', 'iso-8859-1', 'en', 3000],
- ['var3', 0.333, 'image/gif', undef, undef, undef, 43555],
- ];
-
-
-# First we try a request with not accept headers
-$request = new HTTP::Request 'GET', 'http://localhost/';
-@a = choose($variants, $request);
-show_res(@a);
-expect(\@a, [['var2' => 1],
- ['var1' => 0.95],
- ['var3' => 0.333]
- ]
-);
-
-
-$a = choose($variants, $request);
-print "The chosen one is '$a'\n";
-ok($a, "var2");
-
-#------------------
-
-$request = new HTTP::Request 'GET', 'http://localhost/';
-$request->header('Accept', 'text/plain; q=0.55, image/gif; mbx=10000');
-$request->push_header('Accept', 'text/*; q=0.25');
-$request->header('Accept-Language', 'no, en');
-$request->header('Accept-Charset', 'iso-8859-1');
-$request->header('Accept-Encoding', 'gzip');
-
-@a = choose($variants, $request);
-show_res(@a);
-expect(\@a, [['var2' => 0.25],
- ['var1' => 0],
- ['var3' => 0]
- ]
-);
-
-$variants = [
- ['var-en', undef, 'text/html', undef, undef, 'en', undef],
- ['var-de', undef, 'text/html', undef, undef, 'de', undef],
- ['var-ES', undef, 'text/html', undef, undef, 'ES', undef],
- ['provoke-warning', undef, undef, undef, undef, 'x-no-content-type', undef],
- ];
-
-$HTTP::Negotiate::DEBUG=1;
-$ENV{HTTP_ACCEPT_LANGUAGE}='DE,en,fr;Q=0.5,es;q=0.1';
-
-$a = choose($variants);
-
-ok($a, 'var-de');
-
-
-$variants = [
- [ 'Canadian English' => 1.0, 'text/html', undef, undef, 'en-CA', undef ],
- [ 'Generic English' => 1.0, 'text/html', undef, undef, 'en', undef ],
- [ 'Non-Specific' => 1.0, 'text/html', undef, undef, undef, undef ],
-];
-
-$ENV{HTTP_ACCEPT_LANGUAGE}='en-US';
-$a = choose($variants);
-ok($a, 'Generic English');
-
-#------------------
-
-sub expect
-{
- my($res, $exp) = @_;
- do {
- $a = shift @$res;
- $b = shift @$exp;
- last if defined($a) ne defined($b);
- if (defined($a)) {
- ($va, $qa) = @$a;
- ($vb, $qb) = @$b;
- if ($va ne $vb) {
- print "$va == $vb ?\n";
- ok(0);
- return;
- }
- if (abs($qa - $qb) > 0.002) {
- print "$qa ~= $qb ?\n";
- ok(0);
- return;
- }
- }
-
- } until (!defined($a) || !defined($b));
- ok(defined($a), defined($b));
-}
-
-sub show_res
-{
- print "-------------\n";
- for (@_) {
- printf "%-6s %.3f\n", @$_;
- }
- print "-------------\n";
-}
+++ /dev/null
-# Test extra HTTP::Request methods. Basic operation is tested in the
-# message.t test suite.
-
-use strict;
-
-use Test;
-plan tests => 11;
-
-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 IO::Uncompress::Gunzip is there
-
-$req->dump(prefix => "# ");
-
-ok($req->method("DELETE"), "GET");
-ok($req->method, "DELETE");
-
-ok($req->uri("http:"), "http://www.example.com");
-ok($req->uri, "http:");
-
-$req->protocol("HTTP/1.1");
-
-my $r2 = HTTP::Request->parse($req->as_string);
-ok($r2->method, "DELETE");
-ok($r2->uri, "http:");
-ok($r2->protocol, "HTTP/1.1");
-ok($r2->header("Accept-Encoding"), $req->header("Accept-Encoding"));
+++ /dev/null
-#!perl -w
-
-# Test extra HTTP::Response methods. Basic operation is tested in the
-# message.t test suite.
-
-use strict;
-use Test;
-plan tests => 23;
-
-use HTTP::Date;
-use HTTP::Request;
-use HTTP::Response;
-
-my $time = time;
-
-my $req = HTTP::Request->new(GET => 'http://www.sn.no');
-$req->date($time - 30);
-
-my $r = new HTTP::Response 200, "OK";
-$r->client_date($time - 20);
-$r->date($time - 25);
-$r->last_modified($time - 5000000);
-$r->request($req);
-
-#print $r->as_string;
-
-my $current_age = $r->current_age;
-
-ok($current_age >= 35 && $current_age <= 40);
-
-my $freshness_lifetime = $r->freshness_lifetime;
-ok($freshness_lifetime >= 12 * 3600);
-ok($r->freshness_lifetime(heuristic_expiry => 0), undef);
-
-my $is_fresh = $r->is_fresh;
-ok($is_fresh);
-ok($r->is_fresh(heuristic_expiry => 0), undef);
-
-print "# current_age = $current_age\n";
-print "# freshness_lifetime = $freshness_lifetime\n";
-print "# response is ";
-print " not " unless $is_fresh;
-print "fresh\n";
-
-print "# it will be fresh for ";
-print $freshness_lifetime - $current_age;
-print " more seconds\n";
-
-# OK, now we add an Expires header
-$r->expires($time);
-print "\n", $r->dump(prefix => "# ");
-
-$freshness_lifetime = $r->freshness_lifetime;
-ok($freshness_lifetime, 25);
-$r->remove_header('expires');
-
-# Now we try the 'Age' header and the Cache-Contol:
-$r->header('Age', 300);
-$r->push_header('Cache-Control', 'junk');
-$r->push_header(Cache_Control => 'max-age = 10');
-
-#print $r->as_string;
-
-$current_age = $r->current_age;
-$freshness_lifetime = $r->freshness_lifetime;
-
-print "# current_age = $current_age\n";
-print "# freshness_lifetime = $freshness_lifetime\n";
-
-ok($current_age >= 300);
-ok($freshness_lifetime, 10);
-
-ok($r->fresh_until); # should return something
-ok($r->fresh_until(heuristic_expiry => 0)); # should return something
-
-my $r2 = HTTP::Response->parse($r->as_string);
-my @h = $r2->header('Cache-Control');
-ok(@h, 2);
-
-$r->remove_header("Cache-Control");
-
-ok($r->fresh_until); # should still return something
-ok($r->fresh_until(heuristic_expiry => 0), undef);
-
-ok($r->redirects, 0);
-$r->previous($r2);
-ok($r->previous, $r2);
-ok($r->redirects, 1);
-
-$r2->previous($r->clone);
-ok($r->redirects, 2);
-for ($r->redirects) {
- ok($_->is_success);
-}
-
-ok($r->base, $r->request->uri);
-$r->push_header("Content-Location", "/1/A/a");
-ok($r->base, "http://www.sn.no/1/A/a");
-$r->push_header("Content-Base", "/2/;a=/foo/bar");
-ok($r->base, "http://www.sn.no/2/;a=/foo/bar");
-$r->push_header("Content-Base", "/3/");
-ok($r->base, "http://www.sn.no/2/;a=/foo/bar");
+++ /dev/null
-#!perl -w
-
-use Test;
-plan tests => 8;
-
-use HTTP::Status;
-
-ok(RC_OK, 200);
-
-ok(is_info(RC_CONTINUE));
-ok(is_success(RC_ACCEPTED));
-ok(is_error(RC_BAD_REQUEST));
-ok(is_redirect(RC_MOVED_PERMANENTLY));
-
-ok(!is_success(RC_NOT_FOUND));
-
-ok(status_message(0), undef);
-ok(status_message(200), "OK");
+++ /dev/null
-#!perl -w
-
-use Test;
-plan tests => 8;
-
-use HTTP::Status qw(:constants :is status_message);
-
-ok(HTTP_OK, 200);
-
-ok(is_info(HTTP_CONTINUE));
-ok(is_success(HTTP_ACCEPTED));
-ok(is_error(HTTP_BAD_REQUEST));
-ok(is_redirect(HTTP_MOVED_PERMANENTLY));
-
-ok(!is_success(HTTP_NOT_FOUND));
-
-ok(status_message(0), undef);
-ok(status_message(200), "OK");
use strict;
use Test;
-plan tests => 14;
+plan tests => 35;
use LWP::UserAgent;
+# Prevent environment from interfering with test:
+delete $ENV{PERL_LWP_SSL_VERIFY_HOSTNAME};
+delete $ENV{HTTPS_CA_FILE};
+delete $ENV{HTTPS_CA_DIR};
+delete $ENV{PERL_LWP_SSL_CA_FILE};
+delete $ENV{PERL_LWP_SSL_CA_PATH};
+delete $ENV{PERL_LWP_ENV_PROXY};
+
my $ua = LWP::UserAgent->new;
my $clone = $ua->clone;
my $res = $ua->get("data:text/html,%3Chtml%3E%3Chead%3E%3Cmeta%20http-equiv%3D%22Content-Script-Type%22%20content%3D%22text%2Fjavascript%22%3E%3Cmeta%20http-equiv%3D%22Content-Style-Type%22%20content%3D%22text%2Fcss%22%3E%3C%2Fhead%3E%3C%2Fhtml%3E");
ok($res->header("Content-Style-Type", "text/css"));
ok($res->header("Content-Script-Type", "text/javascript"));
+
+ok(join(":", $ua->ssl_opts), "verify_hostname");
+ok($ua->ssl_opts("verify_hostname"), 1);
+ok($ua->ssl_opts(verify_hostname => 0), 1);
+ok($ua->ssl_opts("verify_hostname"), 0);
+ok($ua->ssl_opts(verify_hostname => undef), 0);
+ok($ua->ssl_opts("verify_hostname"), undef);
+ok(join(":", $ua->ssl_opts), "");
+
+$ua = LWP::UserAgent->new(ssl_opts => {});
+ok($ua->ssl_opts("verify_hostname"), 1);
+
+$ua = LWP::UserAgent->new(ssl_opts => { verify_hostname => 0 });
+ok($ua->ssl_opts("verify_hostname"), 0);
+
+$ua = LWP::UserAgent->new(ssl_opts => { SSL_ca_file => 'cert.dat'});
+ok($ua->ssl_opts("verify_hostname"), 1);
+ok($ua->ssl_opts("SSL_ca_file"), 'cert.dat');
+
+$ENV{PERL_LWP_SSL_VERIFY_HOSTNAME} = 1;
+$ua = LWP::UserAgent->new();
+ok($ua->ssl_opts("verify_hostname"), 1);
+
+$ua = LWP::UserAgent->new(ssl_opts => {});
+ok($ua->ssl_opts("verify_hostname"), 1);
+
+$ua = LWP::UserAgent->new(ssl_opts => { verify_hostname => 0 });
+ok($ua->ssl_opts("verify_hostname"), 0);
+
+$ENV{PERL_LWP_SSL_VERIFY_HOSTNAME} = 0;
+$ua = LWP::UserAgent->new();
+ok($ua->ssl_opts("verify_hostname"), 0);
+
+$ua = LWP::UserAgent->new(ssl_opts => {});
+ok($ua->ssl_opts("verify_hostname"), 0);
+
+$ua = LWP::UserAgent->new(ssl_opts => { verify_hostname => 1 });
+ok($ua->ssl_opts("verify_hostname"), 1);
+
+delete @ENV{grep /_proxy$/i, keys %ENV}; # clean out any proxy vars
+
+$ENV{http_proxy} = "http://example.com";
+$ua = LWP::UserAgent->new;
+ok($ua->proxy('http'), undef);
+$ua = LWP::UserAgent->new(env_proxy => 1);;
+ok($ua->proxy('http'), "http://example.com");
+
+$ENV{PERL_LWP_ENV_PROXY} = 1;
+$ua = LWP::UserAgent->new();
+ok($ua->proxy('http'), "http://example.com");
+$ua = LWP::UserAgent->new(env_proxy => 0);
+ok($ua->proxy('http'), undef);
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-use lib '.';
-use Test::More tests => 12;
-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" );
-}
-
-{
- is( $input->{maxlength}, 8, 'got maxlength: 8' );
-
- set_value( $input, '1234' );
- set_value( $input, '1234567890' );
- ok(!$input->strict, "not strict by default");
- $form->strict(1);
- ok($input->strict, "input strict change when form strict change");
- set_value( $input, '1234' );
- eval {
- set_value( $input, '1234567890' );
- };
- like($@, qr/^Input 'passwd' has maxlength '8' at /, "Exception raised");
-}
-
-__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>
-
+++ /dev/null
-#!/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 content_charset {
- return "iso-8859-1";
-}
-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;
-}
+++ /dev/null
-#!perl -w
-
-use strict;
-use Test qw(plan ok);
-
-plan tests => 22;
-
-use HTML::Form;
-
-my $form = HTML::Form->parse(<<"EOT", base => "http://example.com", strict => 1);
-<form>
-<input type="hidden" name="hidden_1">
-
-<input type="checkbox" name="checkbox_1" value="c1_v1" CHECKED>
-<input type="checkbox" name="checkbox_1" value="c1_v2" CHECKED>
-<input type="checkbox" name="checkbox_2" value="c2_v1" CHECKED>
-
-<select name="multi_select_field" multiple="1">
- <option> 1
- <option> 2
- <option> 3
-</select>
-</form>
-EOT
-
-# list names
-ok($form->param, 4);
-ok(j($form->param), "hidden_1:checkbox_1:checkbox_2:multi_select_field");
-
-# get
-ok($form->param('hidden_1'), '');
-ok($form->param('checkbox_1'), 'c1_v1');
-ok(j($form->param('checkbox_1')), 'c1_v1:c1_v2');
-ok($form->param('checkbox_2'), 'c2_v1');
-ok(j($form->param('checkbox_2')), 'c2_v1');
-ok(!defined($form->param('multi_select_field')));
-ok(j($form->param('multi_select_field')), '');
-ok(!defined($form->param('unknown')));
-ok(j($form->param('unknown')), '');
-
-# set
-eval {
- $form->param('hidden_1', 'x');
-};
-ok($@, qr/readonly/);
-ok(j($form->param('hidden_1')), '');
-
-eval {
- $form->param('checkbox_1', 'foo');
-};
-ok($@, qr/Illegal value/);
-ok(j($form->param('checkbox_1')), 'c1_v1:c1_v2');
-
-$form->param('checkbox_1', 'c1_v2');
-ok(j($form->param('checkbox_1')), 'c1_v2');
-$form->param('checkbox_1', 'c1_v2');
-ok(j($form->param('checkbox_1')), 'c1_v2');
-$form->param('checkbox_1', []);
-ok(j($form->param('checkbox_1')), '');
-$form->param('checkbox_1', ['c1_v2', 'c1_v1']);
-ok(j($form->param('checkbox_1')), 'c1_v1:c1_v2');
-$form->param('checkbox_1', []);
-ok(j($form->param('checkbox_1')), '');
-$form->param('checkbox_1', 'c1_v2', 'c1_v1');
-ok(j($form->param('checkbox_1')), 'c1_v1:c1_v2');
-
-$form->param('multi_select_field', 3, 2);
-ok(j($form->param('multi_select_field')), "2:3");
-
-sub j {
- join(":", @_);
-}
+++ /dev/null
-#!perl -w
-
-use strict;
-use Test qw(plan ok);
-
-plan tests => 12;
-
-use HTML::Form;
-
-my $form = HTML::Form->parse(<<"EOT", base => "http://example.com", strict => 1);
-<form>
-<input name="n1" id="id1" class="A" value="1">
-<input id="id2" class="A" value="2">
-<input id="id3" class="B" value="3">
-<select id="id4">
- <option>1
- <option>2
- <option>3
-</selector>
-<input id="#foo" name="#bar" class=".D" disabled>
-</form>
-EOT
-
-#$form->dump;
-
-ok($form->value("n1"), 1);
-ok($form->value("^n1"), 1);
-ok($form->value("#id1"), 1);
-ok($form->value(".A"), 1);
-ok($form->value("#id2"), 2);
-ok($form->value(".B"), 3);
-
-ok(j(map $_->value, $form->find_input(".A")), "1:2");
-
-$form->find_input("#id2")->name("n2");
-$form->value("#id2", 22);
-ok($form->click->uri->query, "n1=1&n2=22");
-
-# try some odd names
-ok($form->find_input("##foo")->name, "#bar");
-ok($form->find_input("#bar"), undef);
-ok($form->find_input("^#bar")->class, ".D");
-ok($form->find_input("..D")->id, "#foo");
-
-sub j {
- join(":", @_);
-}
+++ /dev/null
-#!perl -w
-
-use strict;
-use Test qw(plan ok);
-
-plan tests => 127;
-
-use HTML::Form;
-
-my @warn;
-$SIG{__WARN__} = sub { push(@warn, $_[0]) };
-
-my @f = HTML::Form->parse("", "http://localhost/");
-ok(@f, 0);
-
-@f = HTML::Form->parse(<<'EOT', "http://localhost/");
-<form action="abc" name="foo">
-<input name="name">
-</form>
-<form></form>
-EOT
-
-ok(@f, 2);
-
-my $f = shift @f;
-ok($f->value("name"), "");
-ok($f->dump, "GET http://localhost/abc [foo]\n name= (text)\n");
-
-my $req = $f->click;
-ok($req->method, "GET");
-ok($req->uri, "http://localhost/abc?name=");
-
-$f->value(name => "Gisle Aas");
-$req = $f->click;
-ok($req->method, "GET");
-ok($req->uri, "http://localhost/abc?name=Gisle+Aas");
-
-ok($f->attr("name"), "foo");
-ok($f->attr("method"), undef);
-
-$f = shift @f;
-ok($f->method, "GET");
-ok($f->action, "http://localhost/");
-ok($f->enctype, "application/x-www-form-urlencoded");
-ok($f->dump, "GET http://localhost/\n");
-
-# try some more advanced inputs
-$f = HTML::Form->parse(<<'EOT', base => "http://localhost/", verbose => 1);
-<form method=post>
- <input name=i type="image" src="foo.gif">
- <input name=c type="checkbox" checked>
- <input name=r type="radio" value="a">
- <input name=r type="radio" value="b" checked>
- <input name=t type="text">
- <input name=p type="PASSWORD">
- <input name=h type="hidden" value=xyzzy>
- <input name=s type="submit" value="Doit!">
- <input name=r type="reset">
- <input name=b type="button">
- <input name=f type="file" value="foo.txt">
- <input name=x type="xyzzy">
-
- <textarea name=a>
-abc
- </textarea>
-
- <select name=s>
- <option>Foo
- <option value="bar" selected>Bar
- </select>
-
- <select name=m multiple>
- <option selected value="a">Foo
- <option selected value="b">Bar
- </select>
-</form>
-EOT
-
-#print $f->dump;
-#print $f->click->as_string;
-
-ok($f->click->as_string, <<'EOT');
-POST http://localhost/
-Content-Length: 69
-Content-Type: application/x-www-form-urlencoded
-
-i.x=1&i.y=1&c=on&r=b&t=&p=&h=xyzzy&f=&x=&a=%0Aabc%0A+++&s=bar&m=a&m=b
-EOT
-
-ok(@warn, 1);
-ok($warn[0] =~ /^Unknown input type 'xyzzy'/);
-@warn = ();
-
-$f = HTML::Form->parse(<<'EOT', "http://localhost/");
-<form>
- <input type=submit value="Upload it!" name=n disabled>
- <input type=image alt="Foo">
- <input type=text name=t value="1">
-</form>
-EOT
-
-#$f->dump;
-ok($f->click->as_string, <<'EOT');
-GET http://localhost/?x=1&y=1&t=1
-
-EOT
-
-# test file upload
-$f = HTML::Form->parse(<<'EOT', "http://localhost/");
-<form method=post enctype="MULTIPART/FORM-DATA">
- <input name=f type=file value="/etc/passwd">
- <input type=submit value="Upload it!">
-</form>
-EOT
-
-#print $f->dump;
-#print $f->click->as_string;
-
-ok($f->click->as_string, <<'EOT');
-POST http://localhost/
-Content-Length: 0
-Content-Type: multipart/form-data; boundary=none
-
-EOT
-
-my $filename = sprintf "foo-%08d.txt", $$;
-die if -e $filename;
-
-open(FILE, ">$filename") || die;
-binmode(FILE);
-print FILE "This is some text\n";
-close(FILE) || die;
-
-$f->value(f => $filename);
-
-#print $f->click->as_string;
-
-ok($f->click->as_string, <<"EOT");
-POST http://localhost/
-Content-Length: 139
-Content-Type: multipart/form-data; boundary=xYzZY
-
---xYzZY\r
-Content-Disposition: form-data; name="f"; filename="$filename"\r
-Content-Type: text/plain\r
-\r
-This is some text
-\r
---xYzZY--\r
-EOT
-
-unlink($filename) || warn "Can't unlink '$filename': $!";
-
-ok(@warn, 0);
-
-# Try to parse form HTTP::Response directly
-{
- package MyResponse;
- use vars qw(@ISA);
- require HTTP::Response;
- @ISA = ('HTTP::Response');
-
- sub base { "http://www.example.com" }
-}
-my $response = MyResponse->new(200, 'OK');
-$response->content("<form><input type=text value=42 name=x></form>");
-
-$f = HTML::Form->parse($response);
-
-ok($f->click->as_string, <<"EOT");
-GET http://www.example.com?x=42
-
-EOT
-
-$f = HTML::Form->parse(<<EOT, "http://www.example.com");
-<form>
- <input type=checkbox name=x> I like it!
-</form>
-EOT
-
-$f->find_input("x")->check;
-
-ok($f->click->as_string, <<"EOT");
-GET http://www.example.com?x=on
-
-EOT
-
-$f->value("x", "off");
-ok($f->click->as_string, <<"EOT");
-GET http://www.example.com
-
-EOT
-
-$f->value("x", "I like it!");
-ok($f->click->as_string, <<"EOT");
-GET http://www.example.com?x=on
-
-EOT
-
-$f->value("x", "I LIKE IT!");
-ok($f->click->as_string, <<"EOT");
-GET http://www.example.com?x=on
-
-EOT
-
-$f = HTML::Form->parse(<<EOT, "http://www.example.com");
-<form>
-<select name=x>
- <option value=1>one
- <option value=2>two
- <option>3
-</select>
-<select name=y multiple>
- <option value=1>
-</select>
-</form>
-EOT
-
-$f->value("x", "one");
-
-ok($f->click->as_string, <<"EOT");
-GET http://www.example.com?x=1
-
-EOT
-
-$f->value("x", "TWO");
-ok($f->click->as_string, <<"EOT");
-GET http://www.example.com?x=2
-
-EOT
-
-ok(join(":", $f->find_input("x")->value_names), "one:two:3");
-ok(join(":", map $_->name, $f->find_input(undef, "option")), "x:y");
-
-$f = HTML::Form->parse(<<EOT, "http://www.example.com");
-<form>
-<input name=x value=1 disabled>
-<input name=y value=2 READONLY type=TEXT>
-<input name=z value=3 type=hidden>
-</form>
-EOT
-
-ok($f->value("x"), 1);
-ok($f->value("y"), 2);
-ok($f->value("z"), 3);
-ok($f->click->uri->query, "y=2&z=3");
-
-my $input = $f->find_input("x");
-ok($input->type, "text");
-ok(!$input->readonly);
-ok($input->disabled);
-ok($input->disabled(0));
-ok(!$input->disabled);
-ok($f->click->uri->query, "x=1&y=2&z=3");
-
-$input = $f->find_input("y");
-ok($input->type, "text");
-ok($input->readonly);
-ok(!$input->disabled);
-$input->value(22);
-ok($f->click->uri->query, "x=1&y=22&z=3");
-
-$input->strict(1);
-eval {
- $input->value(23);
-};
-ok($@ =~ /^Input 'y' is readonly/);
-
-ok($input->readonly(0));
-ok(!$input->readonly);
-
-$input->value(222);
-ok(@warn, 0);
-ok($f->click->uri->query, "x=1&y=222&z=3");
-
-$input = $f->find_input("z");
-ok($input->type, "hidden");
-ok($input->readonly);
-ok(!$input->disabled);
-
-$f = HTML::Form->parse(<<EOT, "http://www.example.com");
-<form>
-<textarea name="t" type="hidden">
-<foo>
-</textarea>
-<select name=s value=s>
- <option name=y>Foo
- <option name=x value=bar type=x>Bar
-</form>
-EOT
-
-ok($f->value("t"), "\n<foo>\n");
-ok($f->value("s"), "Foo");
-ok(join(":", $f->find_input("s")->possible_values), "Foo:bar");
-ok(join(":", $f->find_input("s")->other_possible_values), "bar");
-ok($f->value("s", "bar"), "Foo");
-ok($f->value("s"), "bar");
-ok(join(":", $f->find_input("s")->other_possible_values), "");
-
-
-$f = HTML::Form->parse(<<EOT, base => "http://www.example.com", strict => 1);
-<form>
-
-<input type=radio name=r0 value=1 disabled>one
-
-<input type=radio name=r1 value=1 disabled>one
-<input type=radio name=r1 value=2>two
-<input type=radio name=r1 value=3>three
-
-<input type=radio name=r2 value=1>one
-<input type=radio name=r2 value=2 disabled>two
-<input type=radio name=r2 value=3>three
-
-<select name=s0>
- <option disabled>1
-</select>
-
-<select name=s1>
- <option disabled>1
- <option>2
- <option>3
-</select>
-
-<select name=s2>
- <option>1
- <option disabled>2
- <option>3
-</select>
-
-<select name=s3 disabled>
- <option>1
- <option disabled>2
- <option>3
-</select>
-
-<select name=m0 multiple>
- <option disabled>1
-</select>
-
-<select name=m1 multiple="">
- <option disabled>1
- <option>2
- <option>3
-</select>
-
-<select name=m2 multiple>
- <option>1
- <option disabled>2
- <option>3
-</select>
-
-<select name=m3 disabled multiple>
- <option>1
- <option disabled>2
- <option>3
-</select>
-
-</form>
-
-EOT
-#print $f->dump;
-ok($f->find_input("r0")->disabled);
-ok(!eval {$f->value("r0", 1);});
-ok($@ && $@ =~ /^The value '1' has been disabled for field 'r0'/);
-ok($f->find_input("r0")->disabled(0));
-ok(!$f->find_input("r0")->disabled);
-ok($f->value("r0", 1), undef);
-ok($f->value("r0"), 1);
-
-ok(!$f->find_input("r1")->disabled);
-ok($f->value("r1", 2), undef);
-ok($f->value("r1"), 2);
-ok(!eval {$f->value("r1", 1);});
-ok($@ && $@ =~ /^The value '1' has been disabled for field 'r1'/);
-
-ok($f->value("r2", 1), undef);
-ok(!eval {$f->value("r2", 2);});
-ok($@ && $@ =~ /^The value '2' has been disabled for field 'r2'/);
-ok(!eval {$f->value("r2", "two");});
-ok($@ && $@ =~ /^The value 'two' has been disabled for field 'r2'/);
-ok(!$f->find_input("r2")->disabled(1));
-ok(!eval {$f->value("r2", 1);});
-ok($@ && $@ =~ /^The value '1' has been disabled for field 'r2'/);
-ok($f->find_input("r2")->disabled(0));
-ok(!$f->find_input("r2")->disabled);
-ok($f->value("r2", 2), 1);
-
-ok($f->find_input("s0")->disabled);
-ok(!$f->find_input("s1")->disabled);
-ok(!$f->find_input("s2")->disabled);
-ok($f->find_input("s3")->disabled);
-
-ok(!eval {$f->value("s1", 1);});
-ok($@ && $@ =~ /^The value '1' has been disabled for field 's1'/);
-
-ok($f->find_input("m0")->disabled);
-ok($f->find_input("m1", undef, 1)->disabled);
-ok(!$f->find_input("m1", undef, 2)->disabled);
-ok(!$f->find_input("m1", undef, 3)->disabled);
-
-ok(!$f->find_input("m2", undef, 1)->disabled);
-ok($f->find_input("m2", undef, 2)->disabled);
-ok(!$f->find_input("m2", undef, 3)->disabled);
-
-ok($f->find_input("m3", undef, 1)->disabled);
-ok($f->find_input("m3", undef, 2)->disabled);
-ok($f->find_input("m3", undef, 3)->disabled);
-
-$f->find_input("m3", undef, 2)->disabled(0);
-ok(!$f->find_input("m3", undef, 2)->disabled);
-ok($f->find_input("m3", undef, 2)->value(2), undef);
-ok($f->find_input("m3", undef, 2)->value(undef), 2);
-
-$f->find_input("m3", undef, 2)->disabled(1);
-ok($f->find_input("m3", undef, 2)->disabled);
-ok(eval{$f->find_input("m3", undef, 2)->value(2)}, undef);
-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">
- <keygen NAME="randomkey" CHALLENGE="1234567890">
- <input TYPE="text" NAME="Field1" VALUE="Default Text">
-</form>
-EOT
-
-ok($f->find_input("randomkey"));
-ok($f->find_input("randomkey")->challenge, "1234567890");
-ok($f->find_input("randomkey")->keytype, "rsa");
-ok($f->click->as_string, <<EOT);
-POST http://example.com/secure/keygen/test.cgi
-Content-Length: 19
-Content-Type: application/x-www-form-urlencoded
-
-Field1=Default+Text
-EOT
-
-$f->value(randomkey => "foo");
-ok($f->click->as_string, <<EOT);
-POST http://example.com/secure/keygen/test.cgi
-Content-Length: 33
-Content-Type: application/x-www-form-urlencoded
-
-randomkey=foo&Field1=Default+Text
-EOT
-
-$f = HTML::Form->parse(<<EOT, "http://www.example.com");
-<form ACTION="http://example.com/">
- <select name=s>
- <option>1
- <option>2
- <input name=t>
-</form>
-EOT
-
-ok($f);
-ok($f->find_input("t"));
-
-
-@f = HTML::Form->parse(<<EOT, "http://www.example.com");
-<form ACTION="http://example.com/">
- <select name=s>
- <option>1
- <option>2
-</form>
-<form ACTION="http://example.com/">
- <input name=t>
-</form>
-EOT
-
-ok(@f, 2);
-ok($f[0]->find_input("s"));
-ok($f[1]->find_input("t"));
-
-$f = HTML::Form->parse(<<EOT, "http://www.example.com");
-<form ACTION="http://example.com/">
- <fieldset>
- <legend>Radio Buttons with Labels</legend>
- <label>
- <input type=radio name=r0 value=0 />zero
- </label>
- <label>one
- <input type=radio name=r1 value=1>
- </label>
- <label for="r2">two</label>
- <input type=radio name=r2 id=r2 value=2>
- <label>
- <span>nested</span>
- <input type=radio name=r3 value=3>
- </label>
- <label>
- before
- and <input type=radio name=r4 value=4>
- after
- </label>
- </fieldset>
-</form>
-EOT
-
-ok(join(":", $f->find_input("r0")->value_names), "zero");
-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");
-
-@warn = ();
-$f = HTML::Form->parse(<<EOT, "http://www.example.com");
-<form>
-<select id="myselect">
-<option>one</option>
-<option>two</option>
-<option>three</option>
-</select>
-</form>
-EOT
-ok(@warn, 0);
--- /dev/null
+#!perl -w
+
+use strict;
+use Test;
+plan tests => 1;
+
+use LWP::UserAgent;
+my $ua = LWP::UserAgent->new;
+
+require HTTP::Request;
+my $req = HTTP::Request->new(TRACE => "http://www.apache.org/");
+$req->protocol("HTTP/1.0");
+my $res = $ua->simple_request($req);
+ok($res->content, qr/HTTP\/1.0/);
+
+$res->dump(prefix => "# ");
+++ /dev/null
-#!perl -w
-
-use Test;
-
-use strict;
-use File::Listing;
-use LWP::Simple;
-
-# some sample URLs
-my @urls = (
- "http://www.apache.org/dist/apr/?C=N&O=D",
- "http://perl.apache.org/rpm/distrib/",
- "http://www.cpan.org/modules/by-module/",
- );
-plan tests => scalar(@urls);
-
-for my $url (@urls) {
- print "# $url\n";
- my $dir = get($url);
- unless ($dir) {
- print "# Can't get document at $url\n";
- ok(0);
- next;
- }
- my @listing = parse_dir($dir, undef, "apache");
- ok(@listing);
-}
+++ /dev/null
-#!perl -w
-
-use strict;
-use Test;
-plan tests => 6;
-
-use Net::HTTP;
-
-
-my $s = Net::HTTP->new(Host => "www.apache.org",
- KeepAlive => 1,
- Timeout => 15,
- PeerHTTPVersion => "1.1",
- MaxLineLength => 512) || die "$@";
-
-for (1..2) {
- $s->write_request(TRACE => "/libwww-perl",
- 'User-Agent' => 'Mozilla/5.0',
- 'Accept-Language' => 'no,en',
- Accept => '*/*');
-
- my($code, $mess, %h) = $s->read_response_headers;
- print "# $code $mess\n";
- for (sort keys %h) {
- print "# $_: $h{$_}\n";
- }
- print "\n";
-
- ok($code, "200");
- ok($h{'Content-Type'}, "message/http");
-
- my $buf;
- while (1) {
- my $tmp;
- my $n = $s->read_entity_body($tmp, 20);
- last unless $n;
- $buf .= $tmp;
- }
- $buf =~ s/\r//g;
-
- ok($buf, <<EOT);
-TRACE /libwww-perl HTTP/1.1
-Host: www.apache.org
-User-Agent: Mozilla/5.0
-Accept-Language: no,en
-Accept: */*
-
-EOT
-}
-
+++ /dev/null
-#!perl -w
-
-use strict;
-use Test;
-
-use LWP::UserAgent;
-
-my $ua = LWP::UserAgent->new();
-my $res = $ua->simple_request(HTTP::Request->new(GET => "https://www.apache.org"));
-
-if ($res->code == 501 && $res->message =~ /Protocol scheme 'https' is not supported/) {
- print "1..0 # Skipped: " . $res->message . "\n";
- exit;
-}
-
-plan tests => 2;
-ok($res->is_success);
-ok($res->content =~ /Apache Software Foundation/);
-
-$res->dump(prefix => "# ");
+++ /dev/null
-use strict;
-use Test;
-
-plan tests => 5;
-
-use LWP::UserAgent;
-
-my $ua = LWP::UserAgent->new(keep_alive => 1);
-
-my $req = HTTP::Request->new(GET => "http://jigsaw.w3.org/HTTP/Basic/");
-
-my $res = $ua->request($req);
-
-#print $res->as_string;
-
-ok($res->code, 401);
-
-$req->authorization_basic('guest', 'guest');
-$res = $ua->simple_request($req);
-
-print $req->as_string, "\n";
-
-#print $res->as_string;
-ok($res->code, 200);
-ok($res->content =~ /Your browser made it!/);
-
-{
- package MyUA;
- use vars qw(@ISA);
- @ISA = qw(LWP::UserAgent);
-
- my @try = (['foo', 'bar'], ['', ''], ['guest', ''], ['guest', 'guest']);
-
- sub get_basic_credentials {
- my($self,$realm, $uri, $proxy) = @_;
- #print "$realm/$uri/$proxy\n";
- my $p = shift @try;
- #print join("/", @$p), "\n";
- return @$p;
- }
-
-}
-
-$ua = MyUA->new(keep_alive => 1);
-
-$req = HTTP::Request->new(GET => "http://jigsaw.w3.org/HTTP/Basic/");
-$res = $ua->request($req);
-
-#print $res->as_string;
-
-ok($res->content =~ /Your browser made it!/);
-ok($res->header("Client-Response-Num"), 5);
-
+++ /dev/null
-use strict;
-use Test;
-
-plan tests => 2;
-
-use LWP::UserAgent;
-
-{
- package MyUA;
- use vars qw(@ISA);
- @ISA = qw(LWP::UserAgent);
-
- my @try = (['foo', 'bar'], ['', ''], ['guest', ''], ['guest', 'guest']);
-
- sub get_basic_credentials {
- my($self,$realm, $uri, $proxy) = @_;
- print "$realm:$uri:$proxy => ";
- my $p = shift @try;
- print join("/", @$p), "\n";
- return @$p;
- }
-
-}
-
-my $ua = MyUA->new(keep_alive => 1);
-
-my $req = HTTP::Request->new(GET => "http://jigsaw.w3.org/HTTP/Digest/");
-my $res = $ua->request($req);
-
-#print $res->as_string;
-
-ok($res->content =~ /Your browser made it!/);
-ok($res->header("Client-Response-Num"), 5);
+++ /dev/null
-print "1..5\n";
-
-use strict;
-use LWP::UserAgent;
-
-my $ua = LWP::UserAgent->new(keep_alive => 1);
-
-my $req = HTTP::Request->new(GET => "http://jigsaw.w3.org/HTTP/ChunkedScript");
-my $res = $ua->request($req);
-
-print "not " unless $res->is_success && $res->content_type eq "text/plain";
-print "ok 1\n";
-
-print "not " unless $res->header("Client-Transfer-Encoding") eq "chunked";
-print "ok 2\n";
-
-for (${$res->content_ref}) {
- s/\015?\012/\n/g;
- /Below this line, is 1000 repeated lines of 0-9/ || die;
- s/^.*?-----+\n//s;
-
- my @lines = split(/^/);
- print "not " if @lines != 1000;
- print "ok 3\n";
-
- # check that all lines are the same
- my $first = shift(@lines);
- my $no_they_are_not;
- for (@lines) {
- $no_they_are_not++ if $_ ne $first;
- }
- print "not " if $no_they_are_not;
- print "ok 4\n";
-
- print "not " unless $first =~ /^\d+$/;
- print "ok 5\n";
-}
+++ /dev/null
-print "1..2\n";
-
-use strict;
-use LWP::UserAgent;
-
-my $ua = LWP::UserAgent->new(keep_alive => 1);
-
-my $res = $ua->get(
- "http://jigsaw.w3.org/HTTP/h-content-md5.html",
- "TE" => "deflate",
-);
-
-use Digest::MD5 qw(md5_base64);
-print "not " unless $res->header("Content-MD5") eq md5_base64($res->content) . "==";
-print "ok 1\n";
-
-print $res->as_string;
-
-my $etag = $res->header("etag");
-
-$res = $ua->get(
- "http://jigsaw.w3.org/HTTP/h-content-md5.html",
- "TE" => "deflate",
- "If-None-Match" => $etag,
-);
-print $res->as_string;
-
-print "not " unless $res->code eq "304" && $res->header("Client-Response-Num") == 2;
-print "ok 2\n";
+++ /dev/null
-print "1..2\n";
-
-use strict;
-use LWP::UserAgent;
-
-my $ua = LWP::UserAgent->new(keep_alive => 1);
-
-my $req = HTTP::Request->new(GET => "http://jigsaw.w3.org/HTTP/h-content-md5.html");
-$req->header("TE", "deflate");
-
-my $res = $ua->request($req);
-
-use Digest::MD5 qw(md5_base64);
-print "not " unless $res->header("Content-MD5") eq md5_base64($res->content) . "==";
-print "ok 1\n";
-
-print $res->as_string;
-
-my $etag = $res->header("etag");
-$req->header("If-None-Match" => $etag);
-
-$res = $ua->request($req);
-print $res->as_string;
-
-print "not " unless $res->code eq "304" && $res->header("Client-Response-Num") == 2;
-print "ok 2\n";
+++ /dev/null
-print "1..1\n";
-
-use strict;
-use LWP::UserAgent;
-
-my $ua = LWP::UserAgent->new(keep_alive => 1);
-
-my $res = $ua->get(
- "http://jigsaw.w3.org/HTTP/neg",
- Connection => "close",
-);
-
-print $res->as_string, "\n";
-
-print "not " unless $res->code == 300;
-print "ok 1\n";
+++ /dev/null
-print "1..1\n";
-
-use strict;
-use LWP::UserAgent;
-
-my $ua = LWP::UserAgent->new(keep_alive => 1);
-
-my $req = HTTP::Request->new(GET => "http://jigsaw.w3.org/HTTP/neg");
-$req->header(Connection => "close");
-my $res = $ua->request($req);
-
-print $res->as_string, "\n";
-
-print "not " unless $res->code == 300;
-print "ok 1\n";
+++ /dev/null
-#!perl -w
-
-print "1..4\n";
-
-use strict;
-use LWP::UserAgent;
-
-my $ua = LWP::UserAgent->new(keep_alive => 1);
-
-
-my $content;
-my $testno = 1;
-
-for my $te (undef, "", "deflate", "gzip", "trailers, deflate;q=0.4, identity;q=0.1") {
- my $req = HTTP::Request->new(GET => "http://jigsaw.w3.org/HTTP/TE/foo.txt");
- if (defined $te) {
- $req->header(TE => $te);
- $req->header(Connection => "TE");
- }
- print $req->as_string;
-
- my $res = $ua->request($req);
- if (defined $content) {
- print "not " unless $content eq $res->content;
- print "ok $testno\n\n";
- $testno++;
- }
- else {
- $content = $res->content;
- }
- $res->content("");
- print $res->as_string;
-}
--- /dev/null
+use strict;
+use Test;
+
+plan tests => 5;
+
+use LWP::UserAgent;
+
+my $ua = LWP::UserAgent->new(keep_alive => 1);
+
+my $req = HTTP::Request->new(GET => "http://jigsaw.w3.org/HTTP/Basic/");
+
+my $res = $ua->request($req);
+
+#print $res->as_string;
+
+ok($res->code, 401);
+
+$req->authorization_basic('guest', 'guest');
+$res = $ua->simple_request($req);
+
+print $req->as_string, "\n";
+
+#print $res->as_string;
+ok($res->code, 200);
+ok($res->content =~ /Your browser made it!/);
+
+{
+ package MyUA;
+ use vars qw(@ISA);
+ @ISA = qw(LWP::UserAgent);
+
+ my @try = (['foo', 'bar'], ['', ''], ['guest', ''], ['guest', 'guest']);
+
+ sub get_basic_credentials {
+ my($self,$realm, $uri, $proxy) = @_;
+ #print "$realm/$uri/$proxy\n";
+ my $p = shift @try;
+ #print join("/", @$p), "\n";
+ return @$p;
+ }
+
+}
+
+$ua = MyUA->new(keep_alive => 1);
+
+$req = HTTP::Request->new(GET => "http://jigsaw.w3.org/HTTP/Basic/");
+$res = $ua->request($req);
+
+#print $res->as_string;
+
+ok($res->content =~ /Your browser made it!/);
+ok($res->header("Client-Response-Num"), 5);
+
--- /dev/null
+use strict;
+use Test;
+
+plan tests => 2;
+
+use LWP::UserAgent;
+
+{
+ package MyUA;
+ use vars qw(@ISA);
+ @ISA = qw(LWP::UserAgent);
+
+ my @try = (['foo', 'bar'], ['', ''], ['guest', ''], ['guest', 'guest']);
+
+ sub get_basic_credentials {
+ my($self,$realm, $uri, $proxy) = @_;
+ print "$realm:$uri:$proxy => ";
+ my $p = shift @try;
+ print join("/", @$p), "\n";
+ return @$p;
+ }
+
+}
+
+my $ua = MyUA->new(keep_alive => 1);
+
+my $req = HTTP::Request->new(GET => "http://jigsaw.w3.org/HTTP/Digest/");
+my $res = $ua->request($req);
+
+#print $res->as_string;
+
+ok($res->content =~ /Your browser made it!/);
+ok($res->header("Client-Response-Num"), 5);
--- /dev/null
+print "1..5\n";
+
+use strict;
+use LWP::UserAgent;
+
+my $ua = LWP::UserAgent->new(keep_alive => 1);
+
+my $req = HTTP::Request->new(GET => "http://jigsaw.w3.org/HTTP/ChunkedScript");
+my $res = $ua->request($req);
+
+print "not " unless $res->is_success && $res->content_type eq "text/plain";
+print "ok 1\n";
+
+print "not " unless $res->header("Client-Transfer-Encoding") eq "chunked";
+print "ok 2\n";
+
+for (${$res->content_ref}) {
+ s/\015?\012/\n/g;
+ /Below this line, is 1000 repeated lines of 0-9/ || die;
+ s/^.*?-----+\n//s;
+
+ my @lines = split(/^/);
+ print "not " if @lines != 1000;
+ print "ok 3\n";
+
+ # check that all lines are the same
+ my $first = shift(@lines);
+ my $no_they_are_not;
+ for (@lines) {
+ $no_they_are_not++ if $_ ne $first;
+ }
+ print "not " if $no_they_are_not;
+ print "ok 4\n";
+
+ print "not " unless $first =~ /^\d+$/;
+ print "ok 5\n";
+}
--- /dev/null
+print "1..2\n";
+
+use strict;
+use LWP::UserAgent;
+
+my $ua = LWP::UserAgent->new(keep_alive => 1);
+
+my $res = $ua->get(
+ "http://jigsaw.w3.org/HTTP/h-content-md5.html",
+ "TE" => "deflate",
+);
+
+use Digest::MD5 qw(md5_base64);
+print "not " unless $res->header("Content-MD5") eq md5_base64($res->content) . "==";
+print "ok 1\n";
+
+print $res->as_string;
+
+my $etag = $res->header("etag");
+
+$res = $ua->get(
+ "http://jigsaw.w3.org/HTTP/h-content-md5.html",
+ "TE" => "deflate",
+ "If-None-Match" => $etag,
+);
+print $res->as_string;
+
+print "not " unless $res->code eq "304" && $res->header("Client-Response-Num") == 2;
+print "ok 2\n";
--- /dev/null
+print "1..2\n";
+
+use strict;
+use LWP::UserAgent;
+
+my $ua = LWP::UserAgent->new(keep_alive => 1);
+
+my $req = HTTP::Request->new(GET => "http://jigsaw.w3.org/HTTP/h-content-md5.html");
+$req->header("TE", "deflate");
+
+my $res = $ua->request($req);
+
+use Digest::MD5 qw(md5_base64);
+print "not " unless $res->header("Content-MD5") eq md5_base64($res->content) . "==";
+print "ok 1\n";
+
+print $res->as_string;
+
+my $etag = $res->header("etag");
+$req->header("If-None-Match" => $etag);
+
+$res = $ua->request($req);
+print $res->as_string;
+
+print "not " unless $res->code eq "304" && $res->header("Client-Response-Num") == 2;
+print "ok 2\n";
--- /dev/null
+print "1..1\n";
+
+use strict;
+use LWP::UserAgent;
+
+my $ua = LWP::UserAgent->new(keep_alive => 1);
+
+my $res = $ua->get(
+ "http://jigsaw.w3.org/HTTP/neg",
+ Connection => "close",
+);
+
+print $res->as_string, "\n";
+
+print "not " unless $res->code == 300;
+print "ok 1\n";
--- /dev/null
+print "1..1\n";
+
+use strict;
+use LWP::UserAgent;
+
+my $ua = LWP::UserAgent->new(keep_alive => 1);
+
+my $req = HTTP::Request->new(GET => "http://jigsaw.w3.org/HTTP/neg");
+$req->header(Connection => "close");
+my $res = $ua->request($req);
+
+print $res->as_string, "\n";
+
+print "not " unless $res->code == 300;
+print "ok 1\n";
--- /dev/null
+#!perl -w
+
+print "1..4\n";
+
+use strict;
+use LWP::UserAgent;
+
+my $ua = LWP::UserAgent->new(keep_alive => 1);
+
+
+my $content;
+my $testno = 1;
+
+for my $te (undef, "", "deflate", "gzip", "trailers, deflate;q=0.4, identity;q=0.1") {
+ my $req = HTTP::Request->new(GET => "http://jigsaw.w3.org/HTTP/TE/foo.txt");
+ if (defined $te) {
+ $req->header(TE => $te);
+ $req->header(Connection => "TE");
+ }
+ print $req->as_string;
+
+ my $res = $ua->request($req);
+ if (defined $content) {
+ print "not " unless $content eq $res->content;
+ print "ok $testno\n\n";
+ $testno++;
+ }
+ else {
+ $content = $res->content;
+ }
+ $res->content("");
+ print $res->as_string;
+}
--- /dev/null
+#!perl -w
+
+use strict;
+use Test;
+plan tests => 2;
+
+use LWP::UserAgent;
+my $ua = LWP::UserAgent->new;
+
+ok $ua->is_online;
+
+$ua->protocols_allowed([]);
+ok !$ua->is_online;
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Config;
-use HTTP::Daemon;
-use Test::More;
-# use Time::HiRes qw(sleep);
-our $CRLF;
-use Socket qw($CRLF);
-
-our $LOGGING = 0;
-
-our @TESTS = (
- {
- expect => 629,
- comment => "traditional, unchunked POST request",
- raw => "POST /cgi-bin/redir-TE.pl HTTP/1.1
-User-Agent: UNTRUSTED/1.0
-Content-Type: application/x-www-form-urlencoded
-Content-Length: 629
-Host: localhost
-
-JSR-205=0;font_small=15;png=1;jpg=1;alpha_channel=256;JSR-82=0;JSR-135=1;mot-wt=0;JSR-75-pim=0;pointer_motion_event=0;camera=1;free_memory=455472;heap_size=524284;cldc=CLDC-1.1;canvas_size_y=176;canvas_size_x=176;double_buffered=1;color=65536;JSR-120=1;JSR-184=1;JSR-180=0;JSR-75-file=0;push_socket=0;pointer_event=0;nokia-ui=1;java_platform=xxxxxxxxxxxxxxxxx/xxxxxxx;gif=1;midp=MIDP-1.0 MIDP-2.0;font_large=22;sie-col-game=0;JSR-179=0;push_sms=1;JSR-172=0;font_medium=18;fullscreen_canvas_size_y=220;fullscreen_canvas_size_x=176;java_locale=de;video_encoding=encoding=JPEG&width=176&height=182encoding=JPEG&width=176&height=220;"
- },
- {
- expect => 8,
- comment => "chunked with illegal Content-Length header; tiny message",
- raw => "POST /cgi-bin/redir-TE.pl HTTP/1.1
-Host: localhost
-Content-Type: application/x-www-form-urlencoded
-Content-Length: 8
-Transfer-Encoding: chunked
-
-8
-icm.x=u2
-0
-
-",
- },
- {
- expect => 868,
- comment => "chunked with illegal Content-Length header; medium sized",
- raw => "POST /cgi-bin/redir-TE.pl HTTP/1.1
-Host:dev05
-Connection:close
-Content-Type:application/x-www-form-urlencoded
-Content-Length:868
-transfer-encoding:chunked
-
-364
-JSR-205=0;font_small=20;png=1;jpg=1;JSR-82=0;JSR-135=1;mot-wt=0;JSR-75-pim=0;http=1;pointer_motion_event=0;browser_launch=1;free_memory=733456;user_agent=xxxxxxxxx/xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx;heap_size=815080;cldc=CLDC-1.0;canvas_size_y=182;canvas_size_x=176;double_buffered=1;NAVIGATION PRESS=20;JSR-184=0;JSR-120=1;color=32768;JSR-180=0;JSR-75-file=0;RIGHT SOFT KEY=22;NAVIGATION RIGHT=5;KEY *=42;push_socket=0;pointer_event=0;KEY #=35;KEY NUM 9=57;nokia-ui=0;KEY NUM 8=56;KEY NUM 7=55;KEY NUM 6=54;KEY NUM 5=53;gif=1;KEY NUM 4=52;NAVIGATION UP=1;KEY NUM 3=51;KEY NUM 2=50;KEY NUM 1=49;midp=MIDP-2.0 VSCL-1.1.0;font_large=20;KEY NUM 0=48;sie-col-game=0;JSR-179=0;push_sms=1;JSR-172=0;NAVIGATION LEFT=2;LEFT SOFT KEY=21;font_medium=20;fullscreen_canvas_size_y=204;fullscreen_canvas_size_x=176;https=1;NAVIGATION DOWN=6;java_locale=en-DE;
-0
-
-",
- },
- {
- expect => 1104,
- comment => "chunked correctly, size ~1k; base for the big next test",
- raw => "POST /cgi-bin/redir-TE.pl HTTP/1.1
-User-Agent: UNTRUSTED/1.0
-Content-Type: application/x-www-form-urlencoded
-Host: localhost:80
-Transfer-Encoding: chunked
-
-450
-JSR-205=0;font_small=15;png=1;jpg=1;jsr184_dithering=0;CLEAR/DELETE=-8;JSR-82=0;alpha_channel=32;JSR-135=1;mot-wt=0;JSR-75-pim=0;http=1;pointer_motion_event=0;browser_launch=1;BACK/RETURN=-11;camera=1;free_memory=456248;user_agent=xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx;heap_size=524284;cldc=CLDC-1.1;canvas_size_y=176;canvas_size_x=176;double_buffered=1;NAVIGATION PRESS=-5;JSR-184=1;JSR-120=1;color=65536;JSR-180=0;JSR-75-file=0;RIGHT SOFT KEY=-7;NAVIGATION RIGHT=-4;KEY *=42;push_socket=0;pointer_event=0;KEY #=35;KEY NUM 9=57;nokia-ui=1;KEY NUM 8=56;KEY NUM 7=55;KEY NUM 6=54;KEY NUM 5=53;java_platform=xxxxxxxxxxxxxxxxx/xxxxxxx;KEY NUM 4=52;gif=1;KEY NUM 3=51;NAVIGATION UP=-1;KEY NUM 2=50;KEY NUM 1=49;midp=MIDP-1.0 MIDP-2.0;font_large=22;KEY NUM 0=48;sie-col-game=0;JSR-179=0;push_sms=1;JSR-172=0;NAVIGATION LEFT=-3;LEFT SOFT KEY=-6;jsr184_antialiasing=0;font_medium=18;fullscreen_canvas_size_y=220;fullscreen_canvas_size_x=176;https=1;NAVIGATION DOWN=-2;java_locale=de;video_encoding=encoding=JPEG&width=176&height=182encoding=JPEG&width=176&height=220;
-0
-
-"
- },
- {
- expect => 1104*1024,
- comment => "chunked with many chunks",
- raw => ("POST /cgi-bin/redir-TE.pl HTTP/1.1
-User-Agent: UNTRUSTED/1.0
-Content-Type: application/x-www-form-urlencoded
-Host: localhost:80
-Transfer-Encoding: chunked
-
-".("450
-JSR-205=0;font_small=15;png=1;jpg=1;jsr184_dithering=0;CLEAR/DELETE=-8;JSR-82=0;alpha_channel=32;JSR-135=1;mot-wt=0;JSR-75-pim=0;http=1;pointer_motion_event=0;browser_launch=1;BACK/RETURN=-11;camera=1;free_memory=456248;user_agent=xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx;heap_size=524284;cldc=CLDC-1.1;canvas_size_y=176;canvas_size_x=176;double_buffered=1;NAVIGATION PRESS=-5;JSR-184=1;JSR-120=1;color=65536;JSR-180=0;JSR-75-file=0;RIGHT SOFT KEY=-7;NAVIGATION RIGHT=-4;KEY *=42;push_socket=0;pointer_event=0;KEY #=35;KEY NUM 9=57;nokia-ui=1;KEY NUM 8=56;KEY NUM 7=55;KEY NUM 6=54;KEY NUM 5=53;java_platform=xxxxxxxxxxxxxxxxx/xxxxxxx;KEY NUM 4=52;gif=1;KEY NUM 3=51;NAVIGATION UP=-1;KEY NUM 2=50;KEY NUM 1=49;midp=MIDP-1.0 MIDP-2.0;font_large=22;KEY NUM 0=48;sie-col-game=0;JSR-179=0;push_sms=1;JSR-172=0;NAVIGATION LEFT=-3;LEFT SOFT KEY=-6;jsr184_antialiasing=0;font_medium=18;fullscreen_canvas_size_y=220;fullscreen_canvas_size_x=176;https=1;NAVIGATION DOWN=-2;java_locale=de;video_encoding=encoding=JPEG&width=176&height=182encoding=JPEG&width=176&height=220;
-"x1024)."0
-
-")
- },
- );
-
-
-my $can_fork = $Config{d_fork} ||
- (($^O eq 'MSWin32' || $^O eq 'NetWare') and
- $Config{useithreads} and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/);
-
-my $tests = @TESTS;
-my $tport = 8333;
-
-my $tsock = IO::Socket::INET->new(LocalAddr => '0.0.0.0',
- LocalPort => $tport,
- Listen => 1,
- ReuseAddr => 1);
-if (!$can_fork) {
- plan skip_all => "This system cannot fork";
-}
-elsif (!$tsock) {
- plan skip_all => "Cannot listen on 0.0.0.0:$tport";
-}
-else {
- close $tsock;
- plan tests => $tests;
-}
-
-sub mywarn ($) {
- return unless $LOGGING;
- my($mess) = @_;
- open my $fh, ">>", "http-daemon.out"
- or die $!;
- my $ts = localtime;
- print $fh "$ts: $mess\n";
- close $fh or die $!;
-}
-
-
-my $pid;
-if ($pid = fork) {
- sleep 4;
- for my $t (0..$#TESTS) {
- my $test = $TESTS[$t];
- my $raw = $test->{raw};
- $raw =~ s/\r?\n/$CRLF/mg;
- if (0) {
- open my $fh, "| socket localhost $tport" or die;
- print $fh $test;
- }
- use IO::Socket::INET;
- my $sock = IO::Socket::INET->new(
- PeerAddr => "127.0.0.1",
- PeerPort => $tport,
- ) or die;
- if (0) {
- for my $pos (0..length($raw)-1) {
- print $sock substr($raw,$pos,1);
- sleep 0.001;
- }
- } else {
- print $sock $raw;
- }
- local $/;
- my $resp = <$sock>;
- close $sock;
- my($got) = $resp =~ /\r?\n\r?\n(\d+)/s;
- is($got,
- $test->{expect},
- "[$test->{expect}] $test->{comment}",
- );
- }
- wait;
-} else {
- die "cannot fork: $!" unless defined $pid;
- my $d = HTTP::Daemon->new(
- LocalAddr => '0.0.0.0',
- LocalPort => $tport,
- ReuseAddr => 1,
- ) or die;
- mywarn "Starting new daemon as '$$'";
- my $i;
- LISTEN: while (my $c = $d->accept) {
- my $r = $c->get_request;
- mywarn sprintf "headers[%s] content[%s]", $r->headers->as_string, $r->content;
- my $res = HTTP::Response->new(200,undef,undef,length($r->content).$CRLF);
- $c->send_response($res);
- $c->force_last_request; # we're just not mature enough
- $c->close;
- undef($c);
- last if ++$i >= $tests;
- }
-}
-
-
-
-# Local Variables:
-# mode: cperl
-# cperl-indent-level: 2
-# End:
exit;
}
+delete $ENV{PERL_LWP_ENV_PROXY};
+
$| = 1; # autoflush
require IO::Socket; # make sure this work before we try to make a HTTP::Daemon
open(DAEMON, "$perl local/http.t daemon |") or die "Can't exec daemon: $!";
}
-use Test;
-plan tests => 54;
+use Test::More;
+plan tests => 59;
my $greeting = <DAEMON>;
$greeting =~ /(<[^>]+>)/;
$req->header(X_Foo => "Bar");
$res = $ua->request($req);
-ok($res->is_error);
-ok($res->code, 404);
-ok($res->message, qr/not\s+found/i);
+ok($res->is_error, 'is_error');
+is($res->code, 404, 'response code 404');
+like($res->message, qr/not\s+found/i, '404 message');
# we also expect a few headers
ok($res->server);
ok($res->date);
#print $res->as_string;
ok($res->is_success);
-ok($res->code, 200);
-ok($res->message, "OK");
+is($res->code, 200, 'status code 200');
+is($res->message, "OK", 'message OK');
$_ = $res->content;
@accept = /^Accept:\s*(.*)/mg;
-ok($_, qr/^From:\s*gisle\@aas\.no\n/m);
-ok($_, qr/^Host:/m);
-ok(@accept, 3);
-ok($_, qr/^Accept:\s*text\/html/m);
-ok($_, qr/^Accept:\s*text\/plain/m);
-ok($_, qr/^Accept:\s*image\/\*/m);
-ok($_, qr/^If-Modified-Since:\s*\w{3},\s+\d+/m);
-ok($_, qr/^Long-Text:\s*This.*broken between/m);
-ok($_, qr/^Foo-Bar:\s*1\n/m);
-ok($_, qr/^X-Foo:\s*Bar\n/m);
-ok($_, qr/^User-Agent:\s*Mozilla\/0.01/m);
+like($_, qr/^From:\s*gisle\@aas\.no\n/m);
+like($_, qr/^Host:/m);
+is(@accept, 3, '3 items in accept');
+like($_, qr/^Accept:\s*text\/html/m);
+like($_, qr/^Accept:\s*text\/plain/m);
+like($_, qr/^Accept:\s*image\/\*/m);
+like($_, qr/^If-Modified-Since:\s*\w{3},\s+\d+/m);
+like($_, qr/^Long-Text:\s*This.*broken between/m);
+like($_, qr/^Foo-Bar:\s*1\n/m);
+like($_, qr/^X-Foo:\s*Bar\n/m);
+like($_, qr/^User-Agent:\s*Mozilla\/0.01/m);
# Try it with the higher level 'get' interface
$res = $ua->get(url("/echo/path_info?query", $base),
X_Foo => "Bar",
);
#$res->dump;
-ok($res->code, 200);
+is($res->code, 200, 'response code 200');
+
+#----------------------------------------------------------------
+print "UserAgent->put...\n";
+sub httpd_put_echo
+{
+ my($c, $req) = @_;
+ $c->send_basic_header(200);
+ print $c "Content-Type: message/http\015\012";
+ $c->send_crlf;
+ print $c $req->as_string;
+}
+ok($res->content, qr/^From: gisle\@aas.no$/m);
+# Try it with the higher level 'get' interface
+$res = $ua->put(url("/echo/path_info?query", $base),
+ Accept => 'text/html',
+ Accept => 'text/plain; q=0.9',
+ Accept => 'image/*',
+ X_Foo => "Bar",
+);
+#$res->dump;
+is($res->code, 200, 'response code 200');
+ok($res->content, qr/^From: gisle\@aas.no$/m);
+
+#----------------------------------------------------------------
+print "UserAgent->delete...\n";
+sub httpd_delete_echo
+{
+ my($c, $req) = @_;
+ $c->send_basic_header(200);
+ print $c "Content-Type: message/http\015\012";
+ $c->send_crlf;
+ print $c $req->as_string;
+}
+ok($res->content, qr/^From: gisle\@aas.no$/m);
+# Try it with the higher level 'get' interface
+$res = $ua->delete(url("/echo/path_info?query", $base),
+ Accept => 'text/html',
+ Accept => 'text/plain; q=0.9',
+ Accept => 'image/*',
+ X_Foo => "Bar",
+);
+#$res->dump;
+is($res->code, 200, 'response code 200');
ok($res->content, qr/^From: gisle\@aas.no$/m);
#----------------------------------------------------------------
ok($res->is_success);
ok($res->content_type, 'text/html');
-ok($res->content_length, 147);
+is($res->content_length, 147, '147 content length');
ok($res->title, 'En prøve');
ok($res->content, qr/å være/);
$res = $ua->request($req);
#print $res->as_string;
ok($res->is_error);
-ok($res->code, 404); # not found
-
+is($res->code, 404, 'response code 404'); # not found
+
# Then try to list current directory
$req = new HTTP::Request GET => url("/file?name=.", $base);
$res = $ua->request($req);
#print $res->as_string;
-ok($res->code, 501); # NYI
+is($res->code, 501, 'response code 501'); # NYI
#----------------------------------------------------------------
ok($res->is_success);
ok($res->content, qr|/echo/redirect|);
ok($res->previous->is_redirect);
-ok($res->previous->code, 301);
+is($res->previous->code, 301, 'response code 301');
# Let's test a redirect loop too
sub httpd_get_redirect2 { shift->send_redirect("/redirect3/") }
#print $res->as_string;
ok($res->is_redirect);
ok($res->header("Client-Warning"), qr/loop detected/i);
-ok($res->redirects, 5);
+is($res->redirects, 5, '5 max redirects');
$ua->max_redirect(0);
$res = $ua->request($req);
-ok($res->previous, undef);
-ok($res->redirects, 0);
+is($res->previous, undef, 'undefined previous');
+is($res->redirects, 0, 'zero redirects');
$ua->max_redirect(5);
#----------------------------------------------------------------
# Let's try with a $ua that does not pass out credentials
$res = $ua->request($req);
-ok($res->code, 401);
+is($res->code, 401, 'respone code 401');
# Let's try to set credentials for this realm
$ua->credentials($req->uri->host_port, "libwww-perl", "ok 12", "xyzzy");
# Then illegal credentials
$ua->credentials($req->uri->host_port, "libwww-perl", "user", "passwd");
$res = $ua->request($req);
-ok($res->code, 401);
+is($res->code, 401, 'response code 401');
#----------------------------------------------------------------
$req = new HTTP::Request GET => url("/quit", $base);
$res = $ua->request($req);
-ok($res->code, 503);
+is($res->code, 503, 'response code is 503');
ok($res->content, qr/Bye, bye/);
+++ /dev/null
-
-print "1..13\n";
-
-
-use WWW::RobotRules::AnyDBM_File;
-
-$file = "test-$$";
-
-$r = new WWW::RobotRules::AnyDBM_File "myrobot/2.0", $file;
-
-$r->parse("http://www.aas.no/robots.txt", "");
-
-$r->visit("www.aas.no:80");
-
-print "not " if $r->no_visits("www.aas.no:80") != 1;
-print "ok 1\n";
-
-
-$r->push_rules("www.sn.no:80", "/aas", "/per");
-$r->push_rules("www.sn.no:80", "/god", "/old");
-
-@r = $r->rules("www.sn.no:80");
-print "Rules: @r\n";
-
-print "not " if "@r" ne "/aas /per /god /old";
-print "ok 2\n";
-
-$r->clear_rules("per");
-$r->clear_rules("www.sn.no:80");
-
-@r = $r->rules("www.sn.no:80");
-print "Rules: @r\n";
-
-print "not " if "@r" ne "";
-print "ok 3\n";
-
-$r->visit("www.aas.no:80", time+10);
-$r->visit("www.sn.no:80");
-
-print "No visits: ", $r->no_visits("www.aas.no:80"), "\n";
-print "Last visit: ", $r->last_visit("www.aas.no:80"), "\n";
-print "Fresh until: ", $r->fresh_until("www.aas.no:80"), "\n";
-
-print "not " if $r->no_visits("www.aas.no:80") != 2;
-print "ok 4\n";
-
-print "not " if abs($r->last_visit("www.sn.no:80") - time) > 2;
-print "ok 5\n";
-
-$r = undef;
-
-# Try to reopen the database without a name specified
-$r = new WWW::RobotRules::AnyDBM_File undef, $file;
-$r->visit("www.aas.no:80");
-
-print "not " if $r->no_visits("www.aas.no:80") != 3;
-print "ok 6\n";
-
-print "Agent-Name: ", $r->agent, "\n";
-print "not " if $r->agent ne "myrobot";
-print "ok 7\n";
-
-$r = undef;
-
-print "*** Dump of database ***\n";
-tie(%cat, AnyDBM_File, $file, 0, 0644) or die "Can't tie: $!";
-while (($key,$val) = each(%cat)) {
- print "$key\t$val\n";
-}
-print "******\n";
-
-untie %cat;
-
-# Try to open database with a different agent name
-$r = new WWW::RobotRules::AnyDBM_File "MOMSpider/2.0", $file;
-
-print "not " if $r->no_visits("www.sn.no:80");
-print "ok 8\n";
-
-# Try parsing
-$r->parse("http://www.sn.no:8080/robots.txt", <<EOT, (time + 3));
-
-User-Agent: *
-Disallow: /
-
-User-Agent: Momspider
-Disallow: /foo
-Disallow: /bar
-
-EOT
-
-@r = $r->rules("www.sn.no:8080");
-print "not " if "@r" ne "/foo /bar";
-print "ok 9\n";
-
-print "not " if $r->allowed("http://www.sn.no") >= 0;
-print "ok 10\n";
-
-print "not " if $r->allowed("http://www.sn.no:8080/foo/gisle");
-print "ok 11\n";
-
-sleep(5); # wait until file has expired
-print "not " if $r->allowed("http://www.sn.no:8080/foo/gisle") >= 0;
-print "ok 12\n";
-
-
-$r = undef;
-
-print "*** Dump of database ***\n";
-tie(%cat, AnyDBM_File, $file, 0, 0644) or die "Can't tie: $!";
-while (($key,$val) = each(%cat)) {
- print "$key\t$val\n";
-}
-print "******\n";
-
-untie %cat; # Otherwise the next line fails on DOSish
-
-while (unlink("$file", "$file.pag", "$file.dir", "$file.db")) {}
-
-# Try open a an emty database without specifying a name
-eval {
- $r = new WWW::RobotRules::AnyDBM_File undef, $file;
-};
-print $@;
-print "not " unless $@; # should fail
-print "ok 13\n";
-
-unlink "$file", "$file.pag", "$file.dir", "$file.db";
+++ /dev/null
-#!/local/bin/perl
-
-=head1 NAME
-
-robot-rules.t
-
-=head1 DESCRIPTION
-
-Test a number of different A</robots.txt> files against a number
-of different User-agents.
-
-=cut
-
-require WWW::RobotRules;
-use Carp;
-use strict;
-
-print "1..50\n"; # for Test::Harness
-
-# We test a number of different /robots.txt files,
-#
-
-my $content1 = <<EOM;
-# http://foo/robots.txt
-User-agent: *
-Disallow: /private
-Disallow: http://foo/also_private
-
-User-agent: MOMspider
-Disallow:
-EOM
-
-my $content2 = <<EOM;
-# http://foo/robots.txt
-User-agent: MOMspider
- # comment which should be ignored
-Disallow: /private
-EOM
-
-my $content3 = <<EOM;
-# http://foo/robots.txt
-EOM
-
-my $content4 = <<EOM;
-# http://foo/robots.txt
-User-agent: *
-Disallow: /private
-Disallow: mailto:foo
-
-User-agent: MOMspider
-Disallow: /this
-
-User-agent: Another
-Disallow: /that
-
-
-User-agent: SvartEnke1
-Disallow: http://fOO
-Disallow: http://bar
-
-User-Agent: SvartEnke2
-Disallow: ftp://foo
-Disallow: http://foo:8080/
-Disallow: http://bar/
-
-Sitemap: http://www.adobe.com/sitemap.xml
-EOM
-
-my $content5 = <<EOM;
-# I've locked myself away
-User-agent: *
-Disallow: /
-# The castle is your home now, so you can go anywhere you like.
-User-agent: Belle
-Disallow: /west-wing/ # except the west wing!
-# It's good to be the Prince...
-User-agent: Beast
-Disallow:
-EOM
-
-# same thing backwards
-my $content6 = <<EOM;
-# It's good to be the Prince...
-User-agent: Beast
-Disallow:
-# The castle is your home now, so you can go anywhere you like.
-User-agent: Belle
-Disallow: /west-wing/ # except the west wing!
-# I've locked myself away
-User-agent: *
-Disallow: /
-EOM
-
-# and a number of different robots:
-
-my @tests1 = (
- [$content1, 'MOMspider' =>
- 1 => 'http://foo/private' => 1,
- 2 => 'http://foo/also_private' => 1,
- ],
-
- [$content1, 'Wubble' =>
- 3 => 'http://foo/private' => 0,
- 4 => 'http://foo/also_private' => 0,
- 5 => 'http://foo/other' => 1,
- ],
-
- [$content2, 'MOMspider' =>
- 6 => 'http://foo/private' => 0,
- 7 => 'http://foo/other' => 1,
- ],
-
- [$content2, 'Wubble' =>
- 8 => 'http://foo/private' => 1,
- 9 => 'http://foo/also_private' => 1,
- 10 => 'http://foo/other' => 1,
- ],
-
- [$content3, 'MOMspider' =>
- 11 => 'http://foo/private' => 1,
- 12 => 'http://foo/other' => 1,
- ],
-
- [$content3, 'Wubble' =>
- 13 => 'http://foo/private' => 1,
- 14 => 'http://foo/other' => 1,
- ],
-
- [$content4, 'MOMspider' =>
- 15 => 'http://foo/private' => 1,
- 16 => 'http://foo/this' => 0,
- 17 => 'http://foo/that' => 1,
- ],
-
- [$content4, 'Another' =>
- 18 => 'http://foo/private' => 1,
- 19 => 'http://foo/this' => 1,
- 20 => 'http://foo/that' => 0,
- ],
-
- [$content4, 'Wubble' =>
- 21 => 'http://foo/private' => 0,
- 22 => 'http://foo/this' => 1,
- 23 => 'http://foo/that' => 1,
- ],
-
- [$content4, 'Another/1.0' =>
- 24 => 'http://foo/private' => 1,
- 25 => 'http://foo/this' => 1,
- 26 => 'http://foo/that' => 0,
- ],
-
- [$content4, "SvartEnke1" =>
- 27 => "http://foo/" => 0,
- 28 => "http://foo/this" => 0,
- 29 => "http://bar/" => 1,
- ],
-
- [$content4, "SvartEnke2" =>
- 30 => "http://foo/" => 1,
- 31 => "http://foo/this" => 1,
- 32 => "http://bar/" => 1,
- ],
-
- [$content4, "MomSpiderJr" => # should match "MomSpider"
- 33 => 'http://foo/private' => 1,
- 34 => 'http://foo/also_private' => 1,
- 35 => 'http://foo/this/' => 0,
- ],
-
- [$content4, "SvartEnk" => # should match "*"
- 36 => "http://foo/" => 1,
- 37 => "http://foo/private/" => 0,
- 38 => "http://bar/" => 1,
- ],
-
- [$content5, 'Villager/1.0' =>
- 39 => 'http://foo/west-wing/' => 0,
- 40 => 'http://foo/' => 0,
- ],
-
- [$content5, 'Belle/2.0' =>
- 41 => 'http://foo/west-wing/' => 0,
- 42 => 'http://foo/' => 1,
- ],
-
- [$content5, 'Beast/3.0' =>
- 43 => 'http://foo/west-wing/' => 1,
- 44 => 'http://foo/' => 1,
- ],
-
- [$content6, 'Villager/1.0' =>
- 45 => 'http://foo/west-wing/' => 0,
- 46 => 'http://foo/' => 0,
- ],
-
- [$content6, 'Belle/2.0' =>
- 47 => 'http://foo/west-wing/' => 0,
- 48 => 'http://foo/' => 1,
- ],
-
- [$content6, 'Beast/3.0' =>
- 49 => 'http://foo/west-wing/' => 1,
- 50 => 'http://foo/' => 1,
- ],
-
- # when adding tests, remember to increase
- # the maximum at the top
-
- );
-
-my $t;
-
-for $t (@tests1) {
- my ($content, $ua) = splice(@$t, 0, 2);
-
- my $robotsrules = new WWW::RobotRules($ua);
- $robotsrules->parse('http://foo/robots.txt', $content);
-
- my ($num, $path, $expected);
- while(($num, $path, $expected) = splice(@$t, 0, 3)) {
- my $allowed = $robotsrules->allowed($path);
- $allowed = 1 if $allowed;
- if($allowed != $expected) {
- $robotsrules->dump;
- confess "Test Failed: $ua => $path ($allowed != $expected)";
- }
- print "ok $num\n";
- }
-}
exit;
}
+delete $ENV{PERL_LWP_ENV_PROXY};
+
$| = 1; # autoflush
require IO::Socket; # make sure this work before we try to make a HTTP::Daemon
exit;
}
+delete $ENV{PERL_LWP_ENV_PROXY};
+
$| = 1; # autoflush
require IO::Socket; # make sure this work before we try to make a HTTP::Daemon
projects / platform / upstream / perl-libwww-perl.git / commitdiff