diff --git a/Changes b/Changes
index 5f2b4b6..7ac0c57 100644
--- a/Changes
+++ b/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 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]
diff --git a/Mechanize.pm b/Mechanize.pm
index fd49cf3..b4b2a03 100644
--- a/Mechanize.pm
+++ b/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 attribute, and that each
+C 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
@@ -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
diff --git a/t/lacks_uncapped_inputs-bad.html b/t/lacks_uncapped_inputs-bad.html
new file mode 100644
index 0000000..f834cde
--- /dev/null
+++ b/t/lacks_uncapped_inputs-bad.html
@@ -0,0 +1,15 @@
+
+
+ Title
+
+
+
+
+
diff --git a/t/lacks_uncapped_inputs-good.html b/t/lacks_uncapped_inputs-good.html
new file mode 100644
index 0000000..7e0fdac
--- /dev/null
+++ b/t/lacks_uncapped_inputs-good.html
@@ -0,0 +1,12 @@
+
+
+ Title
+
+
+
+
+
diff --git a/t/lacks_uncapped_inputs.t b/t/lacks_uncapped_inputs.t
new file mode 100644
index 0000000..6c57270
--- /dev/null
+++ b/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();