r18603 - in /branches/upstream/libwww-perl/current: ./ lib/ lib/HTML/ lib/HTTP/ lib/HTTP/Request/ lib/LWP/Protocol/ lib/Net/ lib/Net/HTTP/ t/base/ t/html/
gregoa-guest at users.alioth.debian.org
gregoa-guest at users.alioth.debian.org
Tue Apr 15 15:03:36 UTC 2008
Author: gregoa-guest
Date: Tue Apr 15 15:03:35 2008
New Revision: 18603
URL: http://svn.debian.org/wsvn/?sc=1&rev=18603
Log:
[svn-upgrade] Integrating new upstream version, libwww-perl (5.811)
Modified:
branches/upstream/libwww-perl/current/Changes
branches/upstream/libwww-perl/current/META.yml
branches/upstream/libwww-perl/current/lib/HTML/Form.pm
branches/upstream/libwww-perl/current/lib/HTTP/Message.pm
branches/upstream/libwww-perl/current/lib/HTTP/Request.pm
branches/upstream/libwww-perl/current/lib/HTTP/Request/Common.pm
branches/upstream/libwww-perl/current/lib/HTTP/Response.pm
branches/upstream/libwww-perl/current/lib/HTTP/Status.pm
branches/upstream/libwww-perl/current/lib/LWP.pm
branches/upstream/libwww-perl/current/lib/LWP/Protocol/http.pm
branches/upstream/libwww-perl/current/lib/Net/HTTP.pm
branches/upstream/libwww-perl/current/lib/Net/HTTP/Methods.pm
branches/upstream/libwww-perl/current/t/base/common-req.t
branches/upstream/libwww-perl/current/t/base/message.t
branches/upstream/libwww-perl/current/t/html/form.t
Modified: branches/upstream/libwww-perl/current/Changes
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/Changes?rev=18603&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/Changes (original)
+++ branches/upstream/libwww-perl/current/Changes Tue Apr 15 15:03:35 2008
@@ -1,3 +1,29 @@
+2008-04-14 Gisle Aas <gisle at ActiveState.com>
+
+ Release 5.811
+
+ Gisle Aas (6):
+ Avoid "used only once" warning for $Config::Config.
+ Make HTTP::Request::Common::PUT set Content-Length header [RT#34772]
+ Added the add_content_utf8 method to HTTP::Message.
+ Typo fix.
+ Retry syscalls when they fail with EINTR or EAGAIN [RT#34093,32356]
+ Allow HTTP::Content content that can be downgraded to bytes.
+
+ Gavin Peters (1):
+ HTML::Form does not recognise multiple select items with same name [RT#18993]
+
+ Mark Stosberg (1):
+ Document how HTTP::Status codes correspond to the classification functions [RT#20819]
+
+ Robert Stone (1):
+ Allow 100, 204, 304 responses to have content [RT#17907]
+
+ sasao (1):
+ HTTP::Request::Common::POST suppressed filename="0" in Content-Disposition [RT#18887]
+
+
+
2008-04-08 Gisle Aas <gisle at ActiveState.com>
Release 5.810
Modified: branches/upstream/libwww-perl/current/META.yml
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/META.yml?rev=18603&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/META.yml (original)
+++ branches/upstream/libwww-perl/current/META.yml Tue Apr 15 15:03:35 2008
@@ -1,6 +1,6 @@
--- #YAML:1.0
name: libwww-perl
-version: 5.810
+version: 5.811
abstract: ~
license: ~
generated_by: ExtUtils::MakeMaker version 6.3201
Modified: branches/upstream/libwww-perl/current/lib/HTML/Form.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/lib/HTML/Form.pm?rev=18603&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/HTML/Form.pm (original)
+++ branches/upstream/libwww-perl/current/lib/HTML/Form.pm Tue Apr 15 15:03:35 2008
@@ -5,7 +5,7 @@
use Carp ();
use vars qw($VERSION);
-$VERSION = "5.810";
+$VERSION = "5.811";
my %form_tags = map {$_ => 1} qw(input textarea button select option);
@@ -136,6 +136,8 @@
my @forms;
my $f; # current form
+
+ my %openselect; # index to the open instance of a select
while (my $t = $p->get_tag) {
my($tag,$attr) = @$t;
@@ -198,6 +200,9 @@
$attr->{"select_$_"} = delete $attr->{$_}
if exists $attr->{$_};
}
+ # count this new select option separately
+ $openselect{$attr->{name}}++;
+
while ($t = $p->get_tag) {
my $tag = shift @$t;
last if $tag eq "/select";
@@ -216,6 +221,7 @@
$a{value_name} = $p->get_trimmed_text;
$a{value} = delete $a{value_name}
unless defined $a{value};
+ $a{idx} = $openselect{$attr->{name}};
$f->push_input("option", \%a);
}
else {
@@ -1049,7 +1055,7 @@
my $m = $self->{menu}[0];
$m->{disabled}++ if delete $self->{option_disabled};
- my $prev = $form->find_input($self->{name}, $self->{type});
+ my $prev = $form->find_input($self->{name}, $self->{type}, $self->{idx});
return $self->SUPER::add_to_form($form) unless $prev;
# merge menues
Modified: branches/upstream/libwww-perl/current/lib/HTTP/Message.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/lib/HTTP/Message.pm?rev=18603&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/HTTP/Message.pm (original)
+++ branches/upstream/libwww-perl/current/lib/HTTP/Message.pm Tue Apr 15 15:03:35 2008
@@ -2,7 +2,7 @@
use strict;
use vars qw($VERSION $AUTOLOAD);
-$VERSION = "5.810";
+$VERSION = "5.811";
require HTTP::Headers;
require Carp;
@@ -11,7 +11,14 @@
$HTTP::URI_CLASS ||= $ENV{PERL_HTTP_URI_CLASS} || "URI";
eval "require $HTTP::URI_CLASS"; die $@ if $@;
-*_is_utf8 = defined &utf8::is_utf8 ? \&utf8::is_utf8 : sub { 0 };
+*_utf8_downgrade = defined(&utf8::downgrade) ?
+ sub {
+ utf8::downgrade($_[0], 1) or
+ Carp::croak("HTTP::Message content must be bytes")
+ }
+ :
+ sub {
+ };
sub new
{
@@ -29,9 +36,7 @@
$header = HTTP::Headers->new;
}
if (defined $content) {
- if (_is_utf8($content)) {
- Carp::croak("HTTP::Message content not bytes");
- }
+ _utf8_downgrade($content);
}
else {
$content = '';
@@ -110,9 +115,7 @@
sub _set_content {
my $self = $_[0];
- if (_is_utf8($_[1])) {
- Carp::croak("HTTP::Message content not bytes")
- }
+ _utf8_downgrade($_[1]);
if (!ref($_[1]) && ref($self->{_content}) eq "SCALAR") {
${$self->{_content}} = $_[1];
}
@@ -132,9 +135,7 @@
my $chunkref = \$_[0];
$chunkref = $$chunkref if ref($$chunkref); # legacy
- if (_is_utf8($$chunkref)) {
- Carp::croak("HTTP::Message added content not bytes");
- }
+ _utf8_downgrade($$chunkref);
my $ref = ref($self->{_content});
if (!$ref) {
@@ -149,6 +150,12 @@
delete $self->{_parts};
}
+sub add_content_utf8 {
+ my($self, $buf) = @_;
+ utf8::upgrade($buf);
+ utf8::encode($buf);
+ $self->add_content($buf);
+}
sub content_ref
{
@@ -555,7 +562,7 @@
=item $mess->content
-=item $mess->content( $content )
+=item $mess->content( $bytes )
The content() method sets the raw content if an argument is given. If no
argument is given the content is not touched. In either case the
@@ -565,14 +572,19 @@
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->add_content( $bytes )
+
+The add_content() methods appends more data bytes to the end of the
+current content buffer.
+
+=item $mess->add_content_utf8( $string )
+
+The add_content_utf8() method appends the UTF-8 bytes representing the
+string to the end of the current content buffer.
=item $mess->content_ref
-=item $mess->content_ref( \$content )
+=item $mess->content_ref( \$bytes )
The content_ref() method will return a reference to content buffer string.
It can be more efficient to access the content this way if the content
@@ -591,9 +603,9 @@
=item $mess->decoded_content( %options )
-Returns the content with any C<Content-Encoding> undone and strings
-mapped to perl's Unicode strings. If the C<Content-Encoding> or
-C<charset> of the message is unknown this method will fail by
+Returns the content with any C<Content-Encoding> undone and the raw
+content encoded to perl's Unicode strings. If the C<Content-Encoding>
+or C<charset> of the message is unknown this method will fail by
returning C<undef>.
The following options can be specified.
@@ -613,7 +625,7 @@
Abort decoding when if malformed characters is found in the content. By
default you get the substitution character ("\x{FFFD}") in place of
-mailformed characters.
+malformed characters.
=item C<raise_error>
Modified: branches/upstream/libwww-perl/current/lib/HTTP/Request.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/lib/HTTP/Request.pm?rev=18603&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/HTTP/Request.pm (original)
+++ branches/upstream/libwww-perl/current/lib/HTTP/Request.pm Tue Apr 15 15:03:35 2008
@@ -2,7 +2,7 @@
require HTTP::Message;
@ISA = qw(HTTP::Message);
-$VERSION = "5.810";
+$VERSION = "5.811";
use strict;
@@ -178,7 +178,7 @@
=item $r->content
-=item $r->content( $content )
+=item $r->content( $bytes )
This is used to get/set the content and it is inherited from the
C<HTTP::Message> base class. See L<HTTP::Message> for details and
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=18603&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/HTTP/Request/Common.pm (original)
+++ branches/upstream/libwww-perl/current/lib/HTTP/Request/Common.pm Tue Apr 15 15:03:35 2008
@@ -13,7 +13,7 @@
require HTTP::Request;
use Carp();
-$VERSION = "5.810";
+$VERSION = "5.811";
my $CRLF = "\015\012"; # "\r\n" is not portable
@@ -104,6 +104,7 @@
while (($k,$v) = splice(@_, 0, 2)) {
if (lc($k) eq 'content') {
$req->add_content($v);
+ $req->header("Content-Length", length(${$req->content_ref}));
}
else {
$req->push_header($k, $v);
@@ -134,7 +135,7 @@
}
$k =~ s/([\\\"])/\\$1/g;
my $disp = qq(form-data; name="$k");
- if ($usename) {
+ if (defined($usename) and length($usename)) {
$usename =~ s/([\\\"])/\\$1/g;
$disp .= qq(; filename="$usename");
}
Modified: branches/upstream/libwww-perl/current/lib/HTTP/Response.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/lib/HTTP/Response.pm?rev=18603&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/HTTP/Response.pm (original)
+++ branches/upstream/libwww-perl/current/lib/HTTP/Response.pm Tue Apr 15 15:03:35 2008
@@ -2,7 +2,7 @@
require HTTP::Message;
@ISA = qw(HTTP::Message);
-$VERSION = "5.810";
+$VERSION = "5.811";
use strict;
use HTTP::Status ();
@@ -310,7 +310,7 @@
=item $r->content
-=item $r->content( $content )
+=item $r->content( $bytes )
This is used to get/set the raw content and it is inherited from the
C<HTTP::Message> base class. See L<HTTP::Message> for details and
Modified: branches/upstream/libwww-perl/current/lib/HTTP/Status.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/lib/HTTP/Status.pm?rev=18603&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/HTTP/Status.pm (original)
+++ branches/upstream/libwww-perl/current/lib/HTTP/Status.pm Tue Apr 15 15:03:35 2008
@@ -1,7 +1,7 @@
package HTTP::Status;
use strict;
-require 5.002; # becase we use prototypes
+require 5.002; # because we use prototypes
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
@@ -9,7 +9,7 @@
@ISA = qw(Exporter);
@EXPORT = qw(is_info is_success is_redirect is_error status_message);
@EXPORT_OK = qw(is_client_error is_server_error);
-$VERSION = "5.810";
+$VERSION = "5.811";
# Note also addition of mnemonics to @EXPORT below
@@ -203,28 +203,28 @@
=item is_info( $code )
-Return TRUE if C<$code> is an I<Informational> status code. This
+Return TRUE if C<$code> is an I<Informational> status code (1xx). This
class of status code indicates a provisional response which can't have
any content.
=item is_success( $code )
-Return TRUE if C<$code> is a I<Successful> status code.
+Return TRUE if C<$code> is a I<Successful> status code (2xx).
=item is_redirect( $code )
-Return TRUE if C<$code> is a I<Redirection> status code. This class of
+Return TRUE if C<$code> is a I<Redirection> status code (3xx). This class of
status code indicates that further action needs to be taken by the
user agent in order to fulfill the request.
=item is_error( $code )
-Return TRUE if C<$code> is an I<Error> status code. The function
+Return TRUE if C<$code> is an I<Error> status code (4xx or 5xx). The function
return TRUE for both client error or a server error status codes.
=item is_client_error( $code )
-Return TRUE if C<$code> is an I<Client Error> status code. This class
+Return TRUE if C<$code> is an I<Client Error> status code (4xx). This class
of status code is intended for cases in which the client seems to have
erred.
@@ -232,7 +232,7 @@
=item is_server_error( $code )
-Return TRUE if C<$code> is an I<Server Error> status code. This class
+Return TRUE if C<$code> is an I<Server Error> status code (5xx). This class
of status codes is intended for cases in which the server is aware
that it has erred or is incapable of performing the request.
Modified: branches/upstream/libwww-perl/current/lib/LWP.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/lib/LWP.pm?rev=18603&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/LWP.pm (original)
+++ branches/upstream/libwww-perl/current/lib/LWP.pm Tue Apr 15 15:03:35 2008
@@ -1,6 +1,6 @@
package LWP;
-$VERSION = "5.810";
+$VERSION = "5.811";
sub Version { $VERSION; }
require 5.005;
Modified: branches/upstream/libwww-perl/current/lib/LWP/Protocol/http.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/lib/LWP/Protocol/http.pm?rev=18603&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/LWP/Protocol/http.pm (original)
+++ branches/upstream/libwww-perl/current/lib/LWP/Protocol/http.pm Tue Apr 15 15:03:35 2008
@@ -203,12 +203,26 @@
#print "------\n$req_buf\n------\n";
if (!$has_content || $write_wait || $has_content > 8*1024) {
- # XXX need to watch out for write timeouts
- my $n = $socket->syswrite($req_buf, length($req_buf));
- die $! unless defined($n);
- die "short write" unless $n == length($req_buf);
- #LWP::Debug::conns($req_buf);
- $req_buf = "";
+ do {
+ # Since this just writes out the header block it should almost
+ # always succeed to send the whole buffer in a single write call.
+ my $n = syswrite($socket, $req_buf, length($req_buf));
+ unless (defined $n) {
+ redo if $!{EINTR};
+ if ($!{EAGAIN}) {
+ select(undef, undef, undef, 0.1);
+ redo;
+ }
+ die "write failed: $!";
+ }
+ if ($n) {
+ substr($req_buf, 0, $n, "");
+ }
+ else {
+ select(undef, undef, undef, 0.5);
+ }
+ }
+ while (length $req_buf);
}
my($code, $mess, @junk);
@@ -240,20 +254,32 @@
my $fbits = '';
vec($fbits, fileno($socket), 1) = 1;
+ WRITE:
while ($woffset < length($$wbuf)) {
- my $time_before;
my $sel_timeout = $timeout;
if ($write_wait) {
- $time_before = time;
$sel_timeout = $write_wait if $write_wait < $sel_timeout;
}
+ my $time_before;
+ $time_before = time if $sel_timeout;
my $rbits = $fbits;
my $wbits = $write_wait ? undef : $fbits;
- my $nfound = select($rbits, $wbits, undef, $sel_timeout);
- unless (defined $nfound) {
- die "select failed: $!";
+ my $sel_timeout_before = $sel_timeout;
+ SELECT:
+ {
+ my $nfound = select($rbits, $wbits, undef, $sel_timeout);
+ unless (defined $nfound) {
+ if ($!{EINTR} || $!{EAGAIN}) {
+ if ($time_before) {
+ $sel_timeout = $sel_timeout_before - (time - $time_before);
+ $sel_timeout = 0 if $sel_timeout < 0;
+ }
+ redo SELECT;
+ }
+ die "select failed: $!";
+ }
}
if ($write_wait) {
@@ -264,13 +290,21 @@
if (defined($rbits) && $rbits =~ /[^\0]/) {
# readable
my $buf = $socket->_rbuf;
- my $n = $socket->sysread($buf, 1024, length($buf));
- unless ($n) {
- die "EOF";
+ my $n = sysread($socket, $buf, 1024, length($buf));
+ unless (defined $n) {
+ die "read failed: $!" unless $!{EINTR} || $!{EAGAIN};
+ # if we get here the rest of the block will do nothing
+ # and we will retry the read on the next round
+ }
+ elsif ($n == 0) {
+ # the server closed the connection before we finished
+ # writing all the request content. No need to write any more.
+ $drop_connection++;
+ last WRITE;
}
$socket->_rbuf($buf);
- if ($buf =~ /\015?\012\015?\012/) {
- # a whole response present
+ if (!$code && $buf =~ /\015?\012\015?\012/) {
+ # a whole response header is present, so we can read it without blocking
($code, $mess, @h) = $socket->read_response_headers(laxed => 1,
junk_out => \@junk,
);
@@ -280,16 +314,19 @@
}
else {
$drop_connection++;
- last;
+ last WRITE;
# XXX should perhaps try to abort write in a nice way too
}
}
}
if (defined($wbits) && $wbits =~ /[^\0]/) {
- my $n = $socket->syswrite($$wbuf, length($$wbuf), $woffset);
- unless ($n) {
- die "syswrite: $!" unless defined $n;
- die "syswrite: no bytes written";
+ my $n = syswrite($socket, $$wbuf, length($$wbuf), $woffset);
+ unless (defined $n) {
+ die "write failed: $!" unless $!{EINTR} || $!{EAGAIN};
+ $n = 0; # will retry write on the next round
+ }
+ elsif ($n == 0) {
+ die "write failed: no bytes written";
}
$woffset += $n;
@@ -304,7 +341,7 @@
$woffset = 0;
}
}
- }
+ } # WRITE
}
($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
@@ -341,7 +378,10 @@
READ:
{
$n = $socket->read_entity_body($buf, $size);
- die "Can't read entity body: $!" unless defined $n;
+ unless (defined $n) {
+ redo READ if $!{EINTR} || $!{EAGAIN};
+ die "read failed: $!";
+ }
redo READ if $n == -1;
}
$complete++ if !$n;
@@ -393,9 +433,24 @@
my($self, $timeout) = @_;
my $fbits = '';
vec($fbits, fileno($self), 1) = 1;
- my $nfound = select($fbits, undef, undef, $timeout);
- die "select failed: $!" unless defined $nfound;
- return $nfound > 0;
+ SELECT:
+ {
+ my $before;
+ $before = time if $timeout;
+ my $nfound = select($fbits, undef, undef, $timeout);
+ unless (defined $nfound) {
+ if ($!{EINTR} || $!{EAGAIN}) {
+ # don't really think EAGAIN can happen here
+ if ($timeout) {
+ $timeout -= time - $before;
+ $timeout = 0 if $timeout < 0;
+ }
+ redo SELECT;
+ }
+ die "select failed: $!";
+ }
+ return $nfound > 0;
+ }
}
sub ping {
Modified: branches/upstream/libwww-perl/current/lib/Net/HTTP.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/lib/Net/HTTP.pm?rev=18603&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/Net/HTTP.pm (original)
+++ branches/upstream/libwww-perl/current/lib/Net/HTTP.pm Tue Apr 15 15:03:35 2008
@@ -3,7 +3,7 @@
use strict;
use vars qw($VERSION @ISA);
-$VERSION = "5.810";
+$VERSION = "5.811";
eval { require IO::Socket::INET } || require IO::Socket;
require Net::HTTP::Methods;
@@ -213,7 +213,12 @@
The return value will be C<undef> on read errors, 0 on EOF, -1 if no data
could be returned this time, otherwise the number of bytes assigned
-to $buf. The $buf set to "" when the return value is -1.
+to $buf. The $buf is set to "" when the return value is -1.
+
+You normally want to retry this call if this function returns either
+-1 or C<undef> with C<$!> as EINTR or EAGAIN (see L<Errno>). EINTR
+can happen if the application catches signals and EAGAIN can happen if
+you made the socket non-blocking.
This method will raise exceptions (die) if the server does not speak
proper HTTP. This can only happen when reading chunked data.
Modified: branches/upstream/libwww-perl/current/lib/Net/HTTP/Methods.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/lib/Net/HTTP/Methods.pm?rev=18603&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/Net/HTTP/Methods.pm (original)
+++ branches/upstream/libwww-perl/current/lib/Net/HTTP/Methods.pm Tue Apr 15 15:03:35 2008
@@ -5,7 +5,7 @@
use strict;
use vars qw($VERSION);
-$VERSION = "5.810";
+$VERSION = "5.811";
my $CRLF = "\015\012"; # "\r\n" is not portable
@@ -227,11 +227,26 @@
if $max_line_length && length($_) > $max_line_length;
# need to read more data to find a line ending
- my $n = $self->sysread($_, 1024, length);
- if (!$n) {
- return undef unless length;
- return substr($_, 0, length, "");
- }
+ READ:
+ {
+ my $n = $self->sysread($_, 1024, length);
+ unless (defined $n) {
+ redo READ if $!{EINTR};
+ if ($!{EAGAIN}) {
+ # Hmm, we must be reading from a non-blocking socket
+ # XXX Should really wait until this socket is readable,...
+ select(undef, undef, undef, 0.1); # but this will do for now
+ redo READ;
+ }
+ # if we have already accumulated some data let's at least
+ # return that as a line
+ die "read failed: $!" unless length;
+ }
+ unless ($n) {
+ return undef unless length;
+ return substr($_, 0, length, "");
+ }
+ }
}
die "Line too long ($pos; limit is $max_line_length)"
if $max_line_length && $pos > $max_line_length;
@@ -366,8 +381,8 @@
delete ${*$self}{'http_bytes'};
my $method = shift(@{${*$self}{'http_request_method'}});
my $status = ${*$self}{'http_status'};
- if ($method eq "HEAD" || $status =~ /^(?:1|[23]04)/) {
- # these responses are always empty
+ if ($method eq "HEAD") {
+ # this response is always empty regardless of other headers
$bytes = 0;
}
elsif (my $te = ${*$self}{'http_te'}) {
@@ -407,6 +422,11 @@
elsif (defined(my $content_length = ${*$self}{'http_content_length'})) {
$bytes = $content_length;
}
+ elsif ($status =~ /^(?:1|[23]04)/) {
+ # RFC 2616 says that these responses should always be empty
+ # but that does not appear to be true in practice [RT#17907]
+ $bytes = 0;
+ }
else {
# XXX Multi-Part types are self delimiting, but RFC 2616 says we
# only has to deal with 'multipart/byteranges'
Modified: branches/upstream/libwww-perl/current/t/base/common-req.t
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/t/base/common-req.t?rev=18603&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/t/base/common-req.t (original)
+++ branches/upstream/libwww-perl/current/t/base/common-req.t Tue Apr 15 15:03:35 2008
@@ -30,7 +30,7 @@
print "ok 5\n";
print "not " unless ${$r->content_ref} eq "foo" and
- $r->content eq "foo";
+ $r->content eq "foo" and $r->content_length == 3;
print "ok 6\n";
#--- Test POST requests ---
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=18603&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/t/base/message.t (original)
+++ branches/upstream/libwww-perl/current/t/base/message.t Tue Apr 15 15:03:35 2008
@@ -3,10 +3,10 @@
use strict;
use Test qw(plan ok skip);
-plan tests => 100;
+plan tests => 102;
require HTTP::Message;
-require Config;
+use Config qw(%Config);
my($m, $m2, @parts);
@@ -339,7 +339,7 @@
$m->content_type("text/plain; charset=UTF-8");
$m->content("H4sICFWAq0ECA3h4eAB7v3u/R6ZCSUZqUarCoxm7uAAZKHXiEAAAAA==\n");
-my $NO_ENCODE = $] < 5.008 || ($Config::Config{'extensions'} !~ /\bEncode\b/)
+my $NO_ENCODE = $] < 5.008 || ($Config{'extensions'} !~ /\bEncode\b/)
? "No Encode module" : "";
$@ = "";
skip($NO_ENCODE, sub { eval { $m->decoded_content } }, "\x{FEFF}Hi there \x{263A}\n");
@@ -390,3 +390,15 @@
else {
skip("Missing is_utf8 test") for 1..3;
}
+
+# test the add_content_utf8 method
+if ($] >= 5.008001) {
+ $m = HTTP::Message->new(["Content-Type", "text/plain; charset=UTF-8"]);
+ $m->add_content_utf8("\x{263A}");
+ $m->add_content_utf8("-\xC5");
+ ok($m->content, "\xE2\x98\xBA-\xC3\x85");
+ ok($m->decoded_content, "\x{263A}-\x{00C5}");
+}
+else {
+ skip("Missing is_utf8 test") for 1..2;
+}
Modified: branches/upstream/libwww-perl/current/t/html/form.t
URL: http://svn.debian.org/wsvn/branches/upstream/libwww-perl/current/t/html/form.t?rev=18603&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/t/html/form.t (original)
+++ branches/upstream/libwww-perl/current/t/html/form.t Tue Apr 15 15:03:35 2008
@@ -3,7 +3,7 @@
use strict;
use Test qw(plan ok);
-plan tests => 123;
+plan tests => 124;
use HTML::Form;
@@ -416,6 +416,24 @@
ok($@ && $@ =~ /^The value '2' has been disabled/);
ok(eval{$f->find_input("m3", undef, 2)->value(undef)}, undef);
ok($@ && $@ =~ /^The 'm3' field can't be unchecked/);
+
+# multiple select with the same name [RT#18993]
+$f = HTML::Form->parse(<<EOT, "http://localhost/");
+<form action="target.html" method="get">
+<select name="bug">
+<option selected value=hi>hi
+<option value=mom>mom
+</select>
+<select name="bug">
+<option value=hi>hi
+<option selected value=mom>mom
+</select>
+<select name="nobug">
+<option value=hi>hi
+<option selected value=mom>mom
+</select>
+EOT
+ok(join("|", $f->form), "bug|hi|bug|mom|nobug|mom");
# Try a disabled radiobutton:
$f = HTML::Form->parse(<<EOT, "http://localhost/");
More information about the Pkg-perl-cvs-commits
mailing list