r11053 - in /branches/upstream/libwww-perl/current: ./ bin/ lib/ lib/HTTP/ lib/HTTP/Request/ lib/LWP/ lib/LWP/Protocol/ lib/Net/ t/base/ t/live/ t/local/
tincho-guest at users.alioth.debian.org
tincho-guest at users.alioth.debian.org
Sun Dec 9 09:21:05 UTC 2007
Author: tincho-guest
Date: Sun Dec 9 09:21:04 2007
New Revision: 11053
URL: http://svn.debian.org/wsvn/?sc=1&rev=11053
Log:
[svn-upgrade] Integrating new upstream version, libwww-perl (5.808)
Added:
branches/upstream/libwww-perl/current/t/live/apache.t
branches/upstream/libwww-perl/current/t/local/chunked.t
Removed:
branches/upstream/libwww-perl/current/t/live/activestate.t
branches/upstream/libwww-perl/current/t/live/validator.t
Modified:
branches/upstream/libwww-perl/current/Changes
branches/upstream/libwww-perl/current/MANIFEST
branches/upstream/libwww-perl/current/Makefile.PL
branches/upstream/libwww-perl/current/bin/lwp-download
branches/upstream/libwww-perl/current/bin/lwp-request
branches/upstream/libwww-perl/current/lib/HTTP/Daemon.pm
branches/upstream/libwww-perl/current/lib/HTTP/Request/Common.pm
branches/upstream/libwww-perl/current/lib/LWP.pm
branches/upstream/libwww-perl/current/lib/LWP/MediaTypes.pm
branches/upstream/libwww-perl/current/lib/LWP/Protocol.pm
branches/upstream/libwww-perl/current/lib/LWP/Protocol/https10.pm
branches/upstream/libwww-perl/current/lib/LWP/Protocol/nntp.pm
branches/upstream/libwww-perl/current/lib/LWP/UserAgent.pm
branches/upstream/libwww-perl/current/lib/Net/HTTPS.pm
branches/upstream/libwww-perl/current/t/base/message.t
branches/upstream/libwww-perl/current/t/local/http-get.t
branches/upstream/libwww-perl/current/talk-to-ourself
Modified: branches/upstream/libwww-perl/current/Changes
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/Changes?rev=11053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/Changes (original)
+++ branches/upstream/libwww-perl/current/Changes Sun Dec 9 09:21:04 2007
@@ -1,3 +1,60 @@
+2007-08-05 Gisle Aas <gisle at ActiveState.com>
+
+ Release 5.808
+
+ Get rid of t/live/validator test. Too much JavaScript madness
+ for it to be a sane LWP test.
+
+
+
+2007-07-31 Gisle Aas <gisle at ActiveState.com>
+
+ Release 5.807
+
+ Apply patch correction from CPAN RT #26152
+
+ More laxed t/live/validator test.
+
+
+
+2007-07-19 Gisle Aas <gisle at ActiveState.com>
+
+ Release 5.806
+
+ Added progress callback to LWP::UserAgent.
+
+ HTTP::Daemon didn't avoid content in responses to HEAD requests
+
+ Add support for HTTP Expect header to HTTP::Daemon (CPAN RT #27933)
+
+ Fix t/base/message.t so tests are skipped if Encode is not
+ installed. (CPAN RT #25286)
+
+ Add HTML::Tagset as a prerequisite to Makefile.PL
+
+ Do not clobber $_ in LWP::Protocol::nntp (CPAN RT #25132)
+
+ Fix lwp-download so it can download files with an "_" in the filename
+ (CPAN RT#26207)
+
+ Quiet complaints from HTML::HeadParser when dealing with undecoded
+ UTF-8 data. (CPAN RT#20274)
+
+ When both IO::Socket::SSL and Net::SSL are loaded, use the latter
+ (CPAN RT #26152)
+
+ Allows SSL to work much more reliably:
+ (CPAN RT #23372)
+
+ Allow text/vnd.wap.wml and application/vnd.oasis.opendocument.text
+ in content-type field in lwp-request (CPAN RT #26151)
+
+ Add default media type for XML in LWP::MediaTypes (CPAN RT #21093)
+
+ Added chunked test by Andreas J. Koenig
+
+
+
2005-12-08 Gisle Aas <gisle at ActiveState.com>
Release 5.805
Modified: branches/upstream/libwww-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/MANIFEST?rev=11053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/MANIFEST (original)
+++ branches/upstream/libwww-perl/current/MANIFEST Sun Dec 9 09:21:04 2007
@@ -85,7 +85,7 @@
t/base/ua.t Basic LWP::UserAgent tests
t/html/form.t Test HTML::Form module
t/html/form-param.t More HTML::Form tests.
-t/live/activestate.t
+t/live/apache.t
t/live/apache-listing.t Test File::Listing::apache package
t/live/jigsaw-auth-b.t
t/live/jigsaw-auth-d.t
@@ -95,9 +95,9 @@
t/live/jigsaw-neg-get.t
t/live/jigsaw-neg.t
t/live/jigsaw-te.t
-t/live/validator.t
t/local/autoload-get.t
t/local/autoload.t Test autoloading of LWP::Protocol modules
+t/local/chunked.t
t/local/get.t Try to get a local file
t/local/http-get.t
t/local/http.t Test http to local server
Modified: branches/upstream/libwww-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/Makefile.PL?rev=11053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/Makefile.PL (original)
+++ branches/upstream/libwww-perl/current/Makefile.PL Sun Dec 9 09:21:04 2007
@@ -1,5 +1,5 @@
# This -*- perl -*- script writes the Makefile for libwww-perl
-# $Id: Makefile.PL,v 1.76 2005/11/03 17:26:39 gisle Exp $
+# $Id: Makefile.PL,v 1.77 2007/07/19 20:26:10 gisle Exp $
require 5.005;
use strict;
@@ -272,6 +272,7 @@
PREREQ_PM => { 'URI' => "1.10",
'MIME::Base64' => "2.1",
'Net::FTP' => "2.58",
+ 'HTML::Tagset' => 0,
'HTML::Parser' => "3.33",
'Digest::MD5' => 0,
'Compress::Zlib' => "1.10",
Modified: branches/upstream/libwww-perl/current/bin/lwp-download
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/bin/lwp-download?rev=11053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/bin/lwp-download (original)
+++ branches/upstream/libwww-perl/current/bin/lwp-download Sun Dec 9 09:21:04 2007
@@ -1,6 +1,6 @@
#!/usr/bin/perl -w
-# $Id: lwp-download,v 2.15 2004/12/11 14:02:59 gisle Exp $
+# $Id: lwp-download,v 2.16 2007/07/19 20:26:11 gisle Exp $
=head1 NAME
@@ -75,7 +75,7 @@
my $url = URI->new(shift || usage());
my $argfile = shift;
usage() if defined($argfile) && !length($argfile);
-my $version = q$Revision: 2.15 $;
+my $version = q$Revision: 2.16 $;
$version =~ s/[^\d.]//g;
my $ua = LWP::UserAgent->new(
@@ -150,7 +150,7 @@
# validate that we don't have a harmful filename now. The server
# might try to trick us into doing something bad.
if (!length($file) ||
- $file =~ s/([^a-zA-Z0-9\.\-\+\~])/sprintf "\\x%02x", ord($1)/ge)
+ $file =~ s/([^a-zA-Z0-9_\.\-\+\~])/sprintf "\\x%02x", ord($1)/ge)
{
die "Will not save <$url> as \"$file\".\nPlease override file name on the command line.\n";
}
Modified: branches/upstream/libwww-perl/current/bin/lwp-request
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/bin/lwp-request?rev=11053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/bin/lwp-request (original)
+++ branches/upstream/libwww-perl/current/bin/lwp-request Sun Dec 9 09:21:04 2007
@@ -1,6 +1,6 @@
#!/usr/bin/perl -w
-# $Id: lwp-request,v 2.7 2005/12/06 12:16:28 gisle Exp $
+# $Id: lwp-request,v 2.8 2007/07/19 20:26:11 gisle Exp $
#
# Simple user agent using LWP library.
@@ -182,7 +182,7 @@
$progname =~ s,.*[\\/],,; # use basename only
$progname =~ s/\.\w*$//; # strip extension, if any
-$VERSION = sprintf("%d.%02d", q$Revision: 2.7 $ =~ /(\d+)\.(\d+)/);
+$VERSION = sprintf("%d.%02d", q$Revision: 2.8 $ =~ /(\d+)\.(\d+)/);
require LWP;
@@ -366,7 +366,7 @@
}
else {
die "$progname: Illegal Content-type format\n"
- unless $options{'c'} =~ m,^[\w\-]+/[\w\-]+(?:\s*;.*)?$,
+ unless $options{'c'} =~ m,^[\w\-]+/[\w\-.+]+(?:\s*;.*)?$,
}
print "Please enter content ($options{'c'}) to be ${method}ed:\n"
if -t;
Modified: branches/upstream/libwww-perl/current/lib/HTTP/Daemon.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/lib/HTTP/Daemon.pm?rev=11053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/HTTP/Daemon.pm (original)
+++ branches/upstream/libwww-perl/current/lib/HTTP/Daemon.pm Sun Dec 9 09:21:04 2007
@@ -1,11 +1,11 @@
package HTTP::Daemon;
-# $Id: Daemon.pm,v 1.36 2004/12/11 14:13:16 gisle Exp $
+# $Id: Daemon.pm,v 1.39 2007/07/19 21:24:31 gisle Exp $
use strict;
use vars qw($VERSION @ISA $PROTO $DEBUG);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.36 $ =~ /(\d+)\.(\d+)/);
+$VERSION = sprintf("%d.%02d", q$Revision: 1.39 $ =~ /(\d+)\.(\d+)/);
use IO::Socket qw(AF_INET INADDR_ANY inet_ntoa);
@ISA=qw(IO::Socket::INET);
@@ -150,6 +150,7 @@
my $r = HTTP::Request->new($method, $uri);
$r->protocol($proto);
${*$self}{'httpd_client_proto'} = $proto = _http_version($proto);
+ ${*$self}{'httpd_head'} = ($method eq "HEAD");
if ($proto >= $HTTP_1_0) {
# we expect to find some headers
@@ -190,6 +191,18 @@
my $te = $r->header('Transfer-Encoding');
my $ct = $r->header('Content-Type');
my $len = $r->header('Content-Length');
+
+ # Act on the Expect header, if it's there
+ for my $e ( $r->header('Expect') ) {
+ if( lc($e) eq '100-continue' ) {
+ $self->send_status_line(100);
+ }
+ else {
+ $self->send_error(417);
+ $self->reason("Unsupported Expect header value");
+ return;
+ }
+ }
if ($te && lc($te) eq 'chunked') {
# Handle chunked transfer encoding
@@ -375,6 +388,12 @@
${*$self}{'httpd_nomore'}++;
}
+sub head_request
+{
+ my $self = shift;
+ ${*$self}{'httpd_head'};
+}
+
sub send_status_line
{
@@ -440,11 +459,15 @@
}
else {
$self->force_last_request;
+ $res->header('connection','close');
}
print $self $res->headers_as_string($CRLF);
print $self $CRLF; # separates headers and content
}
- if (ref($content) eq "CODE") {
+ if ($self->head_request) {
+ # no content
+ }
+ elsif (ref($content) eq "CODE") {
while (1) {
my $chunk = &$content();
last unless defined($chunk) && length($chunk);
@@ -478,7 +501,7 @@
print $self "Content-Type: $ct$CRLF";
}
print $self $CRLF;
- print $self $content if $content;
+ print $self $content if $content && !$self->head_request;
$self->force_last_request; # no use keeping the connection open
}
@@ -501,7 +524,7 @@
print $self "Content-Length: " . length($mess) . $CRLF;
print $self $CRLF;
}
- print $self $mess;
+ print $self $mess unless $self->head_request;
$status;
}
@@ -528,7 +551,7 @@
print $self "Last-Modified: ", time2str($mtime), "$CRLF" if $mtime;
print $self $CRLF;
}
- $self->send_file(\*F);
+ $self->send_file(\*F) unless $self->head_request;
return RC_OK;
}
else {
@@ -748,6 +771,11 @@
code and no headers should be returned to such a client. This should
be the same as !$c->proto_ge("HTTP/1.0").
+=item $c->head_request
+
+Return TRUE if the last request was a C<HEAD> request. No content
+body must be generated for these requests.
+
=item $c->force_last_request
Make sure that $c->get_request will not try to read more requests off
Modified: branches/upstream/libwww-perl/current/lib/HTTP/Request/Common.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/lib/HTTP/Request/Common.pm?rev=11053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/HTTP/Request/Common.pm (original)
+++ branches/upstream/libwww-perl/current/lib/HTTP/Request/Common.pm Sun Dec 9 09:21:04 2007
@@ -1,4 +1,4 @@
-# $Id: Common.pm,v 1.26 2004/11/15 14:52:37 gisle Exp $
+# $Id: Common.pm,v 1.28 2007/07/19 20:46:48 gisle Exp $
#
package HTTP::Request::Common;
@@ -15,7 +15,7 @@
require HTTP::Request;
use Carp();
-$VERSION = sprintf("%d.%02d", q$Revision: 1.26 $ =~ /(\d+)\.(\d+)/);
+$VERSION = sprintf("%d.%02d", q$Revision: 1.28 $ =~ /(\d+)\.(\d+)/);
my $CRLF = "\015\012"; # "\r\n" is not portable
@@ -343,6 +343,12 @@
Like GET() but the method in the request is "PUT".
+The content of the request can be specified using the "Content"
+pseudo-header. This steals a bit of the header field namespace as
+there is no way to directly specify a header that is actually called
+"Content". If you really need this you must update the request
+returned in a separate statement.
+
=item POST $url
=item POST $url, Header => Value,...
@@ -351,10 +357,16 @@
=item POST $url, Header => Value,..., Content => $form_ref
-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
+=item POST $url, Header => Value,..., Content => $content
+
+This works mostly like PUT() with "POST" as the method, but this
+function also takes a second optional array or hash reference
+parameter $form_ref. As for PUT() the content can also be specified
+directly using the "Content" pseudo-header, and you may also provide
+the $form_ref this way.
+
+The $form_ref argument can be used to pass key/value pairs for the
+form content. By default we will initialize a request using the
C<application/x-www-form-urlencoded> content type. This means that
you can emulate a HTML E<lt>form> POSTing like this:
@@ -422,24 +434,24 @@
--6G+f
Content-Disposition: form-data; name="name"
-
+
Gisle Aas
--6G+f
Content-Disposition: form-data; name="email"
-
+
gisle at 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
Modified: branches/upstream/libwww-perl/current/lib/LWP.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/lib/LWP.pm?rev=11053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/LWP.pm (original)
+++ branches/upstream/libwww-perl/current/lib/LWP.pm Sun Dec 9 09:21:04 2007
@@ -1,9 +1,9 @@
#
-# $Id: LWP.pm,v 1.149 2005/12/08 12:06:22 gisle Exp $
+# $Id: LWP.pm,v 1.152 2007/08/05 13:23:32 gisle Exp $
package LWP;
-$VERSION = "5.805";
+$VERSION = "5.808";
sub Version { $VERSION; }
require 5.005;
Modified: branches/upstream/libwww-perl/current/lib/LWP/MediaTypes.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/lib/LWP/MediaTypes.pm?rev=11053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/LWP/MediaTypes.pm (original)
+++ branches/upstream/libwww-perl/current/lib/LWP/MediaTypes.pm Sun Dec 9 09:21:04 2007
@@ -1,12 +1,12 @@
package LWP::MediaTypes;
-# $Id: MediaTypes.pm,v 1.32 2004/11/17 11:04:09 gisle Exp $
+# $Id: MediaTypes.pm,v 1.33 2007/07/19 20:26:11 gisle Exp $
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(guess_media_type media_suffix);
@EXPORT_OK = qw(add_type add_encoding read_media_types);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.32 $ =~ /(\d+)\.(\d+)/);
+$VERSION = sprintf("%d.%02d", q$Revision: 1.33 $ =~ /(\d+)\.(\d+)/);
require LWP::Debug;
use strict;
@@ -19,6 +19,7 @@
'html' => 'text/html',
'gif' => 'image/gif',
'jpg' => 'image/jpeg',
+ 'xml' => 'text/xml',
);
my %suffixExt = (
@@ -26,6 +27,7 @@
'text/html' => 'html',
'image/gif' => 'gif',
'image/jpeg' => 'jpg',
+ 'text/xml' => 'xml',
);
#XXX: there should be some way to define this in the media.types files.
Modified: branches/upstream/libwww-perl/current/lib/LWP/Protocol.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/lib/LWP/Protocol.pm?rev=11053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/LWP/Protocol.pm (original)
+++ branches/upstream/libwww-perl/current/lib/LWP/Protocol.pm Sun Dec 9 09:21:04 2007
@@ -1,10 +1,10 @@
package LWP::Protocol;
-# $Id: Protocol.pm,v 1.43 2004/11/12 13:34:10 gisle Exp $
+# $Id: Protocol.pm,v 1.46 2007/07/19 20:26:11 gisle Exp $
require LWP::MemberMixin;
@ISA = qw(LWP::MemberMixin);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.43 $ =~ /(\d+)\.(\d+)/);
+$VERSION = sprintf("%d.%02d", q$Revision: 1.46 $ =~ /(\d+)\.(\d+)/);
use strict;
use Carp ();
@@ -98,14 +98,16 @@
{
my ($self, $arg, $response, $collector) = @_;
my $content;
- my($parse_head, $max_size) = @{$self}{qw(parse_head max_size)};
+ my($ua, $parse_head, $max_size) = @{$self}{qw(ua parse_head max_size)};
my $parser;
if ($parse_head && $response->content_type eq 'text/html') {
require HTML::HeadParser;
$parser = HTML::HeadParser->new($response->{'_headers'});
+ $parser->utf8_mode(1) if $] >= 5.008 && $HTML::Parser::VERSION >= 3.40;
}
my $content_size = 0;
+ my $length = $response->content_length;
if (!defined($arg) || !$response->is_success) {
# scalar
@@ -116,11 +118,10 @@
LWP::Debug::debug("read " . length($$content) . " bytes");
$response->add_content($$content);
$content_size += length($$content);
+ $ua->progress(($length ? ($content_size / $length) : "tick"), $response);
if (defined($max_size) && $content_size > $max_size) {
LWP::Debug::debug("Aborting because size limit exceeded");
$response->push_header("Client-Aborted", "max_size");
- #my $tot = $response->header("Content-Length") || 0;
- #$response->header("X-Content-Range", "bytes 0-$content_size/$tot");
last;
}
}
@@ -139,11 +140,10 @@
LWP::Debug::debug("read " . length($$content) . " bytes");
print OUT $$content or die "Can't write to '$arg': $!";
$content_size += length($$content);
+ $ua->progress(($length ? ($content_size / $length) : "tick"), $response);
if (defined($max_size) && $content_size > $max_size) {
LWP::Debug::debug("Aborting because size limit exceeded");
$response->push_header("Client-Aborted", "max_size");
- #my $tot = $response->header("Content-Length") || 0;
- #$response->header("X-Content-Range", "bytes 0-$content_size/$tot");
last;
}
}
@@ -165,6 +165,8 @@
$response->push_header("Client-Aborted", "die");
last;
}
+ $content_size += length($$content);
+ $ua->progress(($length ? ($content_size / $length) : "tick"), $response);
}
}
else {
Modified: branches/upstream/libwww-perl/current/lib/LWP/Protocol/https10.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/lib/LWP/Protocol/https10.pm?rev=11053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/LWP/Protocol/https10.pm (original)
+++ branches/upstream/libwww-perl/current/lib/LWP/Protocol/https10.pm Sun Dec 9 09:21:04 2007
@@ -1,5 +1,5 @@
#
-# $Id: https10.pm,v 1.2 2003/10/23 19:11:33 uid39246 Exp $
+# $Id: https10.pm,v 1.4 2007/07/20 06:16:58 gisle Exp $
use strict;
@@ -7,7 +7,10 @@
# Figure out which SSL implementation to use
use vars qw($SSL_CLASS);
-if ($IO::Socket::SSL::VERSION) {
+if ($Net::SSL::VERSION) {
+ $SSL_CLASS = "Net::SSL";
+}
+elsif ($IO::Socket::SSL::VERSION) {
$SSL_CLASS = "IO::Socket::SSL"; # it was already loaded
}
else {
Modified: branches/upstream/libwww-perl/current/lib/LWP/Protocol/nntp.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/lib/LWP/Protocol/nntp.pm?rev=11053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/LWP/Protocol/nntp.pm (original)
+++ branches/upstream/libwww-perl/current/lib/LWP/Protocol/nntp.pm Sun Dec 9 09:21:04 2007
@@ -1,5 +1,5 @@
#
-# $Id: nntp.pm,v 1.10 2005/10/31 15:10:33 gisle Exp $
+# $Id: nntp.pm,v 1.11 2007/07/19 20:26:11 gisle Exp $
# Implementation of the Network News Transfer Protocol (RFC 977)
#
@@ -116,6 +116,7 @@
# Parse headers
my($key, $val);
+ local $_;
while ($_ = shift @$art) {
if (/^\s+$/) {
last; # end of headers
Modified: branches/upstream/libwww-perl/current/lib/LWP/UserAgent.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/lib/LWP/UserAgent.pm?rev=11053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/LWP/UserAgent.pm (original)
+++ branches/upstream/libwww-perl/current/lib/LWP/UserAgent.pm Sun Dec 9 09:21:04 2007
@@ -1,13 +1,13 @@
package LWP::UserAgent;
-# $Id: UserAgent.pm,v 2.33 2004/09/16 09:28:22 gisle Exp $
+# $Id: UserAgent.pm,v 2.36 2006/06/05 08:36:37 gisle Exp $
use strict;
use vars qw(@ISA $VERSION);
require LWP::MemberMixin;
@ISA = qw(LWP::MemberMixin);
-$VERSION = sprintf("%d.%03d", q$Revision: 2.33 $ =~ /(\d+)\.(\d+)/);
+$VERSION = sprintf("%d.%03d", q$Revision: 2.36 $ =~ /(\d+)\.(\d+)/);
use HTTP::Request ();
use HTTP::Response ();
@@ -209,6 +209,7 @@
@{$self}{qw(timeout cookie_jar use_eval parse_head max_size)};
my $response;
+ $self->progress("begin");
if ($use_eval) {
# we eval, and turn dies into responses below
eval {
@@ -231,6 +232,8 @@
$response->request($request); # record request for reference
$cookie_jar->extract_cookies($response) if $cookie_jar;
$response->header("Client-Date" => HTTP::Date::time2str(time));
+
+ $self->progress("end", $response);
return $response;
}
@@ -423,7 +426,7 @@
sub post {
require HTTP::Request::Common;
my($self, @parameters) = @_;
- my @suff = $self->_process_colonic_headers(\@parameters,2);
+ my @suff = $self->_process_colonic_headers(\@parameters, (ref($parameters[1]) ? 2 : 1));
return $self->request( HTTP::Request::Common::POST( @parameters ), @suff );
}
@@ -483,6 +486,11 @@
return unless defined $arg;
return $arg, $size if defined $size;
return $arg;
+}
+
+sub progress {
+ my($self, $status, $response) = @_;
+ # subclasses might override this
}
@@ -1210,6 +1218,12 @@
=item $ua->post( $url, \%form, $field_name => $value, ... )
+=item $ua->post( $url, $field_name => $value,... Content => \%form )
+
+=item $ua->post( $url, $field_name => $value,... Content => \@form )
+
+=item $ua->post( $url, $field_name => $value,... Content => $content )
+
This method will dispatch a C<POST> request on the given $url, with
%form or @form providing the key/value pairs for the fill-in form
content. Additional headers and content options are the same as for
@@ -1339,6 +1353,15 @@
The base implementation simply checks a set of pre-stored member
variables, set up with the credentials() method.
+=item $ua->progress( $status, $response )
+
+This is called frequently as the response is received regardless of
+how the content is processed. The method is called with $status
+"begin" at the start of processing the request and with $state "end"
+before the request method returns. In between these $status will be
+the fraction of the response currently received or the string "tick"
+if the fraction can't be calculated.
+
=back
=head1 SEE ALSO
Modified: branches/upstream/libwww-perl/current/lib/Net/HTTPS.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/lib/Net/HTTPS.pm?rev=11053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/Net/HTTPS.pm (original)
+++ branches/upstream/libwww-perl/current/lib/Net/HTTPS.pm Sun Dec 9 09:21:04 2007
@@ -1,6 +1,6 @@
package Net::HTTPS;
-# $Id: HTTPS.pm,v 1.3 2002/12/23 18:16:29 gisle Exp $
+# $Id: HTTPS.pm,v 1.4 2007/07/19 20:26:11 gisle Exp $
use strict;
use vars qw($VERSION $SSL_SOCKET_CLASS @ISA);
@@ -8,7 +8,10 @@
$VERSION = "1.00";
# Figure out which SSL implementation to use
-if ($IO::Socket::SSL::VERSION) {
+if ($Net::SSL::VERSION) {
+ $SSL_SOCKET_CLASS = "Net::SSL";
+}
+elsif ($IO::Socket::SSL::VERSION) {
$SSL_SOCKET_CLASS = "IO::Socket::SSL"; # it was already loaded
}
else {
Modified: branches/upstream/libwww-perl/current/t/base/message.t
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/t/base/message.t?rev=11053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/t/base/message.t (original)
+++ branches/upstream/libwww-perl/current/t/base/message.t Sun Dec 9 09:21:04 2007
@@ -6,6 +6,7 @@
plan tests => 95;
require HTTP::Message;
+require Config;
my($m, $m2, @parts);
@@ -339,7 +340,8 @@
$m->content("H4sICFWAq0ECA3h4eAB7v3u/R6ZCSUZqUarCoxm7uAAZKHXiEAAAAA==\n");
$@ = "";
-skip($] < 5.008 ? "No Encode module" : "",
+skip($] < 5.008 || ($Config::Config{'extensions'} !~ /\bEncode\b/)
+ ? "No Encode module" : "",
sub { eval { $m->decoded_content } }, "\x{FEFF}Hi there \x{263A}\n");
ok($@ || "", "");
ok($m->content, "H4sICFWAq0ECA3h4eAB7v3u/R6ZCSUZqUarCoxm7uAAZKHXiEAAAAA==\n");
@@ -348,7 +350,8 @@
$m->content($tmp);
$m->header("Content-Encoding", "gzip");
$@ = "";
-skip($] < 5.008 ? "No Encode module" : "",
+skip($] < 5.008 || ($Config::Config{'extensions'} !~ /\bEncode\b/)
+ ? "No Encode module" : "",
sub { eval { $m->decoded_content } }, "\x{FEFF}Hi there \x{263A}\n");
ok($@ || "", "");
ok($m->content, $tmp);
Added: branches/upstream/libwww-perl/current/t/live/apache.t
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/t/live/apache.t?rev=11053&op=file
==============================================================================
--- branches/upstream/libwww-perl/current/t/live/apache.t (added)
+++ branches/upstream/libwww-perl/current/t/live/apache.t Sun Dec 9 09:21:04 2007
@@ -1,0 +1,50 @@
+print "1..1\n";
+
+use strict;
+use Net::HTTP;
+
+
+my $s = Net::HTTP->new(Host => "www.apache.org",
+ KeepAlive => 1,
+ Timeout => 15,
+ PeerHTTPVersion => "1.1",
+ MaxLineLength => 512) || die "$@";
+
+for (1..1) {
+ $s->write_request(TRACE => "/libwww-perl",
+ 'User-Agent' => 'Mozilla/5.0',
+ 'Accept-Language' => 'no,en',
+ Accept => '*/*');
+
+ my($code, $mess, %h) = $s->read_response_headers;
+ print "# $code $mess\n";
+ for (sort keys %h) {
+ print "# $_: $h{$_}\n";
+ }
+ print "\n";
+
+ my $err;
+ $err++ unless $code eq "200";
+ $err++ unless $h{'Content-Type'} eq "message/http";
+
+ my $buf;
+ while (1) {
+ my $tmp;
+ my $n = $s->read_entity_body($tmp, 20);
+ last unless $n;
+ $buf .= $tmp;
+ }
+ $buf =~ s/\r//g;
+
+ $err++ unless $buf eq "TRACE /libwww-perl HTTP/1.1
+Host: www.apache.org
+User-Agent: Mozilla/5.0
+Accept-Language: no,en
+Accept: */*
+
+";
+
+ print "not " if $err;
+ print "ok $_\n";
+}
+
Added: branches/upstream/libwww-perl/current/t/local/chunked.t
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/t/local/chunked.t?rev=11053&op=file
==============================================================================
--- branches/upstream/libwww-perl/current/t/local/chunked.t (added)
+++ branches/upstream/libwww-perl/current/t/local/chunked.t Sun Dec 9 09:21:04 2007
@@ -1,0 +1,164 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use HTTP::Daemon;
+use Test::More;
+# use Time::HiRes qw(sleep);
+our $CRLF;
+use Socket qw($CRLF);
+
+our $LOGGING = 0;
+
+our @TESTS = (
+ {
+ expect => 629,
+ comment => "traditional, unchunked POST request",
+ raw => "POST /cgi-bin/redir-TE.pl HTTP/1.1
+User-Agent: UNTRUSTED/1.0
+Content-Type: application/x-www-form-urlencoded
+Content-Length: 629
+Host: localhost
+
+JSR-205=0;font_small=15;png=1;jpg=1;alpha_channel=256;JSR-82=0;JSR-135=1;mot-wt=0;JSR-75-pim=0;pointer_motion_event=0;camera=1;free_memory=455472;heap_size=524284;cldc=CLDC-1.1;canvas_size_y=176;canvas_size_x=176;double_buffered=1;color=65536;JSR-120=1;JSR-184=1;JSR-180=0;JSR-75-file=0;push_socket=0;pointer_event=0;nokia-ui=1;java_platform=xxxxxxxxxxxxxxxxx/xxxxxxx;gif=1;midp=MIDP-1.0 MIDP-2.0;font_large=22;sie-col-game=0;JSR-179=0;push_sms=1;JSR-172=0;font_medium=18;fullscreen_canvas_size_y=220;fullscreen_canvas_size_x=176;java_locale=de;video_encoding=encoding=JPEG&width=176&height=182encoding=JPEG&width=176&height=220;"
+ },
+ {
+ expect => 8,
+ comment => "chunked with illegal Content-Length header; tiny message",
+ raw => "POST /cgi-bin/redir-TE.pl HTTP/1.1
+Host: localhost
+Content-Type: application/x-www-form-urlencoded
+Content-Length: 8
+Transfer-Encoding: chunked
+
+8
+icm.x=u2
+0
+
+",
+ },
+ {
+ expect => 868,
+ comment => "chunked with illegal Content-Length header; medium sized",
+ raw => "POST /cgi-bin/redir-TE.pl HTTP/1.1
+Host:dev05
+Connection:close
+Content-Type:application/x-www-form-urlencoded
+Content-Length:868
+transfer-encoding:chunked
+
+364
+JSR-205=0;font_small=20;png=1;jpg=1;JSR-82=0;JSR-135=1;mot-wt=0;JSR-75-pim=0;http=1;pointer_motion_event=0;browser_launch=1;free_memory=733456;user_agent=xxxxxxxxx/xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx;heap_size=815080;cldc=CLDC-1.0;canvas_size_y=182;canvas_size_x=176;double_buffered=1;NAVIGATION PRESS=20;JSR-184=0;JSR-120=1;color=32768;JSR-180=0;JSR-75-file=0;RIGHT SOFT KEY=22;NAVIGATION RIGHT=5;KEY *=42;push_socket=0;pointer_event=0;KEY #=35;KEY NUM 9=57;nokia-ui=0;KEY NUM 8=56;KEY NUM 7=55;KEY NUM 6=54;KEY NUM 5=53;gif=1;KEY NUM 4=52;NAVIGATION UP=1;KEY NUM 3=51;KEY NUM 2=50;KEY NUM 1=49;midp=MIDP-2.0 VSCL-1.1.0;font_large=20;KEY NUM 0=48;sie-col-game=0;JSR-179=0;push_sms=1;JSR-172=0;NAVIGATION LEFT=2;LEFT SOFT KEY=21;font_medium=20;fullscreen_canvas_size_y=204;fullscreen_canvas_size_x=176;https=1;NAVIGATION DOWN=6;java_locale=en-DE;
+0
+
+",
+ },
+ {
+ expect => 1104,
+ comment => "chunked correctly, size ~1k; base for the big next test",
+ raw => "POST /cgi-bin/redir-TE.pl HTTP/1.1
+User-Agent: UNTRUSTED/1.0
+Content-Type: application/x-www-form-urlencoded
+Host: localhost:80
+Transfer-Encoding: chunked
+
+450
+JSR-205=0;font_small=15;png=1;jpg=1;jsr184_dithering=0;CLEAR/DELETE=-8;JSR-82=0;alpha_channel=32;JSR-135=1;mot-wt=0;JSR-75-pim=0;http=1;pointer_motion_event=0;browser_launch=1;BACK/RETURN=-11;camera=1;free_memory=456248;user_agent=xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx;heap_size=524284;cldc=CLDC-1.1;canvas_size_y=176;canvas_size_x=176;double_buffered=1;NAVIGATION PRESS=-5;JSR-184=1;JSR-120=1;color=65536;JSR-180=0;JSR-75-file=0;RIGHT SOFT KEY=-7;NAVIGATION RIGHT=-4;KEY *=42;push_socket=0;pointer_event=0;KEY #=35;KEY NUM 9=57;nokia-ui=1;KEY NUM 8=56;KEY NUM 7=55;KEY NUM 6=54;KEY NUM 5=53;java_platform=xxxxxxxxxxxxxxxxx/xxxxxxx;KEY NUM 4=52;gif=1;KEY NUM 3=51;NAVIGATION UP=-1;KEY NUM 2=50;KEY NUM 1=49;midp=MIDP-1.0 MIDP-2.0;font_large=22;KEY NUM 0=48;sie-col-game=0;JSR-179=0;push_sms=1;JSR-172=0;NAVIGATION LEFT=-3;LEFT SOFT KEY=-6;jsr184_antialiasing=0;font_medium=18;fullscreen_canvas_size_y=220;fullscreen_canvas_size_x=176;https=1;NAVIGATION DOWN=-2;java_locale=de;video_encoding=encoding=JPEG&width=176&height=182encoding=JPEG&width=176&height=220;
+0
+
+"
+ },
+ {
+ expect => 1104*1024,
+ comment => "chunked with many chunks",
+ raw => ("POST /cgi-bin/redir-TE.pl HTTP/1.1
+User-Agent: UNTRUSTED/1.0
+Content-Type: application/x-www-form-urlencoded
+Host: localhost:80
+Transfer-Encoding: chunked
+
+".("450
+JSR-205=0;font_small=15;png=1;jpg=1;jsr184_dithering=0;CLEAR/DELETE=-8;JSR-82=0;alpha_channel=32;JSR-135=1;mot-wt=0;JSR-75-pim=0;http=1;pointer_motion_event=0;browser_launch=1;BACK/RETURN=-11;camera=1;free_memory=456248;user_agent=xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx;heap_size=524284;cldc=CLDC-1.1;canvas_size_y=176;canvas_size_x=176;double_buffered=1;NAVIGATION PRESS=-5;JSR-184=1;JSR-120=1;color=65536;JSR-180=0;JSR-75-file=0;RIGHT SOFT KEY=-7;NAVIGATION RIGHT=-4;KEY *=42;push_socket=0;pointer_event=0;KEY #=35;KEY NUM 9=57;nokia-ui=1;KEY NUM 8=56;KEY NUM 7=55;KEY NUM 6=54;KEY NUM 5=53;java_platform=xxxxxxxxxxxxxxxxx/xxxxxxx;KEY NUM 4=52;gif=1;KEY NUM 3=51;NAVIGATION UP=-1;KEY NUM 2=50;KEY NUM 1=49;midp=MIDP-1.0 MIDP-2.0;font_large=22;KEY NUM 0=48;sie-col-game=0;JSR-179=0;push_sms=1;JSR-172=0;NAVIGATION LEFT=-3;LEFT SOFT KEY=-6;jsr184_antialiasing=0;font_medium=18;fullscreen_canvas_size_y=220;fullscreen_canvas_size_x=176;https=1;NAVIGATION DOWN=-2;java_locale=de;video_encoding=encoding=JPEG&width=176&height=182encoding=JPEG&width=176&height=220;
+"x1024)."0
+
+")
+ },
+ );
+
+
+my $tests = @TESTS;
+plan tests => $tests;
+
+sub mywarn ($) {
+ return unless $LOGGING;
+ my($mess) = @_;
+ open my $fh, ">>", "http-daemon.out"
+ or die $!;
+ my $ts = localtime;
+ print $fh "$ts: $mess\n";
+ close $fh or die $!;
+}
+
+
+my $pid;
+if ($pid = fork) {
+ sleep 4;
+ for my $t (0..$#TESTS) {
+ my $test = $TESTS[$t];
+ my $raw = $test->{raw};
+ $raw =~ s/\r?\n/$CRLF/mg;
+ if (0) {
+ open my $fh, "| socket localhost 8333" or die;
+ print $fh $test;
+ }
+ use IO::Socket::INET;
+ my $sock = IO::Socket::INET->new(
+ PeerAddr => "127.0.0.1",
+ PeerPort => 8333,
+ ) or die;
+ if (0) {
+ for my $pos (0..length($raw)-1) {
+ print $sock substr($raw,$pos,1);
+ sleep 0.001;
+ }
+ } else {
+ print $sock $raw;
+ }
+ local $/;
+ my $resp = <$sock>;
+ close $sock;
+ my($got) = $resp =~ /\r?\n\r?\n(\d+)/s;
+ is($got,
+ $test->{expect},
+ "[$test->{expect}] $test->{comment}",
+ );
+ }
+ wait;
+} else {
+ die "cannot fork: $!" unless defined $pid;
+ my $d = HTTP::Daemon->new(
+ LocalAddr => '0.0.0.0',
+ LocalPort => 8333,
+ ReuseAddr => 1,
+ ) or die;
+ mywarn "Starting new daemon as '$$'";
+ my $i;
+ LISTEN: while (my $c = $d->accept) {
+ my $r = $c->get_request;
+ mywarn sprintf "headers[%s] content[%s]", $r->headers->as_string, $r->content;
+ my $res = HTTP::Response->new(200,undef,undef,length($r->content).$CRLF);
+ $c->send_response($res);
+ $c->force_last_request; # we're just not mature enough
+ $c->close;
+ undef($c);
+ last if ++$i >= $tests;
+ }
+}
+
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 2
+# End:
Modified: branches/upstream/libwww-perl/current/t/local/http-get.t
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/t/local/http-get.t?rev=11053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/t/local/http-get.t (original)
+++ branches/upstream/libwww-perl/current/t/local/http-get.t Sun Dec 9 09:21:04 2007
@@ -50,7 +50,7 @@
open(DAEMON, "$perl local/http-get.t daemon |") or die "Can't exec daemon: $!";
}
-print "1..20\n";
+print "1..21\n";
my $greeting = <DAEMON>;
@@ -384,6 +384,28 @@
}
+{
+
+my $content;
+
+$res = $ua->post(
+ url("/echo/foo", $base),
+ Content_Type => 'text/plain',
+ Content => "Plain Text",
+ ':content_cb' => sub { $content .= $_[0]; return; },
+);
+
+$_ = $content;
+print "not " unless $res->is_success
+ and /^Content-Length:\s*10$/mi
+ and /^Content-Type:\s*text\/plain$/mi
+ and /^Plain Text$/m
+ and ! $res->content
+;
+print "ok 20\n";
+
+}
+
#----------------------------------------------------------------
print "#------------Testing: Terminating server...\n";
sub httpd_get_quit
@@ -396,5 +418,5 @@
$res = $ua->get( url("/quit", $base) );
print "not " unless $res->code == 503 and $res->content =~ /Bye, bye/;
-print "ok 20\n";
-
+print "ok 21\n";
+
Modified: branches/upstream/libwww-perl/current/talk-to-ourself
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/talk-to-ourself?rev=11053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/talk-to-ourself (original)
+++ branches/upstream/libwww-perl/current/talk-to-ourself Sun Dec 9 09:21:04 2007
@@ -1,7 +1,7 @@
#!perl -w
# This program check if we are able to talk to ourself. Misconfigured
-# systems that can't talk to their own 'hostname' has the most commonly
+# systems that can't talk to their own 'hostname' was the most commonly
# reported libwww-failure.
use strict;
More information about the Pkg-perl-cvs-commits
mailing list