pkg://perl-libwww-perl-5.79-5.src.rpm:230201/libwww-perl-5.79.tar.gz
info downloads
libwww-perl-5.79/ 0040755 0000764 0000764 00000000000 10036720346 012736 5 ustar gisle gisle libwww-perl-5.79/lib/ 0040755 0000764 0000764 00000000000 10036720346 013504 5 ustar gisle gisle libwww-perl-5.79/lib/HTTP/ 0040755 0000764 0000764 00000000000 10036720346 014263 5 ustar gisle gisle libwww-perl-5.79/lib/HTTP/Cookies.pm 0100644 0000764 0000764 00000050026 10035541423 016211 0 ustar gisle gisle package HTTP::Cookies;
use strict;
use HTTP::Date qw(str2time time2str);
use HTTP::Headers::Util qw(split_header_words join_header_words);
use LWP::Debug ();
use vars qw($VERSION $EPOCH_OFFSET);
$VERSION = sprintf("%d.%02d", q$Revision: 1.38 $ =~ /(\d+)\.(\d+)/);
# 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->url;
my $scheme = $url->scheme;
unless ($scheme =~ /^https?\z/) {
LWP::Debug::debug("Will not add cookies to non-HTTP requests");
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 =~ /\./) {
LWP::Debug::debug("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) {
LWP::Debug::debug("- checking cookie path=$path");
if (index($req_path, $path) != 0) {
LWP::Debug::debug(" path $path:$req_path does not fit");
next;
}
my($key,$array);
while (($key,$array) = each %{$cookies->{$path}}) {
my($version,$val,$port,$path_spec,$secure,$expires) = @$array;
LWP::Debug::debug(" - checking cookie $key=$val");
if ($secure && !$secure_request) {
LWP::Debug::debug(" not a secure requests");
next;
}
if ($expires && $expires < $now) {
LWP::Debug::debug(" expired");
next;
}
if ($port) {
my $found;
if ($port =~ s/^_//) {
# The correponding 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) {
LWP::Debug::debug(" port $port:$req_port does not fit");
next;
}
}
if ($version > 0 && $netscape_only) {
LWP::Debug::debug(" domain $domain applies to " .
"Netscape-style cookies only");
next;
}
LWP::Debug::debug(" it's a match");
# 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;
}
}
$request->header(Cookie => join("; ", @cval)) if @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->url;
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://www.netscape.com/newsref/std/cookie_spec.html
# can for instance contain an unquoted "," in the expires
# field, so we have to use this ad-hoc parser.
my $now = time();
# 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) {
my @cur;
my $param;
my $expires;
for $param (split(/;\s*/, $set)) {
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";
}
my $lc = lc($k);
if ($lc eq "expires") {
my $etime = str2time($v);
if ($etime) {
push(@cur, "Max-Age" => str2time($v) - $now);
$expires++;
}
}
else {
push(@cur, $k => $v);
}
}
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;
LWP::Debug::debug("Set cookie $key => $val");
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 signigicant
$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") {
LWP::Debug::debug("Domain $domain contains no dot");
next SET_COOKIE;
}
$domain = ".$domain" unless $domain =~ /^\./;
if ($domain =~ /\.\d+$/) {
LWP::Debug::debug("IP-address $domain illeagal as domain");
next SET_COOKIE;
}
my $len = length($domain);
unless (substr($req_host, -$len) eq $domain) {
LWP::Debug::debug("Domain $domain does not match host $req_host");
next SET_COOKIE;
}
my $hostpre = substr($req_host, 0, length($req_host) - $len);
if ($hostpre =~ /\./ && !$ns_cookie) {
LWP::Debug::debug("Host prefix contain a dot: $hostpre => $domain");
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) {
LWP::Debug::debug("Path $path is not a prefix of $req_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+$/) {
LWP::Debug::debug("Bad port $port (not numeric)");
next SET_COOKIE;
}
$found++ if $p eq $req_port;
}
unless ($found) {
LWP::Debug::debug("Request port ($req_port) not found in $port");
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;
$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://www.netscape.com/newsref/std/cookie_spec.html> and
<URL:http://www.cookiecentral.com/>. This module also implements the
new style cookies described in I<RFC 2965>.
The two variants of cookies are supposed to be able to coexist happily.
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.
libwww-perl-5.79/lib/HTTP/Status.pm 0100644 0000764 0000764 00000014775 07746022101 016115 0 ustar gisle gisle package HTTP::Status;
# $Id: Status.pm,v 1.28 2003/10/23 18:56:01 uid39246 Exp $
use strict;
require 5.002; # becase we use prototypes
use vars qw(@ISA @EXPORT @EXPORT_OK $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 = sprintf("%d.%02d", q$Revision: 1.28 $ =~ /(\d+)\.(\d+)/);
# Note also addition of mnemonics to @EXPORT below
my %StatusCode = (
100 => 'Continue',
101 => 'Switching Protocols',
102 => 'Processing', # WebDAV
200 => 'OK',
201 => 'Created',
202 => 'Accepted',
203 => 'Non-Authoritative Information',
204 => 'No Content',
205 => 'Reset Content',
206 => 'Partial Content',
207 => 'Multi-Status', # 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', # WebDAV
423 => 'Locked', # WebDAV
424 => 'Failed Dependency', # WebDAV
500 => 'Internal Server Error',
501 => 'Not Implemented',
502 => 'Bad Gateway',
503 => 'Service Unavailable',
504 => 'Gateway Timeout',
505 => 'HTTP Version Not Supported',
507 => 'Insufficient Storage', # WebDAV
);
my $mnemonicCode = '';
my ($code, $message);
while (($code, $message) = each %StatusCode) {
# create mnemonic subroutines
$message =~ tr/a-z \-/A-Z__/;
$mnemonicCode .= "sub RC_$message () { $code }\t";
# make them exportable
$mnemonicCode .= "push(\@EXPORT, 'RC_$message');\n";
}
# warn $mnemonicCode; # for development
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");
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;
if ($rc != RC_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:
RC_CONTINUE (100)
RC_SWITCHING_PROTOCOLS (101)
RC_PROCESSING (102)
RC_OK (200)
RC_CREATED (201)
RC_ACCEPTED (202)
RC_NON_AUTHORITATIVE_INFORMATION (203)
RC_NO_CONTENT (204)
RC_RESET_CONTENT (205)
RC_PARTIAL_CONTENT (206)
RC_MULTI_STATUS (207)
RC_MULTIPLE_CHOICES (300)
RC_MOVED_PERMANENTLY (301)
RC_FOUND (302)
RC_SEE_OTHER (303)
RC_NOT_MODIFIED (304)
RC_USE_PROXY (305)
RC_TEMPORARY_REDIRECT (307)
RC_BAD_REQUEST (400)
RC_UNAUTHORIZED (401)
RC_PAYMENT_REQUIRED (402)
RC_FORBIDDEN (403)
RC_NOT_FOUND (404)
RC_METHOD_NOT_ALLOWED (405)
RC_NOT_ACCEPTABLE (406)
RC_PROXY_AUTHENTICATION_REQUIRED (407)
RC_REQUEST_TIMEOUT (408)
RC_CONFLICT (409)
RC_GONE (410)
RC_LENGTH_REQUIRED (411)
RC_PRECONDITION_FAILED (412)
RC_REQUEST_ENTITY_TOO_LARGE (413)
RC_REQUEST_URI_TOO_LARGE (414)
RC_UNSUPPORTED_MEDIA_TYPE (415)
RC_REQUEST_RANGE_NOT_SATISFIABLE (416)
RC_EXPECTATION_FAILED (417)
RC_UNPROCESSABLE_ENTITY (422)
RC_LOCKED (423)
RC_FAILED_DEPENDENCY (424)
RC_INTERNAL_SERVER_ERROR (500)
RC_NOT_IMPLEMENTED (501)
RC_BAD_GATEWAY (502)
RC_SERVICE_UNAVAILABLE (503)
RC_GATEWAY_TIMEOUT (504)
RC_HTTP_VERSION_NOT_SUPPORTED (505)
RC_INSUFFICIENT_STORAGE (507)
=head1 FUNCTIONS
The following additional functions are provided. Most of them are
exported by default.
=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. 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.
=item is_redirect( $code )
Return TRUE if C<$code> is a I<Redirection> status code. This class of
status code indicates that further action needs to be taken by the
user agent in order to fulfill the request.
=item is_error( $code )
Return TRUE if C<$code> is an I<Error> status code. The function
return TRUE for both client error or a server error status codes.
=item is_client_error( $code )
Return TRUE if C<$code> is an I<Client Error> status code. This class
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. 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
Wished @EXPORT_OK had been used instead of @EXPORT in the beginning.
Now too much is exported by default.
libwww-perl-5.79/lib/HTTP/Cookies/ 0040755 0000764 0000764 00000000000 10036720346 015657 5 ustar gisle gisle libwww-perl-5.79/lib/HTTP/Cookies/Netscape.pm 0100644 0000764 0000764 00000005721 07746205052 017767 0 ustar gisle gisle package HTTP::Cookies::Netscape;
use strict;
use vars qw(@ISA $VERSION);
$VERSION = sprintf("%d.%02d", q$Revision: 1.26 $ =~ /(\d+)\.(\d+)/);
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;
LWP::Debug::debug("$file doesn't look like a netscape cookies file. Skipping.");
close(FILE);
return;
}
LWP::Debug::debug("Okay, $file is a netscape cookies file. Parsing.");
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/, $_);
LWP::Debug::debug(join '', "-Reading NS cookie: ",
map(" <$_>", 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;
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
libwww-perl-5.79/lib/HTTP/Cookies/Microsoft.pm 0100644 0000764 0000764 00000017757 07743317667 020223 0 ustar gisle gisle package HTTP::Cookies::Microsoft;
use strict;
use vars qw(@ISA $VERSION);
$VERSION = sprintf("%d.%02d", q$Revision: 1.7 $ =~ /(\d+)\.(\d+)/);
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;
}
}
if ($data =~ /Cookie\:$user_name\@([\x21-\xFF]+).*?($user_name\@[\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
libwww-perl-5.79/lib/HTTP/Request/ 0040755 0000764 0000764 00000000000 10036720346 015713 5 ustar gisle gisle libwww-perl-5.79/lib/HTTP/Request/Common.pm 0100644 0000764 0000764 00000030161 07746023744 017513 0 ustar gisle gisle # $Id: Common.pm,v 1.22 2003/10/23 19:11:32 uid39246 Exp $
#
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);
require HTTP::Request;
use Carp();
$VERSION = sprintf("%d.%02d", q$Revision: 1.22 $ =~ /(\d+)\.(\d+)/);
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 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 (lc($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);
while (($k,$v) = splice(@_, 0, 2)) {
if (lc($k) eq 'content') {
$req->add_content($v);
}
else {
$req->push_header($k, $v);
}
}
$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);
}
my $disp = qq(form-data; name="$k");
$disp .= qq(; filename="$usename") if $usename;
my $content = "";
my $h = HTTP::Headers->new(@headers);
my $ct = $h->header("Content-Type");
if ($file) {
require Symbol;
my $fh = Symbol::gensym();
open($fh, $file) or Carp::croak("Can't open file $file: $!");
binmode($fh);
if ($DYNAMIC_FILE_UPLOAD) {
# will read file later
$content = $fh;
}
else {
local($/) = undef; # slurp files
$content = <$fh>;
close($fh);
$h->header("Content-Length" => length($content));
}
unless ($ct) {
require LWP::MediaTypes;
$ct = 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 "" 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;
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 HTTP::Request
objects. These functions are usually more convenient to use than the
standard HTTP::Request constructor for these common requests. The
following functions are provided.
=over 4
=item GET $url, Header => Value,...
The GET() function returns a HTTP::Request object initialized with the
GET method and the specified URL. Without additional arguments it
is exactly equivalent to the following call
HTTP::Request->new(GET => $url)
but is less cluttered. It also reads better when used together with the
LWP::UserAgent->request() method:
my $ua = new LWP::UserAgent;
my $res = $ua->request(GET 'http://www.sn.no')
if ($res->is_success) { ...
You can also initialize header values in the request by specifying
some key/value pairs as optional arguments. For instance:
$ua->request(GET 'http://www.sn.no',
If_Match => 'foo',
From => 'gisle@aas.no',
);
A header key called 'Content' is special and when seen the value will
initialize the content part of the request instead of setting a header.
=item HEAD $url, [Header => Value,...]
Like GET() but the method in the request is HEAD.
=item PUT $url, [Header => Value,...]
Like GET() but the method in the request is PUT.
=item POST $url, [$form_ref], [Header => Value,...]
This works mostly like GET() with POST as the method, but this function
also takes a second optional array or hash reference parameter
($form_ref). This 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
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... ]
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. 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 don't want any filename in the request.
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>.
=back
=head1 SEE ALSO
L<HTTP::Request>, L<LWP::UserAgent>
=head1 COPYRIGHT
Copyright 1997-2000, Gisle Aas
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
libwww-perl-5.79/lib/HTTP/Headers/ 0040755 0000764 0000764 00000000000 10036720346 015636 5 ustar gisle gisle libwww-perl-5.79/lib/HTTP/Headers/Auth.pm 0100644 0000764 0000764 00000003770 07746023744 017115 0 ustar gisle gisle package HTTP::Headers::Auth;
use strict;
use vars qw($VERSION);
$VERSION = sprintf("%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/);
require 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, lc(shift @$_) => {});
shift @$_;
}
if (@ret) {
# this a new parameter pair for the last auth scheme
while (@$_) {
my $k = lc(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;
libwww-perl-5.79/lib/HTTP/Headers/ETag.pm 0100644 0000764 0000764 00000004266 07746023744 017035 0 ustar gisle gisle package HTTP::Headers::ETag;
use strict;
use vars qw($VERSION);
$VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/);
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;
libwww-perl-5.79/lib/HTTP/Headers/Util.pm 0100644 0000764 0000764 00000010641 07746023744 017124 0 ustar gisle gisle package HTTP::Headers::Util;
use strict;
use vars qw($VERSION @ISA @EXPORT_OK);
$VERSION = sprintf("%d.%02d", q$Revision: 1.13 $ =~ /(\d+)\.(\d+)/);
require Exporter;
@ISA=qw(Exporter);
@EXPORT_OK=qw(split_header_words join_header_words);
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 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\""]
=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.
libwww-perl-5.79/lib/HTTP/Request.pm 0100644 0000764 0000764 00000011646 10034755637 016267 0 ustar gisle gisle package HTTP::Request;
# $Id: Request.pm,v 1.40 2004/04/07 10:44:47 gisle Exp $
require HTTP::Message;
@ISA = qw(HTTP::Message);
$VERSION = sprintf("%d.%02d", q$Revision: 1.40 $ =~ /(\d+)\.(\d+)/);
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;
}
$old;
}
*url = \&uri; # legacy
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(@_));
}
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->content
=item $r->content( $content )
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.
libwww-perl-5.79/lib/HTTP/Response.pm 0100644 0000764 0000764 00000025623 10035603761 016424 0 ustar gisle gisle package HTTP::Response;
# $Id: Response.pm,v 1.49 2004/04/09 20:30:41 gisle Exp $
require HTTP::Message;
@ISA = qw(HTTP::Message);
$VERSION = sprintf("%d.%02d", q$Revision: 1.49 $ =~ /(\d+)\.(\d+)/);
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) = 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) || "?";
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
return $HTTP::URI_CLASS->new_abs($base, $self->request->uri);
# So yes, if $base is undef, the return value is effectively
# just a copy of $self->request->uri.
}
sub as_string
{
require HTTP::Status;
my $self = shift;
my($eol) = @_;
$eol = "\n" unless defined $eol;
my $code = $self->code;
my $status_message = HTTP::Status::status_message($code) || "Unknown code";
my $message = $self->message || "";
my $status_line = "$code";
my $proto = $self->protocol;
$status_line = "$proto $status_line" if $proto;
$status_line .= " ($status_message)" if $status_message ne $message;
$status_line .= " $message";
return join($eol, $status_line, $self->SUPER::as_string(@_));
}
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
{
my $self = shift;
my $title = 'An Error Occurred';
my $body = $self->status_line;
return <<EOM;
<HTML>
<HEAD><TITLE>$title</TITLE></HEAD>
<BODY>
<H1>$title</H1>
$body
</BODY>
</HTML>
EOM
}
sub current_age
{
my $self = 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
}
my $request = $self->request;
if ($request) {
my $request_time = $request->date;
if ($request_time) {
# Add response_delay to age to get 'corrected_initial_age'
$age += $response_time - $request_time;
}
}
if ($response_time) {
$age += time - $response_time;
}
return $age;
}
sub freshness_lifetime
{
my $self = shift;
# First look for the Cache-Control: max-age=n header
my @cc = $self->header('Cache-Control');
if (@cc) {
my $cc;
for $cc (@cc) {
my $cc_dir;
for $cc_dir (split(/\s*,\s*/, $cc)) {
if ($cc_dir =~ /max-age\s*=\s*(\d+)/i) {
return $1;
}
}
}
}
# Next possibility is to look at the "Expires" header
my $date = $self->date || $self->client_date || time;
my $expires = $self->expires;
unless ($expires) {
# Must apply heuristic expiration
my $last_modified = $self->last_modified;
if ($last_modified) {
my $h_exp = ($date - $last_modified) * 0.10; # 10% since last-mod
if ($h_exp < 60) {
return 60; # minimum
}
elsif ($h_exp > 24 * 3600) {
# Should give a warning if more than 24 hours according to
# RFC 2616 section 13.2.4, but I don't know how to do it
# from this function interface, so I just make this the
# maximum value.
return 24 * 3600;
}
return $h_exp;
}
else {
return 3600; # 1 hour is fallback when all else fails
}
}
return $expires - $date;
}
sub is_fresh
{
my $self = shift;
$self->freshness_lifetime > $self->current_age;
}
sub fresh_until
{
my $self = shift;
return $self->freshness_lifetime - $self->current_age + 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->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( $content )
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.
=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.
=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
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->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->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
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 a number representing the freshness lifetime in
seconds.
If the response does not contain an "Expires" or a "Cache-Control"
header, then this function will apply some simple heuristic based on
'Last-Modified' to determine a suitable lifetime.
=item $r->is_fresh
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 refetched or revalidated by the origin
server.
=item $r->fresh_until
Returns the time when this entity is no longer fresh.
=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.
libwww-perl-5.79/lib/HTTP/Date.pm 0100644 0000764 0000764 00000024770 07746023744 015521 0 ustar gisle gisle package HTTP::Date; # $Date: 2003/10/23 19:11:32 $
$VERSION = sprintf("%d.%02d", q$Revision: 1.46 $ =~ /(\d+)\.(\d+)/);
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-1900);
$t < 0 ? undef : $t;
};
}
my @d = parse_date($str);
return undef unless @d;
$d[0] -= 1900; # year
$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, 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, or the time is outside
the representable range. 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
libwww-perl-5.79/lib/HTTP/Daemon.pm 0100644 0000764 0000764 00000053066 10035602727 016034 0 ustar gisle gisle package HTTP::Daemon;
# $Id: Daemon.pm,v 1.35 2004/04/09 20:21:43 gisle Exp $
use strict;
use vars qw($VERSION @ISA $PROTO $DEBUG);
$VERSION = sprintf("%d.%02d", q$Revision: 1.35 $ =~ /(\d+)\.(\d+)/);
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 = "http://";
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 != 80;
$url .= "/";
$url;
}
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);
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');
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 ($ct && lc($ct) =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*(\w+)/) {
# Handle multipart content type
my $boundary = "$CRLF--$1--$CRLF";
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) = '';
}
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='';
}
}
${*$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 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_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;
}
print $self $res->headers_as_string($CRLF);
print $self $CRLF; # separates headers and content
}
if (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->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;
$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);
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->url->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 read 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 return 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->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_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.
libwww-perl-5.79/lib/HTTP/Message.pm 0100644 0000764 0000764 00000031012 10035541423 016173 0 ustar gisle gisle package HTTP::Message;
# $Id: Message.pm,v 1.42 2004/04/09 15:07:04 gisle Exp $
use strict;
use vars qw($VERSION $AUTOLOAD);
$VERSION = sprintf("%d.%02d", q$Revision: 1.42 $ =~ /(\d+)\.(\d+)/);
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 $@;
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;
}
$content = '' unless defined $content;
bless {
'_headers' => $header,
'_content' => $content,
}, $class;
}
sub parse
{
my($class, $str) = @_;
my @hdr;
while (1) {
if ($str =~ s/^([^ \t:]+)[ \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;
}
}
new($class, \@hdr, $str);
}
sub clone
{
my $self = shift;
my $clone = HTTP::Message->new($self->headers,
$self->content);
$clone;
}
sub clear {
my $self = shift;
$self->{_headers}->clear;
$self->{_content} = "";
delete $self->{_parts};
return;
}
sub protocol { shift->_elem('_protocol', @_); }
sub content {
my $self = shift;
if (defined(wantarray) && !exists $self->{_content}) {
$self->_content;
}
my $old = $self->{_content};
if (@_) {
$self->{_content} = shift;
delete $self->{_parts};
}
$old;
}
sub add_content
{
my $self = shift;
$self->_content unless exists $self->{_content};
if (ref($_[0])) {
$self->{'_content'} .= ${$_[0]}; # for backwards compatability
}
else {
$self->{'_content'} .= $_[0];
}
delete $self->{_parts};
}
sub content_ref
{
my $self = shift;
$self->_content unless exists $self->{_content};
delete $self->{_parts};
\$self->{'_content'};
}
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 headers { shift->{'_headers'}; }
sub headers_as_string { shift->{'_headers'}->as_string(@_); }
sub parts {
my $self = shift;
if (defined(wantarray) && !exists $self->{_parts}) {
$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;
delete $self->{_content};
}
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} = [$p];
}
elsif (!exists $self->{_parts}) {
$self->_parts;
}
push(@{$self->{_parts}}, @_);
delete $self->{_content};
return;
}
# delegate all other method calls the the _headers object.
sub AUTOLOAD
{
my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
return if $method eq "DESTROY";
# We create the function here so that it will not need to be
# autoloaded the next time.
no strict 'refs';
*$method = eval "sub { shift->{'_headers'}->$method(\@_) }";
goto &$method;
}
# 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 $class = ($self->{_content} =~ m,^(HTTP/.*)\n,) ?
"HTTP::Response" : "HTTP::Request";
$self->{_parts} = [$class->parse($self->{_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->header("Content-Type") || "multipart/mixed";
if ($ct =~ m,^\s*message/,i) {
$self->{_content} = $self->{_parts}[0]->as_string($CRLF);
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 (lc($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->header("Content-Type", $ct);
$self->{_content} = "--$boundary$CRLF" .
join("$CRLF--$boundary$CRLF", @parts) .
"$CRLF--$boundary--$CRLF";
}
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( $content )
The content() method sets the content if an argument is given. If no
argument is given the content is not touched. In either case the
original 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( $data )
The add_content() methods appends more data to the end of the current
content buffer.
=item $mess->content_ref
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.
=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
are 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
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.
=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.
libwww-perl-5.79/lib/HTTP/Negotiate.pm 0100644 0000764 0000764 00000037562 10035541423 016546 0 ustar gisle gisle # $Id: Negotiate.pm,v 1.15 2004/04/09 15:07:04 gisle Exp $
#
package HTTP::Negotiate;
$VERSION = sprintf("%d.%02d", q$Revision: 1.15 $ =~ /(\d+)\.(\d+)/);
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 envirionment variables
$request = new HTTP::Headers;
$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 calcualtions
# 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 assignes Content-Encoding, or if no
# Accept-Encoding field is present, then the value assigned
# is "qe=1". If *all* of the variant's content encoddings
# 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 not 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 maximus of the "q" paramet values for thos 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 (substr($lang, 0, 1 + length($al)) eq "$al-") {
# $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 " -- $lang ISA $al\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],
];
@prefered = 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
libwww-perl-5.79/lib/HTTP/Headers.pm 0100644 0000764 0000764 00000050322 10036066502 016170 0 ustar gisle gisle package HTTP::Headers;
# $Id: Headers.pm,v 1.59 2004/04/10 21:55:14 gisle Exp $
use strict;
use Carp ();
use vars qw($VERSION $TRANSLATE_UNDERSCORE);
$VERSION = sprintf("%d.%02d", q$Revision: 1.59 $ =~ /(\d+)\.(\d+)/);
# 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);
while (my($field, $val) = splice(@_, 0, 2)) {
@old = $self->_header($field, $val);
}
return @old if wantarray;
return $old[0] if @old <= 1;
join(", ", @old);
}
sub clear
{
my $self = shift;
%$self = ();
}
sub push_header
{
Carp::croak('Usage: $h->push_header($field, $val)') if @_ != 3;
shift->_header(@_, 'PUSH');
}
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 $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) = @_;
$field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE;
# $push is only used interally sub push_header
Carp::croak('Need a field name') unless length($field);
my $lc_field = lc $field;
unless(defined $standard_case{$lc_field}) {
# generate a %standard_case entry for this field
$field =~ s/\b(\w)/\u$1/g;
$standard_case{$lc_field} = $field;
}
my $h = $self->{$lc_field};
my @old = ref($h) eq 'ARRAY' ? @$h : (defined($h) ? ($h) : ());
$op ||= "";
$val = undef if $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->{$lc_field} = @new > 1 ? \@new : $new[0];
}
@old;
}
# Compare function which makes it easy to sort headers in the
# recommended "Good Practice" order.
sub _header_cmp
{
($header_order{$a} || 999) <=> ($header_order{$b} || 999) || $a cmp $b;
}
sub header_field_names {
my $self = shift;
return map $standard_case{$_}, sort _header_cmp keys %$self
if wantarray;
return keys %$self;
}
sub scan
{
my($self, $sub) = @_;
my $key;
foreach $key (sort _header_cmp keys %$self) {
next if $key =~ /^_/;
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 = ();
$self->scan(sub {
my($field, $val) = @_;
if ($val =~ /\n/) {
# must handle header values with embedded newlines with care
$val =~ s/\s+$//; # trailing newlines and space must go
$val =~ s/\n\n+/\n/g; # no empty lines
$val =~ s/\n([^\040\t])/\n $1/g; # intial space for continuation
$val =~ s/\n/$endl/g; # substitute with requested line ending
}
push(@result, "$field: $val");
});
join($endl, @result, '');
}
sub clone
{
my $self = shift;
my $clone = new HTTP::Headers;
$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));
}
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 extention. 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 $ct = (shift->_header('Content-Type', @_))[0];
return '' unless defined($ct) && length($ct);
my @ct = split(/;\s*/, $ct, 2);
for ($ct[0]) {
s/\s+//g;
$_ = lc($_);
}
wantarray ? @ct : $ct[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.
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, ... )
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 (this behaviour can be
suppressed by setting the $HTTP::Headers::TRANSLATE_UNDERSCORE
variable to a FALSE value).
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 undefined or 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 )
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-> falls
into this category, as well as C<Allow>, C<Expires> and
C<Last-Modified>. RFC 2616 denote 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. 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_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/1.2');
=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 BUGS
In the argument list to the constructor or header() method, the same
field name should not occur multiple times. The result of doing so,
it that only the last of these fields will be present in the header
after the call. All values ought to be kept.
Passing a value of C<undef> to header() or any of the convenience
methods, does not delete that field. It ought to do that.
=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.
libwww-perl-5.79/lib/LWP/ 0040755 0000764 0000764 00000000000 10036720346 014146 5 ustar gisle gisle libwww-perl-5.79/lib/LWP/Protocol/ 0040755 0000764 0000764 00000000000 10036720346 015747 5 ustar gisle gisle libwww-perl-5.79/lib/LWP/Protocol/nntp.pm 0100644 0000764 0000764 00000007255 07746023745 017307 0 ustar gisle gisle #
# $Id: nntp.pm,v 1.9 2003/10/23 19:11:33 uid39246 Exp $
# Implementation of the Network News Transfer Protocol (RFC 977)
#
package LWP::Protocol::nntp;
require LWP::Protocol;
@ISA = qw(LWP::Protocol);
require LWP::Debug;
require HTTP::Response;
require HTTP::Status;
require Net::NNTP;
use strict;
sub request
{
my($self, $request, $proxy, $arg, $size, $timeout) = @_;
LWP::Debug::trac
