r39559 - in /trunk/libwww-perl: Changes MANIFEST META.yml debian/changelog lib/HTML/Form.pm lib/LWP.pm lib/LWP/Protocol.pm lib/LWP/UserAgent.pm t/html/form-selector.t t/html/form.t

nhandler-guest at users.alioth.debian.org nhandler-guest at users.alioth.debian.org
Thu Jul 9 17:26:39 UTC 2009


Author: nhandler-guest
Date: Thu Jul  9 17:26:32 2009
New Revision: 39559

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=39559
Log:
Update to 5.829

Added:
    trunk/libwww-perl/t/html/form-selector.t
      - copied unchanged from r39558, branches/upstream/libwww-perl/current/t/html/form-selector.t
Modified:
    trunk/libwww-perl/Changes
    trunk/libwww-perl/MANIFEST
    trunk/libwww-perl/META.yml
    trunk/libwww-perl/debian/changelog
    trunk/libwww-perl/lib/HTML/Form.pm
    trunk/libwww-perl/lib/LWP.pm
    trunk/libwww-perl/lib/LWP/Protocol.pm
    trunk/libwww-perl/lib/LWP/UserAgent.pm
    trunk/libwww-perl/t/html/form.t

Modified: trunk/libwww-perl/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwww-perl/Changes?rev=39559&op=diff
==============================================================================
--- trunk/libwww-perl/Changes (original)
+++ trunk/libwww-perl/Changes Thu Jul  9 17:26:32 2009
@@ -1,3 +1,32 @@
+_______________________________________________________________________________
+2009-07-07  Release 5.829
+
+This release removes callback handlers that were left over on the returned
+HTTP::Responses.  This was problematic because it created reference loops
+preventing the Perl garbage collector from releasing their memory.  Another
+problem was that Storable by default would not serialize these objects any
+more.
+
+This release also adds support for locating HTML::Form inputs by id or class
+attribute; for instance $form->value("#foo", 42) will set the value on the
+input with the ID of "foo".
+
+
+Gisle Aas (5):
+      Make the example code 'use strict' clean by adding a my
+      Avoid cycle in response
+      Clean up handlers has from response after data processing is done
+      Support finding inputs by id or class in HTML::Form
+      Test HTML::Form selectors
+
+Mark Stosberg (1):
+      Tidy and document the internals of mirror() better [RT#23450]
+
+phrstbrn (1):
+      Avoid warnings from HTML::Form [RT#42654]
+
+
+
 _______________________________________________________________________________
 2009-06-25  Release 5.828
 

Modified: trunk/libwww-perl/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwww-perl/MANIFEST?rev=39559&op=diff
==============================================================================
--- trunk/libwww-perl/MANIFEST (original)
+++ trunk/libwww-perl/MANIFEST Thu Jul  9 17:26:32 2009
@@ -93,6 +93,7 @@
 t/html/form-param.t		More HTML::Form tests.
 t/html/form-multi-select.t      More HTML::Form tests
 t/html/form-maxlength.t         More HTML::Form tests
+t/html/form-selector.t		More HTML::Form tests
 t/live/apache.t
 t/live/apache-listing.t		Test File::Listing::apache package
 t/live/https.t

Modified: trunk/libwww-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwww-perl/META.yml?rev=39559&op=diff
==============================================================================
--- trunk/libwww-perl/META.yml (original)
+++ trunk/libwww-perl/META.yml Thu Jul  9 17:26:32 2009
@@ -1,6 +1,6 @@
 --- #YAML:1.0
 name:               libwww-perl
-version:            5.828
+version:            5.829
 abstract:           The World-Wide Web library for Perl
 author:
     - Gisle Aas <gisle at activestate.com>

Modified: trunk/libwww-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwww-perl/debian/changelog?rev=39559&op=diff
==============================================================================
--- trunk/libwww-perl/debian/changelog (original)
+++ trunk/libwww-perl/debian/changelog Thu Jul  9 17:26:32 2009
@@ -1,3 +1,9 @@
+libwww-perl (5.829-1) UNRELEASED; urgency=low
+
+  * (NOT RELEASED YET) New upstream release
+
+ -- Nathan Handler <nhandler at ubuntu.com>  Thu, 09 Jul 2009 17:24:39 +0000
+
 libwww-perl (5.828-1) unstable; urgency=low
 
   * New upstream release

Modified: trunk/libwww-perl/lib/HTML/Form.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwww-perl/lib/HTML/Form.pm?rev=39559&op=diff
==============================================================================
--- trunk/libwww-perl/lib/HTML/Form.pm (original)
+++ trunk/libwww-perl/lib/HTML/Form.pm Thu Jul  9 17:26:32 2009
@@ -5,7 +5,7 @@
 use Carp ();
 
 use vars qw($VERSION $Encode_available);
-$VERSION = "5.827";
+$VERSION = "5.829";
 
 eval { require Encode };
 $Encode_available = !$@;
@@ -242,7 +242,9 @@
 			    if exists $attr->{$_};
 		    }
 		    # count this new select option separately
-		    $openselect{$attr->{name}}++;
+		    my $name = $attr->{name};
+		    $name = "" unless defined $name;
+		    $openselect{$name}++;
 
 		    while ($t = $p->get_tag) {
 			my $tag = shift @$t;
@@ -262,7 +264,7 @@
 			    $a{value_name} = $p->get_trimmed_text;
 			    $a{value} = delete $a{value_name}
 				unless defined $a{value};
-			    $a{idx} = $openselect{$attr->{name}};
+			    $a{idx} = $openselect{$name};
 			    $f->push_input("option", \%a, $verbose);
 			}
 			else {
@@ -452,17 +454,20 @@
 }
 
 
-=item $input = $form->find_input( $name )
-
-=item $input = $form->find_input( $name, $type )
-
-=item $input = $form->find_input( $name, $type, $index )
+=item $input = $form->find_input( $selector )
+
+=item $input = $form->find_input( $selector, $type )
+
+=item $input = $form->find_input( $selector, $type, $index )
 
 This method is used to locate specific inputs within the form.  All
 inputs that match the arguments given are returned.  In scalar context
 only the first is returned, or C<undef> if none match.
 
-If $name is specified, then the input must have the indicated name.
+If $selector is specified, then the input's name, id, class attribute must
+match.  A selector prefixed with '#' must match the id attribute of the input.
+A selector prefixed with '.' matches the class attribute.  A selector prefixed
+with '^' or with no prefix matches the name attribute.
 
 If $type is specified, then the input must have the specified type.
 The following type names are used: "text", "password", "hidden",
@@ -481,10 +486,7 @@
 	my @res;
 	my $c;
 	for (@{$self->{'inputs'}}) {
-	    if (defined $name) {
-		next unless exists $_->{name};
-		next if $name ne $_->{name};
-	    }
+	    next if defined($name) && !$_->selected($name);
 	    next if $type && $type ne $_->{type};
 	    $c++;
 	    next if $no && $no != $c;
@@ -496,10 +498,7 @@
     else {
 	$no ||= 1;
 	for (@{$self->{'inputs'}}) {
-	    if (defined $name) {
-		next unless exists $_->{name};
-		next if $name ne $_->{name};
-	    }
+	    next if defined($name) && !$_->selected($name);
 	    next if $type && $type ne $_->{type};
 	    next if --$no;
 	    return $_;
@@ -517,9 +516,9 @@
 }
 
 
-=item $value = $form->value( $name )
-
-=item $form->value( $name, $new_value )
+=item $value = $form->value( $selector )
+
+=item $form->value( $selector, $new_value )
 
 The value() method can be used to get/set the value of some input.  If
 strict is enabled and no input has the indicated name, then this method will croak.
@@ -720,23 +719,24 @@
 
 =item $request = $form->click
 
-=item $request = $form->click( $name )
+=item $request = $form->click( $selector )
 
 =item $request = $form->click( $x, $y )
 
-=item $request = $form->click( $name, $x, $y )
+=item $request = $form->click( $selector, $x, $y )
 
 Will "click" on the first clickable input (which will be of type
 C<submit> or C<image>).  The result of clicking is an C<HTTP::Request>
 object that can then be passed to C<LWP::UserAgent> if you want to
 obtain the server response.
 
-If a $name is specified, we will click on the first clickable input
-with the given name, and the method will croak if no clickable input
-with the given name is found.  If $name is I<not> specified, then it
+If a $selector is specified, we will click on the first clickable input
+matching the selector, and the method will croak if no matching clickable
+input is found.  If $selector is I<not> specified, then it
 is ok if the form contains no clickable inputs.  In this case the
 click() method returns the same request as the make_request() method
-would do.
+would do.  See description of the find_input() method above for how
+the $selector is specified.
 
 If there are multiple clickable inputs with the same name, then there
 is no way to get the click() method of the C<HTML::Form> to click on
@@ -761,7 +761,7 @@
     # try to find first submit button to activate
     for (@{$self->{'inputs'}}) {
         next unless $_->can("click");
-        next if $name && $_->name ne $name;
+        next if $name && !$_->selected($name);
 	next if $_->disabled;
 	return $_->click($self, @_);
     }
@@ -896,6 +896,17 @@
 
 This method can be used to get/set the current name of the input.
 
+=item $input->id
+
+=item $input->class
+
+These methods can be used to get/set the current id or class attribute for the input.
+
+=item $input->selected( $selector )
+
+Returns TRUE if the given selector matched the input.  See the description of
+the find_input() method above for a description of the selector syntax.
+
 =item $value = $input->value
 
 =item $input->value( $new_value )
@@ -918,6 +929,34 @@
     my $old = $self->{name};
     $self->{name} = shift if @_;
     $old;
+}
+
+sub id
+{
+    my $self = shift;
+    my $old = $self->{id};
+    $self->{id} = shift if @_;
+    $old;
+}
+
+sub class
+{
+    my $self = shift;
+    my $old = $self->{class};
+    $self->{class} = shift if @_;
+    $old;
+}
+
+sub selected {
+    my($self, $sel) = @_;
+    return undef unless defined $sel;
+    my $attr =
+        $sel =~ s/^\^// ? "name"  :
+        $sel =~ s/^#//  ? "id"    :
+        $sel =~ s/^\.// ? "class" :
+	                  "name";
+    return 0 unless defined $self->{$attr};
+    return $self->{$attr} eq $sel;
 }
 
 sub value

Modified: trunk/libwww-perl/lib/LWP.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwww-perl/lib/LWP.pm?rev=39559&op=diff
==============================================================================
--- trunk/libwww-perl/lib/LWP.pm (original)
+++ trunk/libwww-perl/lib/LWP.pm Thu Jul  9 17:26:32 2009
@@ -1,6 +1,6 @@
 package LWP;
 
-$VERSION = "5.828";
+$VERSION = "5.829";
 sub Version { $VERSION; }
 
 require 5.005;
@@ -295,7 +295,7 @@
 
   # Create a user agent object
   use LWP::UserAgent;
-  $ua = LWP::UserAgent->new;
+  my $ua = LWP::UserAgent->new;
   $ua->agent("MyApp/0.1 ");
 
   # Create a request

Modified: trunk/libwww-perl/lib/LWP/Protocol.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwww-perl/lib/LWP/Protocol.pm?rev=39559&op=diff
==============================================================================
--- trunk/libwww-perl/lib/LWP/Protocol.pm (original)
+++ trunk/libwww-perl/lib/LWP/Protocol.pm Thu Jul  9 17:26:32 2009
@@ -2,7 +2,7 @@
 
 require LWP::MemberMixin;
 @ISA = qw(LWP::MemberMixin);
-$VERSION = "5.826";
+$VERSION = "5.829";
 
 use strict;
 use Carp ();
@@ -161,9 +161,12 @@
             }
         }
     };
-    if ($@) {
-        chomp($@);
-        $response->push_header('X-Died' => $@);
+    my $err = $@;
+    delete $response->{handlers}{response_data};
+    delete $response->{handlers} unless %{$response->{handlers}};
+    if ($err) {
+        chomp($err);
+        $response->push_header('X-Died' => $err);
         $response->push_header("Client-Aborted", "die");
         return $response;
     }

Modified: trunk/libwww-perl/lib/LWP/UserAgent.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwww-perl/lib/LWP/UserAgent.pm?rev=39559&op=diff
==============================================================================
--- trunk/libwww-perl/lib/LWP/UserAgent.pm (original)
+++ trunk/libwww-perl/lib/LWP/UserAgent.pm Thu Jul  9 17:26:32 2009
@@ -5,7 +5,7 @@
 
 require LWP::MemberMixin;
 @ISA = qw(LWP::MemberMixin);
-$VERSION = "5.827";
+$VERSION = "5.829";
 
 use HTTP::Request ();
 use HTTP::Response ();
@@ -595,8 +595,9 @@
 		       return unless $parser;
 		       unless ($parser->parse($_[3])) {
 			   my $h = $parser->header;
+			   my $r = $_[0];
 			   for my $f ($h->header_field_names) {
-			       $response->init_header($f, [$h->header($f)]);
+			       $r->init_header($f, [$h->header($f)]);
 			   }
 			   undef($parser);
 		       }
@@ -823,47 +824,50 @@
 
     my $request = HTTP::Request->new('GET', $url);
 
-    if (-e $file) {
-	my($mtime) = (stat($file))[9];
-	if($mtime) {
-	    $request->header('If-Modified-Since' =>
-			     HTTP::Date::time2str($mtime));
-	}
+    # If the file exists, add a cache-related header
+    if ( -e $file ) {
+        my ($mtime) = ( stat($file) )[9];
+        if ($mtime) {
+            $request->header( 'If-Modified-Since' => HTTP::Date::time2str($mtime) );
+        }
     }
     my $tmpfile = "$file-$$";
 
     my $response = $self->request($request, $tmpfile);
-    if ($response->is_success) {
-
-	my $file_length = (stat($tmpfile))[7];
-	my($content_length) = $response->header('Content-length');
-
-	if (defined $content_length and $file_length < $content_length) {
-	    unlink($tmpfile);
-	    die "Transfer truncated: " .
-		"only $file_length out of $content_length bytes received\n";
-	}
-	elsif (defined $content_length and $file_length > $content_length) {
-	    unlink($tmpfile);
-	    die "Content-length mismatch: " .
-		"expected $content_length bytes, got $file_length\n";
-	}
-	else {
-	    # OK
-	    if (-e $file) {
-		# Some dosish systems fail to rename if the target exists
-		chmod 0777, $file;
-		unlink $file;
-	    }
-	    rename($tmpfile, $file) or
-		die "Cannot rename '$tmpfile' to '$file': $!\n";
-
-	    if (my $lm = $response->last_modified) {
-		# make sure the file has the same last modification time
-		utime $lm, $lm, $file;
-	    }
-	}
-    }
+
+    # Only fetching a fresh copy of the would be considered success.
+    # If the file was not modified, "304" would returned, which 
+    # is considered by HTTP::Status to be a "redirect", /not/ "success"
+    if ( $response->is_success ) {
+        my $file_length = ( stat($tmpfile) )[7];
+        my ($content_length) = $response->header('Content-length');
+
+        if ( defined $content_length and $file_length < $content_length ) {
+            unlink($tmpfile);
+            die "Transfer truncated: " . "only $file_length out of $content_length bytes received\n";
+        }
+        elsif ( defined $content_length and $file_length > $content_length ) {
+            unlink($tmpfile);
+            die "Content-length mismatch: " . "expected $content_length bytes, got $file_length\n";
+        }
+        # The file was the expected length. 
+        else {
+            # Replace the stale file with a fresh copy
+            if ( -e $file ) {
+                # Some dosish systems fail to rename if the target exists
+                chmod 0777, $file;
+                unlink $file;
+            }
+            rename( $tmpfile, $file )
+                or die "Cannot rename '$tmpfile' to '$file': $!\n";
+
+            # make sure the file has the same last modification time
+            if ( my $lm = $response->last_modified ) {
+                utime $lm, $lm, $file;
+            }
+        }
+    }
+    # The local copy is fresh enough, so just delete the temp file  
     else {
 	unlink($tmpfile);
     }

Modified: trunk/libwww-perl/t/html/form.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwww-perl/t/html/form.t?rev=39559&op=diff
==============================================================================
--- trunk/libwww-perl/t/html/form.t (original)
+++ trunk/libwww-perl/t/html/form.t Thu Jul  9 17:26:32 2009
@@ -3,7 +3,7 @@
 use strict;
 use Test qw(plan ok);
 
-plan tests => 126;
+plan tests => 127;
 
 use HTML::Form;
 
@@ -581,3 +581,15 @@
 EOT
 ok(join(":", $f->find_input("test")->possible_values), "1:2");
 ok(join(":", $f->find_input("test")->other_possible_values), "2");
+
+ at warn = ();
+$f = HTML::Form->parse(<<EOT, "http://www.example.com");
+<form>
+<select id="myselect">
+<option>one</option>
+<option>two</option>
+<option>three</option>
+</select>
+</form>
+EOT
+ok(@warn, 0);




More information about the Pkg-perl-cvs-commits mailing list