Added ->grep_submits(), ->grep_inputs() and ->lacks_uncapped_inputs()

Changes

@@ -4,6 +4,18 @@ WWW::Mechanize and Test::WWW::Mechanize do not use rt.cpan.org for
 bug tracking.  They are now being tracked via Google Code at
 http://code.google.com/p/www-mechanize/issues/list
 
+1.31_02 Fri Jul  1 16:45:55 CDT 2011
+------------------------------------
+[ENHANCEMENTS]
+Added $mech->lacks_uncapped_inputs() to check for <input> tags that
+don't have a maxlength attribute.  We've been using this for years at
+work, and I'm just now moving it into Test::WWW::Mechanize.
+
+Added $mech->grep_inputs() and $mech->grep_submits() to easily pull
+input fields from the page.  I'd like to get this moved up to base
+WWW::Mechanize, because it has use outside of the Test:: world.
+
+
 1.31_01 Wed May  4 16:07:31 CDT 2011
 ------------------------------------
 [ENHANCEMENTS]

Mechanize.pm

@@ -1317,6 +1317,145 @@ sub stuff_inputs {
     return;
 }
 
+
+
+=head2 $mech->lacks_uncapped_inputs( [$comment] )
+
+Executes a test to make sure that the current form content has no
+text input fields that lack the C<maxlength> attribute, and that each
+C<maxlength> value is a positive integer.  The test fails if the current
+form has such a field, and succeeds otherwise.
+
+Returns an array containing all text input fields in the current
+form that do not specify a maximum input length.  Fields for which
+the concept of input length is irrelevant, and controls that HTML
+does not allow to be capped (e.g. textarea) are ignored.
+
+The inputs in the returned array are descended from HTML::Form::Input.
+
+The return is true if the test succeeded, false otherwise.
+
+=cut
+
+sub lacks_uncapped_inputs {
+    my $self    = shift;
+    my $comment = shift;
+
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+    my @uncapped;
+
+    my @inputs = $self->grep_inputs( { type => qr/^(?:text|password)$/ } );
+    foreach my $field ( @inputs ) {
+        next if $field->readonly();
+        next if $field->disabled();
+
+        if ( not defined($field->{maxlength}) ) {
+            push( @uncapped, $field->name . ' has no maxlength attribute' );
+            next;
+        }
+
+        my $val = $field->{maxlength};
+        if ( ($val !~ /^\s*\d+\s*$/) || ($val+0 <= 0) ) {
+            push( @uncapped, $field->name . qq{ has an invalid maxlength attribute of "$val"} );
+        }
+    }
+
+    my $ok = $Test->cmp_ok( scalar @uncapped, '==', 0, $comment );
+    $Test->diag( $_ ) for @uncapped;
+
+    return $ok;
+}
+
+=head2 $mech->grep_inputs( \%properties )
+
+grep_inputs() returns an array of all the input controls in the
+current form whose properties match all of the regexes in $properties.
+The controls returned are all descended from HTML::Form::Input.
+
+If $properties is undef or empty then all inputs will be
+returned.
+
+If there is no current page, there is no form on the current
+page, or there are no submit controls in the current form
+then the return will be an empty array.
+
+    # get all text controls whose names begin with "customer"
+    my @customer_text_inputs =
+        $mech->grep_inputs( {
+            type => qr/^(text|textarea)$/,
+            name => qr/^customer/
+        }
+    );
+
+=cut
+
+sub grep_inputs {
+    my $self = shift;
+    my $properties = shift;
+
+    my @found;
+
+    my $form = $self->current_form();
+    if ( $form ) {
+        my @inputs = $form->inputs();
+        @found = _grep_hashes( \@inputs, $properties );
+    }
+
+    return @found;
+}
+
+
+=head2 $mech->grep_submits( \%properties )
+
+grep_submits() does the same thing as grep_inputs() except that
+it only returns controls that are submit controls, ignoring
+other types of input controls like text and checkboxes.
+
+=cut
+
+sub grep_submits {
+    my $self = shift;
+    my $properties = shift || {};
+
+    $properties->{type} = qr/^(?:submit|image)$/;  # submits only
+    my @found = $self->grep_inputs( $properties );
+
+    return @found;
+}
+
+# search an array of hashrefs, returning an array of the incoming
+# hashrefs that match *all* the pattern in $patterns.
+sub _grep_hashes {
+    my $hashes = shift;
+    my $patterns = shift || {};
+
+    my @found;
+
+    if ( ! %{$patterns} ) {
+        # nothing to match on, so return them all
+        @found = @{$hashes};
+    }
+    else {
+        foreach my $hash ( @{$hashes} ) {
+
+            # check every pattern for a match on the current hash
+            my $matches_everything = 1;
+            foreach my $patternKey ( keys %{$patterns} ) {
+                $matches_everything = 0 unless exists $hash->{$patternKey} && $hash->{$patternKey} =~ $patterns->{$patternKey};
+                last if !$matches_everything;
+            }
+
+            push @found, $hash if $matches_everything;
+        }
+    }
+
+    return @found;
+}
+
+
+
+
 =head1 TODO
 
 Add HTML::Tidy capabilities.
@@ -1344,7 +1483,7 @@ You can also look for information at:
 
 =over 4
 
-=item * Google Code bug tracker
+=item * Bug tracker
 
 L<http://code.google.com/p/www-mechanize/issues/list>
 
@@ -1385,18 +1524,8 @@ and Pete Krawczyk for patches.
 
 Copyright 2004-2011 Andy Lester.
 
-This program is free software; you can redistribute it and/or
-modify it under the terms of either:
-
-=over 4
-
-=item * the GNU General Public License as published by the Free
-Software Foundation; either version 1, or (at your option) any
-later version, or
-
-=item * the Artistic License version 2.0.
-
-=back
+This program is free software; you can redistribute it and/or modify it
+under the terms of the Artistic License version 2.0.
 
 =cut
 

t/lacks_uncapped_inputs-bad.html

@@ -0,0 +1,15 @@
+<html>
+    <head>
+        <title>Title</title>
+    </head>
+    <body>
+        <form name="testform">
+            <input name="foo" type="text" size="12"> <!-- this is one bad one with a missin maxlength -->
+            <input name="bar" type="radio">
+            <input name="bat" type="text" disabled> <!-- no maxlength, but disabled so it's OK -->
+            <input name="baz" type="text" maxlength=" 14 "> <!-- spaces shouldn't be a problem -->
+            <input name="quux" type="text" size="12" maxlength="dogs"> <!-- not an integer -->
+            <input name="crunchy" type="text" size="12" maxlength="-1"> <!-- negative -->
+        </form>
+    </body>
+</html>

t/lacks_uncapped_inputs-good.html

@@ -0,0 +1,12 @@
+<html>
+    <head>
+        <title>Title</title>
+    </head>
+    <body>
+        <form name="testform">
+            <input name="foo" type="text" size="12" maxlength="14">
+            <input name="bar" type="radio">
+            <input name="bat" type="text" disabled> <!-- no maxlength, but disabled so it's OK -->
+        </form>
+    </body>
+</html>

t/lacks_uncapped_inputs.t

@@ -0,0 +1,41 @@
+#!perl -w
+
+use strict;
+use warnings;
+use Test::More tests => 4;
+use Test::Builder::Tester;
+
+use URI::file;
+
+BEGIN {
+    use_ok( 'Test::WWW::Mechanize' );
+}
+
+my $mech = Test::WWW::Mechanize->new();
+isa_ok( $mech,'Test::WWW::Mechanize' );
+
+GOOD: {
+    my $uri = URI::file->new_abs( 't/lacks_uncapped_inputs-good.html' )->as_string;
+    $mech->get( $uri );
+
+    test_out( 'ok 1 - This should have no failures' );
+    $mech->lacks_uncapped_inputs( 'This should have no failures' );
+    test_test( 'Finds the lacks' );
+}
+
+BAD: {
+    my $uri = URI::file->new_abs( 't/lacks_uncapped_inputs-bad.html' )->as_string;
+    $mech->get( $uri );
+
+    test_out( 'not ok 1 - This should have three errors found' );
+    test_fail( +6 );
+    test_diag( q{         got: 3} );
+    test_diag( q{    expected: 0} );
+    test_diag( q{foo has no maxlength attribute} );
+    test_diag( q{quux has an invalid maxlength attribute of "dogs"} );
+    test_diag( q{crunchy has an invalid maxlength attribute of "-1"} );
+    $mech->lacks_uncapped_inputs( 'This should have three errors found' );
+    test_test( 'Detect uncapped' );
+}
+
+done_testing();