r23053 - in /branches/upstream/libwww-perl/current: Changes MANIFEST META.yml bin/lwp-download lib/HTML/Form.pm lib/HTTP/Negotiate.pm lib/HTTP/Response.pm lib/LWP.pm lib/LWP/RobotUA.pm lib/LWP/UserAgent.pm t/html/form-multi-select.t
gregoa at users.alioth.debian.org
gregoa at users.alioth.debian.org
Sat Jul 12 11:48:11 UTC 2008
Author: gregoa
Date: Sat Jul 12 11:48:10 2008
New Revision: 23053
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=23053
Log:
[svn-upgrade] Integrating new upstream version, libwww-perl (5.813)
Added:
branches/upstream/libwww-perl/current/t/html/form-multi-select.t
Modified:
branches/upstream/libwww-perl/current/Changes
branches/upstream/libwww-perl/current/MANIFEST
branches/upstream/libwww-perl/current/META.yml
branches/upstream/libwww-perl/current/bin/lwp-download
branches/upstream/libwww-perl/current/lib/HTML/Form.pm
branches/upstream/libwww-perl/current/lib/HTTP/Negotiate.pm
branches/upstream/libwww-perl/current/lib/HTTP/Response.pm
branches/upstream/libwww-perl/current/lib/LWP.pm
branches/upstream/libwww-perl/current/lib/LWP/RobotUA.pm
branches/upstream/libwww-perl/current/lib/LWP/UserAgent.pm
Modified: branches/upstream/libwww-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwww-perl/current/Changes?rev=23053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/Changes (original)
+++ branches/upstream/libwww-perl/current/Changes Sat Jul 12 11:48:10 2008
@@ -1,3 +1,24 @@
+2008-06-17 Gisle Aas <gisle at ActiveState.com>
+
+ Release 5.813
+
+ Ville Skytta (3):
+ RobotUA constructor ignores delay, use_sleep [RT#35456]
+ Spelling fixes [RT#35457]
+ Add HTTP::Response->filename [RT#35458]
+
+ Mark Stosberg (2):
+ Better diagnostics when the HTML::TokeParser constructor fails [RT#35607]
+ Multiple forms with same-named <select> parse wrongly [RT#35607]
+
+ Gisle Aas (1):
+ Provide a progress method that does something that might be useful.
+
+ Spiros Denaxas (1):
+ Documentation typo fix [RT#36132]
+
+
+
2008-04-16 Gisle Aas <gisle at ActiveState.com>
Release 5.812
Modified: branches/upstream/libwww-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwww-perl/current/MANIFEST?rev=23053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/MANIFEST (original)
+++ branches/upstream/libwww-perl/current/MANIFEST Sat Jul 12 11:48:10 2008
@@ -85,6 +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/html/form-multi-select.t More HTML::Form tests
t/html/form-maxlength.t More HTML::Form tests
t/live/apache.t
t/live/apache-listing.t Test File::Listing::apache package
Modified: branches/upstream/libwww-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwww-perl/current/META.yml?rev=23053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/META.yml (original)
+++ branches/upstream/libwww-perl/current/META.yml Sat Jul 12 11:48:10 2008
@@ -1,9 +1,10 @@
--- #YAML:1.0
name: libwww-perl
-version: 5.812
+version: 5.813
abstract: ~
license: ~
-generated_by: ExtUtils::MakeMaker version 6.3201
+author: ~
+generated_by: ExtUtils::MakeMaker version 6.42_01
distribution_type: module
requires:
Compress::Zlib: 1.10
@@ -14,5 +15,5 @@
Net::FTP: 2.58
URI: 1.10
meta-spec:
- url: http://module-build.sourceforge.net/META-spec-v1.2.html
- version: 1.2
+ url: http://module-build.sourceforge.net/META-spec-v1.3.html
+ version: 1.3
Modified: branches/upstream/libwww-perl/current/bin/lwp-download
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwww-perl/current/bin/lwp-download?rev=23053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/bin/lwp-download (original)
+++ branches/upstream/libwww-perl/current/bin/lwp-download Sat Jul 12 11:48:10 2008
@@ -73,7 +73,7 @@
my $url = URI->new(shift || usage());
my $argfile = shift;
usage() if defined($argfile) && !length($argfile);
-my $VERSION = "5.810";
+my $VERSION = "5.813";
my $ua = LWP::UserAgent->new(
agent => "lwp-download/$VERSION ",
@@ -105,21 +105,12 @@
}
unless (defined $argfile) {
- # must find a suitable name to use. First thing
- # to do is to look for the "Content-Disposition"
- # header defined by RFC1806. This is also supported
- # by Netscape
- my $cd = $res->header("Content-Disposition");
- if ($cd && $cd =~ /\bfilename\s*=\s*(\S+)/) {
- $file = $1;
- $file =~ s/;$//;
- $file =~ s/^([\"\'])(.*)\1$/$2/;
- $file =~ s,.*[\\/],,; # basename
- }
+ # find a suitable name to use
+ $file = $res->filename;
# if this fails we try to make something from the URL
unless ($file) {
- my $req = $res->request; # now always there
+ my $req = $res->request; # not always there
my $rurl = $req ? $req->url : $url;
$file = ($rurl->path_segments)[-1];
Modified: branches/upstream/libwww-perl/current/lib/HTML/Form.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwww-perl/current/lib/HTML/Form.pm?rev=23053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/HTML/Form.pm (original)
+++ branches/upstream/libwww-perl/current/lib/HTML/Form.pm Sat Jul 12 11:48:10 2008
@@ -5,7 +5,7 @@
use Carp ();
use vars qw($VERSION);
-$VERSION = "5.811";
+$VERSION = "5.813";
my %form_tags = map {$_ => 1} qw(input textarea button select option);
@@ -113,6 +113,7 @@
require HTML::TokeParser;
my $p = HTML::TokeParser->new(ref($html) ? $html->decoded_content(ref => 1) : \$html);
+ die "Failed to create HTML::TokeParser object" unless $p;
eval {
# optimization
$p->report_tags(qw(form input textarea select optgroup option keygen label button));
@@ -149,6 +150,7 @@
$action,
$attr->{'enctype'});
$f->{attr} = $attr;
+ %openselect = ();
push(@forms, $f);
my(%labels, $current_label);
while (my $t = $p->get_tag) {
Modified: branches/upstream/libwww-perl/current/lib/HTTP/Negotiate.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwww-perl/current/lib/HTTP/Negotiate.pm?rev=23053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/HTTP/Negotiate.pm (original)
+++ branches/upstream/libwww-perl/current/lib/HTTP/Negotiate.pm Sat Jul 12 11:48:10 2008
@@ -1,6 +1,6 @@
package HTTP::Negotiate;
-$VERSION = "5.810";
+$VERSION = "5.813";
sub Version { $VERSION; }
require 5.002;
@@ -18,7 +18,7 @@
my(%accept);
unless (defined $request) {
- # Create a request object from the CGI envirionment variables
+ # Create a request object from the CGI environment variables
$request = new HTTP::Headers;
$request->header('Accept', $ENV{HTTP_ACCEPT})
if $ENV{HTTP_ACCEPT};
@@ -105,7 +105,7 @@
}
my @Q = (); # This is where we collect the results of the
- # quality calcualtions
+ # quality calculations
# Calculate quality for all the variants that are available.
for (@$variants) {
@@ -126,9 +126,9 @@
# Calculate encoding quality
my $qe = 1;
- # If the variant has no assignes Content-Encoding, or if no
+ # If the variant has no assigned Content-Encoding, or if no
# Accept-Encoding field is present, then the value assigned
- # is "qe=1". If *all* of the variant's content encoddings
+ # is "qe=1". If *all* of the variant's content encodings
# are listed in the Accept-Encoding field, then the value
# assigned is "qw=1". If *any* of the variant's content
# encodings are not listed in the provided Accept-Encoding
@@ -150,7 +150,7 @@
# Calculate charset quality
my $qc = 1;
- # If the variant's media-type has not charset parameter,
+ # If the variant's media-type has no charset parameter,
# or the variant's charset is US-ASCII, or if no Accept-Charset
# field is present, then the value assigned is "qc=1". If the
# variant's charset is listed in the Accept-Charset field,
@@ -167,7 +167,7 @@
my @lang = ref($lang) ? @$lang : ($lang);
# If any of the variant's content languages are listed
# in the Accept-Language field, the the value assigned is
- # the maximus of the "q" paramet values for thos language
+ # the largest of the "q" parameter values for those language
# tags.
my $q = undef;
for (@lang) {
@@ -319,8 +319,8 @@
['var3', 0.3, 'image/gif', undef, undef, undef, 43555],
];
- @prefered = choose($variants, $request_headers);
- $the_one = choose($variants);
+ @preferred = choose($variants, $request_headers);
+ $the_one = choose($variants);
=head1 DESCRIPTION
Modified: branches/upstream/libwww-perl/current/lib/HTTP/Response.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwww-perl/current/lib/HTTP/Response.pm?rev=23053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/HTTP/Response.pm (original)
+++ branches/upstream/libwww-perl/current/lib/HTTP/Response.pm Sat Jul 12 11:48:10 2008
@@ -2,7 +2,7 @@
require HTTP::Message;
@ISA = qw(HTTP::Message);
-$VERSION = "5.811";
+$VERSION = "5.813";
use strict;
use HTTP::Status ();
@@ -93,6 +93,78 @@
# can't find an absolute base
return undef;
+}
+
+
+sub filename
+{
+ my $self = shift;
+ my $file;
+
+ my $cd = $self->header('Content-Disposition');
+ if ($cd) {
+ require HTTP::Headers::Util;
+ if (my @cd = HTTP::Headers::Util::split_header_words($cd)) {
+ my ($disposition, undef, %cd_param) = @{$cd[-1]};
+ $file = $cd_param{filename};
+
+ # RFC 2047 encoded?
+ if ($file && $file =~ /^=\?(.+?)\?(.+?)\?(.+)\?=$/) {
+ my $charset = $1;
+ my $encoding = uc($2);
+ my $encfile = $3;
+
+ if ($encoding eq 'Q' || $encoding eq 'B') {
+ local($SIG{__DIE__});
+ eval {
+ if ($encoding eq 'Q') {
+ $encfile =~ s/_/ /g;
+ require MIME::QuotedPrint;
+ $encfile = MIME::QuotedPrint::decode($encfile);
+ }
+ else { # $encoding eq 'B'
+ require MIME::Base64;
+ $encfile = MIME::Base64::decode($encfile);
+ }
+
+ require Encode;
+ require encoding;
+ # This is ugly use of non-public API, but is there
+ # a better way to accomplish what we want (locally
+ # as-is usable filename string)?
+ my $locale_charset = encoding::_get_locale_encoding();
+ Encode::from_to($encfile, $charset, $locale_charset);
+ };
+
+ $file = $encfile unless $@;
+ }
+ }
+ }
+ }
+
+ my $uri;
+ unless (defined($file) && length($file)) {
+ if (my $cl = $self->header('Content-Location')) {
+ $uri = URI->new($cl);
+ }
+ elsif (my $request = $self->request) {
+ $uri = $request->uri;
+ }
+
+ if ($uri) {
+ $file = ($uri->path_segments)[-1];
+ }
+ }
+
+ if ($file) {
+ $file =~ s,.*[\\/],,; # basename
+ }
+
+ if ($file && !length($file)) {
+ $file = undef;
+ }
+
+ $file;
}
@@ -376,8 +448,7 @@
=back
-If neither of these sources provide an absolute URI, undef is
-returned.
+If none of these sources provide an absolute URI, undef is returned.
When the LWP protocol modules produce the HTTP::Response object, then
any base URI embedded in the document (step 1) will already have
@@ -385,6 +456,41 @@
only performs the last 2 steps (the content is not always available
either).
+=item $r->filename
+
+Returns a filename for this response. Note that doing sanity checks
+on the returned filename (eg. removing characters that cannot be used
+on the target filesystem where the filename would be used, and
+laundering it for security purposes) are the caller's responsibility;
+the only related thing done by this method is that it makes a simple
+attempt to return a plain filename with no preceding path segments.
+
+The filename is obtained from one the following sources (in priority
+order):
+
+=over 4
+
+=item 1.
+
+A "Content-Disposition:" header in the response. Proper decoding of
+RFC 2047 encoded filenames requires the C<MIME::QuotedPrint> (for "Q"
+encoding), C<MIME::Base64> (for "B" encoding), and C<Encode> modules.
+
+=item 2.
+
+A "Content-Location:" header in the response.
+
+=item 3.
+
+The URI used to request this response. This might not be the original
+URI that was passed to $ua->request() method, because we might have
+received some redirect responses first.
+
+=back
+
+If a filename cannot be derived from any of these sources, undef is
+returned.
+
=item $r->as_string
=item $r->as_string( $eol )
Modified: branches/upstream/libwww-perl/current/lib/LWP.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwww-perl/current/lib/LWP.pm?rev=23053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/LWP.pm (original)
+++ branches/upstream/libwww-perl/current/lib/LWP.pm Sat Jul 12 11:48:10 2008
@@ -1,6 +1,6 @@
package LWP;
-$VERSION = "5.812";
+$VERSION = "5.813";
sub Version { $VERSION; }
require 5.005;
Modified: branches/upstream/libwww-perl/current/lib/LWP/RobotUA.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwww-perl/current/lib/LWP/RobotUA.pm?rev=23053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/LWP/RobotUA.pm (original)
+++ branches/upstream/libwww-perl/current/lib/LWP/RobotUA.pm Sat Jul 12 11:48:10 2008
@@ -2,7 +2,7 @@
require LWP::UserAgent;
@ISA = qw(LWP::UserAgent);
-$VERSION = "5.810";
+$VERSION = "5.813";
require WWW::RobotRules;
require HTTP::Request;
@@ -48,8 +48,8 @@
my $self = LWP::UserAgent->new(%cnf);
$self = bless $self, $class;
- $self->{'delay'} = 1; # minutes
- $self->{'use_sleep'} = 1;
+ $self->{'delay'} = $delay; # minutes
+ $self->{'use_sleep'} = $use_sleep;
if ($rules) {
$rules->agent($cnf{agent});
Modified: branches/upstream/libwww-perl/current/lib/LWP/UserAgent.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwww-perl/current/lib/LWP/UserAgent.pm?rev=23053&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/LWP/UserAgent.pm (original)
+++ branches/upstream/libwww-perl/current/lib/LWP/UserAgent.pm Sat Jul 12 11:48:10 2008
@@ -5,7 +5,7 @@
require LWP::MemberMixin;
@ISA = qw(LWP::MemberMixin);
-$VERSION = "5.810";
+$VERSION = "5.813";
use HTTP::Request ();
use HTTP::Response ();
@@ -47,6 +47,7 @@
$use_eval = 1 unless defined $use_eval;
my $parse_head = delete $cnf{parse_head};
$parse_head = 1 unless defined $parse_head;
+ my $show_progress = delete $cnf{show_progress};
my $max_size = delete $cnf{max_size};
my $max_redirect = delete $cnf{max_redirect};
$max_redirect = 7 unless defined $max_redirect;
@@ -86,6 +87,7 @@
timeout => $timeout,
use_eval => $use_eval,
parse_head => $parse_head,
+ show_progress=> $show_progress,
max_size => $max_size,
max_redirect => $max_redirect,
proxy => {},
@@ -211,7 +213,7 @@
@{$self}{qw(timeout cookie_jar use_eval parse_head max_size)};
my $response;
- $self->progress("begin");
+ $self->progress("begin", $request);
if ($use_eval) {
# we eval, and turn dies into responses below
eval {
@@ -490,9 +492,36 @@
return $arg;
}
+my @ANI = qw(- \ | /);
+
sub progress {
- my($self, $status, $response) = @_;
- # subclasses might override this
+ my($self, $status, $m) = @_;
+ return unless $self->{show_progress};
+ if ($status eq "begin") {
+ print STDERR "** ", $m->method, " ", $m->uri, " ==> ";
+ $self->{progress_start} = time;
+ $self->{progress_lastp} = "";
+ $self->{progress_ani} = 0;
+ }
+ elsif ($status eq "end") {
+ delete $self->{progress_lastp};
+ delete $self->{progress_ani};
+ print STDERR $m->status_line;
+ my $t = time - delete $self->{progress_start};
+ print STDERR " (${t}s)" if $t;
+ print STDERR "\n";
+ }
+ elsif ($status eq "tick") {
+ print STDERR "$ANI[$self->{progress_ani}++]\b";
+ $self->{progress_ani} %= @ANI;
+ }
+ else {
+ my $p = sprintf "%3.0f%%", $status * 100;
+ return if $p eq $self->{progress_lastp};
+ print STDERR "$p\b\b\b\b";
+ $self->{progress_lastp} = $p;
+ }
+ STDERR->flush;
}
@@ -1017,7 +1046,7 @@
The $netloc a string of the form "<host>:<port>". The username and
password will only be passed to this server. Example:
- $ua->credenticals("www.example.com:80", "Some Realm", "foo", "secret");
+ $ua->credentials("www.example.com:80", "Some Realm", "foo", "secret");
=item $ua->max_size
@@ -1360,7 +1389,7 @@
The base implementation simply checks a set of pre-stored member
variables, set up with the credentials() method.
-=item $ua->progress( $status, $response )
+=item $ua->progress( $status, $request_or_response )
This is called frequently as the response is received regardless of
how the content is processed. The method is called with $status
@@ -1369,6 +1398,9 @@
the fraction of the response currently received or the string "tick"
if the fraction can't be calculated.
+When $status is "begin" the second argument is the request object,
+otherwise it is the response object.
+
=back
=head1 SEE ALSO
Added: branches/upstream/libwww-perl/current/t/html/form-multi-select.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwww-perl/current/t/html/form-multi-select.t?rev=23053&op=file
==============================================================================
--- branches/upstream/libwww-perl/current/t/html/form-multi-select.t (added)
+++ branches/upstream/libwww-perl/current/t/html/form-multi-select.t Sat Jul 12 11:48:10 2008
@@ -1,0 +1,97 @@
+#!/usr/bin/perl
+
+# Test for case when multiple forms are on a page with same-named <select> fields.
+
+use strict;
+use Test::More tests => 2;
+use HTML::Form;
+
+{
+ my $test = "the settings of a previous form should not interfere with a latter form (control test with one form)";
+ my @forms = HTML::Form->parse( FakeResponse::One->new );
+ my $cat_form = $forms[0];
+ my @vals = $cat_form->param('age');
+ is_deeply(\@vals,[''], $test);
+}
+{
+ my $test = "the settings of a previous form should not interfere with a latter form (test with two forms)";
+ my @forms = HTML::Form->parse( FakeResponse::TwoForms->new );
+ my $cat_form = $forms[1];
+
+ my @vals = $cat_form->param('age');
+ is_deeply(\@vals,[''], $test);
+}
+
+####
+package FakeResponse::One;
+sub new {
+ bless {}, shift;
+}
+sub base {
+ return "http://foo.com"
+}
+sub decoded_content {
+ my $html = qq{
+ <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+ <html xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <title></title>
+ </head>
+ <body>
+
+ <form name="search_cats">
+ <select name="age" onChange="jumpTo(this)" class="sap-form-item">
+ <option value="" selected="selected">Any</option>
+ <option value="young">Young</option>
+ <option value="adult">Adult</option>
+ <option value="senior">Senior</option>
+ <option value="puppy">Puppy </option>
+ </select>
+ </form>
+ </body></html>
+ };
+ return \$html;
+}
+
+#####
+package FakeResponse::TwoForms;
+sub new {
+ bless {}, shift;
+}
+sub base {
+ return "http://foo.com"
+}
+sub decoded_content {
+ my $html = qq{
+ <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+ <html xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <title></title>
+ </head>
+ <body>
+ <form name="search_dogs" >
+ <select name="age" onChange="jumpTo(this)" class="sap-form-item">
+ <option value="" selected="selected">Any</option>
+ <option value="young">Young</option>
+ <option value="adult">Adult</option>
+ <option value="senior">Senior</option>
+ <option value="puppy">Puppy </option>
+ </select>
+ </form>
+
+
+ <form name="search_cats">
+ <select name="age" onChange="jumpTo(this)" class="sap-form-item">
+ <option value="" selected="selected">Any</option>
+ <option value="young">Young</option>
+ <option value="adult">Adult</option>
+ <option value="senior">Senior</option>
+ <option value="puppy">Puppy </option>
+ </select>
+ </form>
+ </body></html>
+ };
+ return \$html;
+}
More information about the Pkg-perl-cvs-commits
mailing list