Test-WWW-Mechanize-1.60/0000755000175000017500000000000014343270553013420 5ustar andyandyTest-WWW-Mechanize-1.60/t/0000755000175000017500000000000014343270552013662 5ustar andyandyTest-WWW-Mechanize-1.60/t/head_ok-parms.t0000644000175000017500000000237214343263442016565 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 15; use Test::Builder::Tester; use Test::WWW::Mechanize; my $ua_args; sub Test::WWW::Mechanize::success { return 1; } sub Test::WWW::Mechanize::head { my $self = shift; my $url = shift; die 'Odd number of args sent in' if @_ % 2 != 0; $ua_args = {@_}; return 1; } my $mech = Test::WWW::Mechanize->new(); isa_ok( $mech, 'Test::WWW::Mechanize' ); my $url = 'dummy://url'; $mech->head_ok( $url ); ok( eq_hash( {}, $ua_args ), 'passing URL only' ); $mech->head_ok( $url, 'Description' ); ok( eq_hash( {}, $ua_args ), 'Passing description' ); $mech->head_ok( $url, undef, 'Description' ); ok( eq_hash( {}, $ua_args ), 'Passing undef for hash' ); my $wanted = { foo=>1, bar=>2, baz=>3 }; $mech->head_ok( $url, [ %{$wanted} ] ); ok( eq_hash( $wanted, $ua_args ), 'Passing anonymous list for hash' ); $mech->head_ok( $url, [ %{$wanted} ], 'Description' ); ok( eq_hash( $wanted, $ua_args ), 'Passing anonymous list for hash' ); $mech->head_ok( $url, { %{$wanted} } ); ok( eq_hash( $wanted, $ua_args ), 'Passing anonymous array for hash' ); $mech->head_ok( $url, { %{$wanted} }, 'Description' ); ok( eq_hash( $wanted, $ua_args ), 'Passing anonymous array for hash' ); done_testing (); Test-WWW-Mechanize-1.60/t/lacks_uncapped_inputs-bad.html0000644000175000017500000000147014343263442021654 0ustar andyandy Title
Test-WWW-Mechanize-1.60/t/button_exists.t0000644000175000017500000000116014343263442016757 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 6; use Test::WWW::Mechanize (); use URI::file (); my $mech = Test::WWW::Mechanize->new(); isa_ok( $mech,'Test::WWW::Mechanize' ); my $uri = URI::file->new_abs( 't/html/form.html' )->as_string; $mech->get_ok( $uri ); ok( $mech->button_exists( 'big_button' ), 'Found a button that is there' ); ok( !$mech->button_exists( 'little_button' ), 'Not found button that is not there' ); $mech->button_exists_ok( 'big_button', 'Found a button that is there' ); $mech->lacks_button_ok( 'little_button', 'Not found button that is not there' ); done_testing(); exit 0 Test-WWW-Mechanize-1.60/t/html_tidy_ok.t0000644000175000017500000000372014343263442016537 0ustar andyandy#!perl -T use strict; use warnings; use Test::Builder::Tester; use Test::More; use Test::WWW::Mechanize; use URI::file; BEGIN { my $module = 'HTML::Tidy5 1.00'; if ( not eval "use $module; 1;" ) { plan skip_all => "Optional $module is not installed, cannot test html_tidy_ok" if $@; } plan tests => 7; } GOOD_GET: { my $mech = Test::WWW::Mechanize->new; isa_ok( $mech, 'Test::WWW::Mechanize' ); my $uri = URI::file->new_abs( 't/bad.html' )->as_string; $mech->get_ok( $uri, 'Fetching the file from disk' ); test_out( "not ok 1 - checking HTML ($uri)" ); test_fail( +6 ); test_err( "# HTML::Tidy5 messages for $uri" ); test_err( '# (1:1) Warning: missing declaration' ); test_err( '# (8:33) Warning: discarding unexpected ' ); test_err( '# (8:9) Warning: missing ' ); test_err( '# 3 messages on the page' ); $mech->html_tidy_ok( 'checking HTML' ); test_test( 'Proper html_tidy_ok results' ); } CONTENT_FOR_VALIDATION: { my $mech = My::Subclass->new; isa_ok( $mech, 'My::Subclass' ); isa_ok( $mech, 'Test::WWW::Mechanize' ); my $uri = URI::file->new_abs( 't/bad.html' )->as_string; $mech->get_ok( $uri, 'Fetching the file from disk' ); test_out( "not ok 1 - checking HTML ($uri)" ); test_fail( +4 ); test_err( "# HTML::Tidy5 messages for $uri" ); test_err( '# (9:9) Warning: missing ' ); test_err( '# 1 message on the page' ); $mech->html_tidy_ok( 'checking HTML' ); test_test( 'Proper html_tidy_ok results after modifying the contents before tidying' ); } done_testing(); exit 0; package My::Subclass; use parent 'Test::WWW::Mechanize'; sub content_for_tidy { my $self = shift; my $content = $self->content; # Fix the missing DOCTYPE. $content = "\n$content"; # Change the to something innocuous. $content =~ s{}{
}; # We're still leaving the unclosed . return $content; } Test-WWW-Mechanize-1.60/t/delete_ok.t0000644000175000017500000000323614343270541016004 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 10; use Test::Builder::Tester; use Test::WWW::Mechanize (); use lib 't'; use TestServer; my $server = TestServer->new; my $pid = $server->background; my $server_root = $server->root; GOOD_DELETE: { local @ENV{qw( http_proxy HTTP_PROXY )}; my $mech = Test::WWW::Mechanize->new( autocheck => 0 ); isa_ok($mech,'Test::WWW::Mechanize'); my $scratch = "$server_root/scratch.html"; $mech->delete_ok($scratch); ok($mech->success, 'sanity check: we can load scratch.html'); test_out('ok 1 - Try to DELETE scratch.html'); my $ok = $mech->delete_ok($scratch, 'Try to DELETE scratch.html'); test_test('DELETEs existing URI and reports success'); is( ref($ok), '', 'delete_ok() should only return a scalar' ); ok( $ok, 'And the result should be true' ); # default desc test_out("ok 1 - DELETE $scratch"); $mech->delete_ok($scratch); test_test('DELETEs existing URI and reports success - default desc'); # For old LWP::UA undef *Test::WWW::Mechanize::can; *Test::WWW::Mechanize::can = sub { return undef; }; $mech->delete_ok($scratch); ok($mech->success, 'sanity check: we can load scratch.html by old LWP::UA'); undef *Test::WWW::Mechanize::can; *Test::WWW::Mechanize::can = *UNIVERSAL::can{CODE}; } UNDEF_URL: { my $mech = Test::WWW::Mechanize->new(); test_out( 'not ok 1 - Passing undef for a URL' ); test_fail( +2 ); test_diag( 'URL cannot be undef.' ); my $ok = $mech->delete_ok( undef, 'Passing undef for a URL' ); test_test( 'Undef URLs' ); } $server->stop; done_testing(); exit 0; Test-WWW-Mechanize-1.60/t/badlinks.html0000644000175000017500000000041114343263442016333 0ustar andyandy Test Page Test Page good Test Test Test Test-WWW-Mechanize-1.60/t/get_ok-parms.t0000644000175000017500000000227014343263442016440 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 15; use Test::Builder::Tester; use Test::WWW::Mechanize; my $ua_args; sub Test::WWW::Mechanize::success { return 1; } sub Test::WWW::Mechanize::get { my $self = shift; my $url = shift; $ua_args = {@_}; return 1; } my $mech = Test::WWW::Mechanize->new(); isa_ok( $mech, 'Test::WWW::Mechanize' ); my $url = 'dummy://url'; $mech->get_ok( $url ); ok( eq_hash( {}, $ua_args ), 'passing URL only' ); $mech->get_ok( $url, 'Description' ); ok( eq_hash( {}, $ua_args ), 'Passing description' ); $mech->get_ok( $url, undef, 'Description' ); ok( eq_hash( {}, $ua_args ), 'Passing undef for hash' ); my $wanted = { foo=>1, bar=>2, baz=>3 }; $mech->get_ok( $url, [ %{$wanted} ] ); ok( eq_hash( $wanted, $ua_args ), 'Passing anonymous list for hash' ); $mech->get_ok( $url, [ %{$wanted} ], 'Description' ); ok( eq_hash( $wanted, $ua_args ), 'Passing anonymous list for hash' ); $mech->get_ok( $url, { %{$wanted} } ); ok( eq_hash( $wanted, $ua_args ), 'Passing anonymous array for hash' ); $mech->get_ok( $url, { %{$wanted} }, 'Description' ); ok( eq_hash( $wanted, $ua_args ), 'Passing anonymous array for hash' ); done_testing(); Test-WWW-Mechanize-1.60/t/content_contains.t0000644000175000017500000000350314343263442017420 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 21; use Test::Builder::Tester; use URI::file; use Test::WWW::Mechanize (); my $mech = Test::WWW::Mechanize->new(); isa_ok( $mech,'Test::WWW::Mechanize' ); my $uri = URI::file->new_abs( 't/goodlinks.html' )->as_string; $mech->get_ok( $uri ); for my $method ( qw( content_contains content_lacks text_contains text_lacks ) ) { for my $ref ( {}, [], qr/foo/, sub {} ) { test_out( "not ok 1 - Test::WWW::Mechanize->$method called incorrectly. It requires a scalar, not a reference." ); test_fail( +1 ); $mech->$method( $ref, 'Passing ref fails' ); my $type = ref( $ref ); test_test( "Passing a $type reference to $method() fails" ); } } # test success test_out( 'ok 1 - Does it say test page?' ); $mech->content_contains( 'Test Page', 'Does it say test page?' ); test_test( 'Finds the contains' ); # default desc test_out( 'ok 1 - Content contains "Test Page"' ); $mech->content_contains( 'Test Page'); test_test( 'Finds the contains - default desc' ); # test failure test_out( 'not ok 1 - Where is Mungo?' ); test_fail(+13); if ( $^O eq 'MSWin32' ) { test_diag(q( searched: "\x{0d}\x{0a} \x{0d}\x{0a} Test Page</titl"...) ); test_diag(q( can't find: "Mungo") ); test_diag(q( LCSS: "go")); test_diag(q(LCSS context: ">\x{0d}\x{0a} <h1>Test Page</h1>\x{0d}\x{0a} <a href="go")); } else { test_diag(q( searched: "<html>\x{0a} <head>\x{0a} <title>Test Page"...) ); test_diag(q( can't find: "Mungo") ); test_diag(q( LCSS: "go")); test_diag(q(LCSS context: "dy>\x{0a}

Test Page

\x{0a} content_contains( 'Mungo', 'Where is Mungo?' ); test_test( 'Handles not finding it' ); done_testing(); Test-WWW-Mechanize-1.60/t/follow_link_ok.t0000644000175000017500000000223014343263442017054 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 6; use Test::Builder::Tester; use URI::file (); use Test::WWW::Mechanize (); FOLLOW_GOOD_LINK: { my $mech = Test::WWW::Mechanize->new( autocheck => 0 ); isa_ok( $mech,'Test::WWW::Mechanize' ); my $uri = URI::file->new_abs( 't/goodlinks.html' )->as_string; $mech->get_ok( $uri ); test_out( 'ok 1 - Go after first link' ); $mech->follow_link_ok( {n=>1}, 'Go after first link' ); test_test( 'Handles good links' ); } FOLLOW_BAD_LINK: { my $mech = Test::WWW::Mechanize->new( autocheck => 0 ); isa_ok( $mech, 'Test::WWW::Mechanize' ); my $uri = URI::file->new_abs( 't/badlinks.html' ); my $bad_uri = $uri->as_string; my $path = $uri->file; s{\Qbadlinks.html}{bad1.html} for ( $path, $bad_uri ); $mech->get_ok( $uri->as_string ); test_out('not ok 1 - Go after bad link'); test_fail(+4); test_diag( $bad_uri ); test_diag( 404 ); # XXX Who is printing this 404, and should it be? test_diag( qq{File `$path' does not exist} ); $mech->follow_link_ok( {n=>2}, 'Go after bad link' ); test_test('Handles bad links'); } done_testing(); Test-WWW-Mechanize-1.60/t/link_status.t0000644000175000017500000000276014343263442016414 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 9; use Test::Builder::Tester; use URI::file; use Test::WWW::Mechanize (); my $mech = Test::WWW::Mechanize->new( autocheck => 0 ); isa_ok( $mech,'Test::WWW::Mechanize' ); my $uri = URI::file->new_abs( 't/goodlinks.html' )->as_string; $mech->get_ok( $uri ); # Good links. my $links=$mech->links(); test_out('ok 1 - Checking all links status are 200'); $mech->link_status_is($links,200,'Checking all links status are 200'); test_test('Handles All Links successful'); # Good links - Default desc test_out('ok 1 - ' . scalar(@{$links}) . ' links have status 200'); $mech->link_status_is($links,200); test_test('Handles All Links successful - default desc'); $mech->link_status_isnt($links,404,'Checking all links isnt'); # Bad links $uri = URI::file->new_abs( 't/badlinks.html' )->as_string; $mech->get_ok( $uri ); $links=$mech->links(); test_out('not ok 1 - Checking all links some bad'); test_fail(+2); test_diag('goodlinks.html'); $mech->link_status_is($links,404,'Checking all links some bad'); test_test('Handles bad links'); test_out('not ok 1 - Checking specified link not found'); test_fail(+2); test_diag('test2.html'); $mech->links_ok('test2.html','Checking specified link not found'); test_test('Handles link not found'); test_out('not ok 1 - Checking all links not 200'); test_fail(+2); test_diag('goodlinks.html'); $mech->link_status_isnt($links,200,'Checking all links not 200'); test_test('Handles all links mismatch'); done_testing(); Test-WWW-Mechanize-1.60/t/html_lint_ok.t0000644000175000017500000000202214343263442016526 0ustar andyandy#!perl -T use strict; use warnings; use Test::Builder::Tester; use Test::More; use Test::WWW::Mechanize; use URI::file; BEGIN { # Load HTML::Lint here for the imports my $module = 'HTML::Lint 2.20'; if ( not eval "use $module; 1;" ) { plan skip_all => "$module is not installed, cannot test html_lint_ok" if $@; } plan tests => 3; } GOOD_GET: { my $mech = Test::WWW::Mechanize->new; isa_ok( $mech, 'Test::WWW::Mechanize' ); my $uri = URI::file->new_abs( 't/bad.html' )->as_string; $mech->get_ok( $uri, 'Fetching the file from disk' ); test_out( "not ok 1 - checking HTML ($uri)" ); test_fail( +6 ); test_err( "# HTML::Lint errors for $uri" ); test_err( '# (7:9) Unknown attribute "hrex" for tag ' ); test_err( '# (8:33) with no opening ' ); test_err( '# (9:5) at (8:9) is never closed' ); test_err( '# 3 errors on the page' ); $mech->html_lint_ok( 'checking HTML' ); test_test( 'Proper html_lint_ok results' ); } done_testing(); exit 0; Test-WWW-Mechanize-1.60/t/head_ok.t0000644000175000017500000000340714343270541015443 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 11; use Test::WWW::Mechanize; use Test::Builder::Tester; use URI::file; my $mech = Test::WWW::Mechanize->new( autocheck => 0 ); isa_ok($mech,'Test::WWW::Mechanize'); GOOD_HEAD: { # Stop giggling, you! my $goodlinks = URI::file->new_abs( 't/goodlinks.html' )->as_string; $mech->head($goodlinks); ok($mech->success, 'sanity check: we can load goodlinks.html'); test_out('ok 1 - Try to HEAD goodlinks.html'); my $ok = $mech->head_ok($goodlinks, 'Try to HEAD goodlinks.html'); test_test('HEAD existing URI and reports success'); is( ref($ok), '', 'head_ok() should only return a scalar' ); ok( $ok, 'And the result should be true' ); # default desc test_out("ok 1 - HEAD $goodlinks"); $mech->head_ok($goodlinks); test_test('HEAD existing URI and reports success - default desc'); } BAD_HEAD: { my $badurl = URI::file->new_abs('t/no-such-file'); my $abs_path = $badurl->file; $mech->head( $badurl->as_string ); ok(!$mech->success, qq{sanity check: we can't load $badurl} ); test_out( 'not ok 1 - Try to HEAD bad URL' ); test_fail( +4 ); test_diag( $badurl->as_string ); test_diag( '404' ); test_diag( qq{File `$abs_path' does not exist} ); my $ok = $mech->head_ok( $badurl->as_string, 'Try to HEAD bad URL' ); test_test( 'Fails to HEAD nonexistent URI and reports failure' ); is( ref($ok), '', 'head_ok() should only return a scalar' ); ok( !$ok, 'And the result should be false' ); } UNDEF_URL: { test_out( 'not ok 1 - Passing undef for a URL' ); test_fail( +2 ); test_diag( 'URL cannot be undef.' ); my $ok = $mech->head_ok( undef, 'Passing undef for a URL' ); test_test( 'Undef URLs' ); } done_testing(); Test-WWW-Mechanize-1.60/t/title_is.t0000644000175000017500000000131314343263442015661 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 4; use Test::Builder::Tester; use URI::file; use Test::WWW::Mechanize (); my $mech=Test::WWW::Mechanize->new( autocheck => 0 ); isa_ok($mech,'Test::WWW::Mechanize'); # Good links. my $uri = URI::file->new_abs( 't/good.html' )->as_string; $mech->get_ok( $uri ); test_out( 'ok 1 - Is this the test page?' ); test_out( 'ok 2 - Title is "Test Page"' ); $mech->title_is( 'Test Page', 'Is this the test page?' ); $mech->title_is( 'Test Page' ); test_test( 'Finds the title OK' ); test_out( 'ok 1 - Is this like the test page?' ); $mech->title_like( qr/[tf]est (p)age/i, 'Is this like the test page?' ); test_test( 'Finds the title OK' ); done_testing(); Test-WWW-Mechanize-1.60/t/TestServer.pm0000644000175000017500000000520014343263442016323 0ustar andyandypackage TestServer; use warnings; use strict; use Test::More; use HTTP::Server::Simple::CGI; use Cwd qw( realpath ); use parent qw( HTTP::Server::Simple::CGI ); my $dispatch_table = {}; =head1 OVERLOADED METHODS =cut our $pid; sub new { die 'An instance of TestServer has already been started.' if $pid; my $class = shift; my $port = shift; if ( !$port ) { $port = int(rand(20000)) + 20000; } my $self = $class->SUPER::new( $port ); my $root = $self->root; return $self; } sub run { my $self = shift; $pid = $self->SUPER::run(@_); $SIG{__DIE__} = \&stop; return $pid; } sub handle_request { my $self = shift; my $cgi = shift; my $path = $cgi->path_info(); my $handler = $dispatch_table->{$path}; if (ref($handler) eq 'CODE') { print "HTTP/1.0 200 OK\r\n"; $handler->($cgi); } else { my $file = $path; if ( $file =~ m{/$} ) { $file .= 'index.html'; } $file =~ s/\s+//g; my $filename = "t/html/$file"; my ($code, $msg) = (200, 'OK'); if ( ! -r $filename ) { ($code, $msg) = (404, 'Not Found'); } if (index(realpath($filename), realpath("t/html")) != 0) { # don't expose a file outside server root ($code, $msg) = (403, 'Forbidden'); } print "HTTP/1.0 $code $msg\r\n"; if ($code == 200) { if (my $response=do { local (@ARGV, $/) = $filename; <> }) { print "Content-Type: text/html\r\n", "Content-Length: ", length($response), "\r\n\r\n", $response; } } else { print $cgi->header, $cgi->start_html($msg), $cgi->h1($msg), $cgi->end_html; } } return; } =head1 METHODS UNIQUE TO TestServer =cut sub set_dispatch { my $self = shift; $dispatch_table = shift; return; } sub background { my $self = shift; $pid = $self->SUPER::background() or Carp::confess( q{Can't start the test server} ); sleep 1; # background() may come back prematurely, so give it a second to fire up my $root = $self->root; diag( "Test server $root as PID $pid" ); return $pid; } sub hostname { my $self = shift; return '127.0.0.1'; } sub root { my $self = shift; my $port = $self->port; my $hostname = $self->hostname; return "http://$hostname:$port"; } sub stop { if ( $pid ) { kill( 9, $pid ) unless $^S; undef $pid; } return; } 1; Test-WWW-Mechanize-1.60/t/submit_form_ok.t0000644000175000017500000000106614343270541017067 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 3; use Test::Builder::Tester; use Test::WWW::Mechanize (); use lib 't'; use TestServer; my $server = TestServer->new; my $pid = $server->background; my $server_root = $server->root; SUBMIT_GOOD_FORM: { local @ENV{qw( http_proxy HTTP_PROXY )}; my $mech = Test::WWW::Mechanize->new(); isa_ok( $mech,'Test::WWW::Mechanize' ); $mech->get_ok( "$server_root/form.html" ); $mech->submit_form_ok( {form_number =>1}, 'Submit First Form' ); } $server->stop; done_testing(); Test-WWW-Mechanize-1.60/t/links_ok.t0000644000175000017500000000233214343263442015660 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 9; use Test::Builder::Tester; use URI::file; use Test::WWW::Mechanize (); my $mech=Test::WWW::Mechanize->new( autocheck => 0 ); isa_ok($mech,'Test::WWW::Mechanize'); # Good links. my $uri = URI::file->new_abs( 't/goodlinks.html' )->as_string; $mech->get_ok( $uri ); my $links = $mech->links(); is( @{$links}, 3, 'got three links' ); test_out('ok 1 - Checking all links successful'); $mech->links_ok($links,'Checking all links successful'); test_test('Handles All Links successful'); $mech->links_ok('goodlinks.html','Specified link'); $mech->links_ok([qw(goodlinks.html badlinks.html)],'Specified link list'); # Bad links $uri = URI::file->new_abs( 't/badlinks.html' )->as_string; $mech->get_ok( $uri ); $links=$mech->links(); test_out('not ok 1 - Checking all links some bad'); test_fail(+4); test_diag('bad1.html'); test_diag('bad2.html'); test_diag('bad3.html'); $mech->links_ok($links,'Checking all links some bad'); test_test('Handles bad links'); test_out('not ok 1 - Checking specified link not found'); test_fail(+2); test_diag('test2.html'); $mech->links_ok('test2.html','Checking specified link not found'); test_test('Handles link not found'); done_testing(); Test-WWW-Mechanize-1.60/t/html/0000755000175000017500000000000014343270552014626 5ustar andyandyTest-WWW-Mechanize-1.60/t/html/form.html0000644000175000017500000000047014343263442016460 0ustar andyandy Test Page

Test Page

Test-WWW-Mechanize-1.60/t/html/scratch.html0000644000175000017500000000037514343263442017150 0ustar andyandy Test Page

Test Page

Test 1 Test 2 Test 3 Test-WWW-Mechanize-1.60/t/manylinks.html0000644000175000017500000000101114343263442016546 0ustar andyandy Test Page

Test Page of many link types

Test 1 Blah blah Secure Mail your complaints Get your distro Test 2 Test 3 Test-WWW-Mechanize-1.60/t/click_ok.t0000644000175000017500000000172714343270541015632 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 6; use Test::Builder::Tester; use Test::WWW::Mechanize (); use lib 't'; use TestServer; my $server = TestServer->new; my $pid = $server->background; my $server_root = $server->root; SUBMIT_GOOD_FORM: { local @ENV{qw( http_proxy HTTP_PROXY )}; my $mech = Test::WWW::Mechanize->new(); isa_ok( $mech,'Test::WWW::Mechanize' ); $mech->get_ok( "$server_root/form.html" ); $mech->click_ok( 'big_button', 'Submit First Form' ); # XXX We need to check that the request is correct. } SUBMIT_GOOD_FORM_WITH_COORDINATES: { local @ENV{qw( http_proxy HTTP_PROXY )}; my $mech = Test::WWW::Mechanize->new(); isa_ok( $mech,'Test::WWW::Mechanize' ); $mech->get_ok( "$server_root/form.html" ); $mech->click_ok( ['big_button',360,80], 'Submit First Form with coordinates' ); # XXX We need to check that the request is correct. } $server->stop; done_testing(); exit 0; Test-WWW-Mechanize-1.60/t/text_contains.t0000644000175000017500000000220614343263442016731 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 5; use Test::Builder::Tester; use URI::file; use Test::WWW::Mechanize (); my $mech = Test::WWW::Mechanize->new(); isa_ok( $mech,'Test::WWW::Mechanize' ); my $uri = URI::file->new_abs( 't/goodlinks.html' )->as_string; $mech->get_ok( $uri ); # test regex test_out( 'ok 1 - Does it say test page?' ); $mech->text_contains( 'Test Page', 'Does it say test page?' ); test_test( 'Finds the contains' ); # default desc test_out( 'ok 1 - Text contains "Test Page"' ); $mech->text_contains( 'Test Page'); test_test( 'Finds the contains - default desc' ); # Handles not finding something. Also, what we are searching for IS # found in content_contains() but NOT in text_contains(). test_out( 'not ok 1 - Trying to find goodlinks' ); test_fail(+5); test_diag( q{ searched: "Test PageTest PageTest 1 Test 2 Test 3"} ); test_diag( q{ can't find: "goodlinks.html"} ); test_diag( q{ LCSS: "s"} ); test_diag( q{LCSS context: "Test PageTest PageTest 1 Test 2 Test 3"} ); $mech->text_contains( 'goodlinks.html', 'Trying to find goodlinks' ); test_test( 'Handles not finding it' ); done_testing(); Test-WWW-Mechanize-1.60/t/page_links_ok.t0000644000175000017500000000172614343263442016662 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 6; use Test::Builder::Tester; use URI::file; use Test::WWW::Mechanize (); my $mech = Test::WWW::Mechanize->new(); isa_ok($mech,'Test::WWW::Mechanize'); my $uri = URI::file->new_abs( 't/goodlinks.html' )->as_string; $mech->get_ok( $uri ); # Good links. test_out('ok 1 - Checking all page links successful'); $mech->page_links_ok('Checking all page links successful'); test_test('Handles All page links successful'); # Good links - default desc test_out('ok 1 - All links ok'); $mech->page_links_ok(); test_test('Handles All page links successful - default desc'); # Bad links $uri = URI::file->new_abs( 't/badlinks.html' )->as_string; $mech->get_ok( $uri ); test_out('not ok 1 - Checking some page link failures'); test_fail(+4); test_diag('bad1.html'); test_diag('bad2.html'); test_diag('bad3.html'); $mech->page_links_ok('Checking some page link failures'); test_test('Handles link not found'); done_testing(); Test-WWW-Mechanize-1.60/t/id_exists.html0000644000175000017500000000043114343263442016541 0ustar andyandy

Test-WWW-Mechanize-1.60/t/pod-coverage.t0000644000175000017500000000035414343263442016424 0ustar andyandy#!perl -T use strict; use warnings; use Test::More; if ( not eval 'use Test::Pod::Coverage 0.08;' ) { plan skip_all => 'Test::Pod::Coverage 0.08 required for testing POD coverage' if $@; } all_pod_coverage_ok(); done_testing(); Test-WWW-Mechanize-1.60/t/00-load.t0000644000175000017500000000145014343270541015201 0ustar andyandy#!perl -T use warnings; use strict; use Test::More tests => 1; use LWP; use WWW::Mechanize; use Test::Builder::Tester; use Test::WWW::Mechanize; pass( 'Modules loaded' ); diag( "Testing Test::WWW::Mechanize $Test::WWW::Mechanize::VERSION on Perl $], $^X" ); diag( "LWP $LWP::VERSION" ); diag( "WWW::Mechanize $WWW::Mechanize::VERSION" ); diag( "Test::More $Test::More::VERSION" ); diag( "Test::Builder::Tester $Test::Builder::Tester::VERSION" ); for my $module ( qw( HTML::Lint HTML::Tidy5 ) ) { my $rc = eval "use $module; 1;"; if ( $rc ) { no strict 'refs'; my $version = ${"${module}::VERSION"}; diag( "Found optional $module $version" ); } else { diag( "Optional $module not found. Install it to use additional features." ); } } done_testing(); Test-WWW-Mechanize-1.60/t/fluffy.html0000644000175000017500000000051714343263442016046 0ustar andyandy Test Page This page has valid structure, but contains errors that HTML::Lint categorizes as fluff. good Test Test-WWW-Mechanize-1.60/t/bad.html0000644000175000017500000000034314343263442015276 0ustar andyandy Test Page Test Page Back to bad good Test Test-WWW-Mechanize-1.60/t/scrape_text_by_id.t0000644000175000017500000001524514343263442017545 0ustar andyandy#!/usr/bin/perl -T use strict; use warnings; use Test::Builder::Tester; use Test::More tests => 3; use URI::file (); use Test::WWW::Mechanize (); subtest scrape_text_by_id => sub { plan tests => 8; my $mech = Test::WWW::Mechanize->new( autolint => 0 ); isa_ok( $mech, 'Test::WWW::Mechanize' ); my $uri = URI::file->new_abs( 't/goodlinks.html' )->as_string; $mech->get_ok( $uri, 'Get a dummy page just to have one' ); subtest 'nothing to find' => sub { plan tests => 2; $mech->update_html( '' ); is_deeply( [$mech->scrape_text_by_id( 'asdf' )], [], 'empty list returned in list context' ); is( $mech->scrape_text_by_id( 'asdf' ), undef, 'undef returned in scalar context' ); }; subtest 'find one' => sub { plan tests => 2; $mech->update_html( '

contents

' ); is_deeply( [$mech->scrape_text_by_id( 'asdf' )], ['contents'], 'list context' ); is( $mech->scrape_text_by_id( 'asdf' ), 'contents', 'scalar context' ); }; subtest 'find multiple' => sub { plan tests => 2; $mech->update_html( '

contents

further

' ); is_deeply( [$mech->scrape_text_by_id( 'asdf' )], ['contents', 'further'], 'empty list returned in list context' ); is( $mech->scrape_text_by_id( 'asdf' ), 'contents', 'first string returned in scalar context' ); }; subtest 'present but empty' => sub { plan tests => 2; $mech->update_html( '

' ); is_deeply( [$mech->scrape_text_by_id( 'asdf' )], [''], 'list context' ); is( $mech->scrape_text_by_id( 'asdf' ), '', 'scalar context' ); }; subtest 'present but emptier' => sub { plan tests => 2; $mech->update_html( '

' ); is_deeply( [$mech->scrape_text_by_id( 'asdf' )], [''], 'list context' ); is( $mech->scrape_text_by_id( 'asdf' ), '', 'scalar context' ); }; subtest 'nested tag' => sub { plan tests => 2; $mech->update_html( '

Bob and Bongo!

' ); is_deeply( [$mech->scrape_text_by_id( 'asdf' )], ['Bob and Bongo!'], 'list context' ); is( $mech->scrape_text_by_id( 'asdf' ), 'Bob and Bongo!', 'scalar context' ); }; }; subtest 'scraped_id_is and scraped_id_like' => sub { plan tests => 5; my $mech = Test::WWW::Mechanize->new( autolint => 0 ); isa_ok( $mech, 'Test::WWW::Mechanize' ); my $uri = URI::file->new_abs( 't/goodlinks.html' )->as_string; $mech->get_ok( $uri, 'Get a dummy page just to have one' ); subtest 'find one' => sub { plan tests => 2; $mech->update_html( '

contents

' ); $mech->scraped_id_is( 'asdf', 'contents', 'Works in scalar context' ); $mech->scraped_id_like( 'asdf', qr/con.+s/, 'Works on regexes' ); }; subtest 'nested tag' => sub { plan tests => 2; $mech->update_html( '

Bob and Bongo!

' ); $mech->scraped_id_is( 'asdf', 'Bob and Bongo!' ); $mech->scraped_id_like( 'asdf', qr/Bob.+Bongo/ ); }; subtest 'failures' => sub { plan tests => 6; $mech->update_html( '

Bob and Bongo!

' ); # Test standard successes. $mech->scraped_id_is( 'asdf', 'Bob and Bongo!' ); $mech->scraped_id_like( 'asdf', qr/Bob.+Bongo/ ); # Test failures. test_out( 'not ok 1 - Trying to match nonexistent ID to a string' ); test_fail( +2 ); test_diag( q{Can't find ID "nonexistent" to compare to "foo"} ); $mech->scraped_id_is( 'nonexistent', 'foo', 'Trying to match nonexistent ID to a string' ); test_test( 'Fails when trying to find nonexistent ID' ); my $regex = qr/Dave/ism; test_out( 'not ok 1 - Trying to match nonexistent ID to a regex' ); test_fail( +2 ); test_diag( qq{Can't find ID "nonexistent" to match against $regex} ); $mech->scraped_id_like( 'nonexistent', $regex, 'Trying to match nonexistent ID to a regex' ); test_test( 'Fails when mismatched against existing ID' ); # Make sure that empty tags don't get seen as non-existent. $mech->scraped_id_is( 'empty', '' ); $mech->scraped_id_like( 'empty', qr/^$/ ); }; }; # Previous versions would miss a search for id="foo" if it was not # exactly id="foo". Here we test for variants. subtest 'scrape_text_by_id optimization' => sub { plan tests => 6; _find_the_chips( <<'HTML', 'Double-quoted ID' ); Bongo not chips

chips

also not chips HTML _find_the_chips( <<'HTML', 'Single-quoted ID' ); Bongo not chips

chips

also not chips HTML _find_the_chips( <<'HTML', 'Unquoted ID' ); Bongo not chips

chips

also not chips HTML _find_the_chips( <<'HTML', 'Abnormal spacing' ); Bongo not chips

chips

also not chips HTML _find_the_chips( <<'HTML', 'Unquoted broken across lines' ); Bongo not chips

chips

also not chips HTML _find_the_chips( <<'HTML', 'Quoted broken across lines' ); Bongo not chips

chips

also not chips HTML }; sub _find_the_chips { local $Test::Builder::Level = $Test::Builder::Level + 1; my $html = shift; my $msg = shift or die; return subtest "_find_the_chips( $msg )" => sub { plan tests => 2; my $mech = Test::WWW::Mechanize->new( autolint => 0 ); isa_ok( $mech, 'Test::WWW::Mechanize' ); $mech->update_html( $html ); $mech->scraped_id_is( 'fish', 'chips' ); }; } done_testing(); exit 0; Test-WWW-Mechanize-1.60/t/page_links_content.t0000644000175000017500000000406714343263442017724 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 9; use Test::Builder::Tester; use URI::file; use Test::WWW::Mechanize (); use lib 't'; my $mech = Test::WWW::Mechanize->new(); isa_ok( $mech,'Test::WWW::Mechanize' ); my $uri = URI::file->new_abs( 't/goodlinks.html' )->as_string; $mech->get_ok( $uri ); # test regex test_out('not ok 1 - page_links_content_like'); test_fail(+2); test_diag(q{ "blah" doesn't look much like a regex to me.}); $mech->page_links_content_like('blah','Testing the regex'); test_test('Handles bad regexs'); # like test_out('ok 1 - Checking all page links contain: Test'); $mech->page_links_content_like(qr/Test/,'Checking all page links contain: Test'); test_test('Handles All page links contents successful'); # like - default desc my $re_string = ($] < 5.014) ? '(?-xism:Test)' : '(?^:Test)'; test_out(qq{ok 1 - All links are like "$re_string"}); $mech->page_links_content_like(qr/Test/); test_test('Handles All page links contents successful'); test_out('not ok 1 - Checking all page link content failures'); test_fail(+4); test_diag('goodlinks.html'); test_diag('badlinks.html'); test_diag('goodlinks.html'); $mech->page_links_content_like(qr/BadTest/,'Checking all page link content failures'); test_test('Handles link content not found'); # unlike # test regex test_out('not ok 1 - page_links_content_unlike'); test_fail(+2); test_diag(q{ "blah" doesn't look much like a regex to me.}); $mech->page_links_content_unlike('blah','Testing the regex'); test_test('Handles bad regexs'); test_out('ok 1 - Checking all page links do not contain: BadTest'); $mech->page_links_content_unlike(qr/BadTest/,'Checking all page links do not contain: BadTest'); test_test('Handles All page links unlike contents successful'); test_out('not ok 1 - Checking all page link unlike content failures'); test_fail(+4); test_diag('goodlinks.html'); test_diag('badlinks.html'); test_diag('goodlinks.html'); $mech->page_links_content_unlike(qr/Test/,'Checking all page link unlike content failures'); test_test('Handles link unlike content found'); done_testing(); Test-WWW-Mechanize-1.60/t/pod.t0000644000175000017500000000027314343263442014633 0ustar andyandy#!perl -Tw use strict; use warnings; use Test::More; if ( not eval 'use Test::Pod 1.00;' ) { plan skip_all => 'Test::Pod 1.00 required for testing POD' if $@; } all_pod_files_ok(); Test-WWW-Mechanize-1.60/t/autotidy.t0000644000175000017500000001146614343263442015721 0ustar andyandy#!/usr/bin/env perl -T use strict; use warnings; use Test::Builder::Tester; use Test::More; use URI::file; use Test::WWW::Mechanize; BEGIN { my $module = 'HTML::Tidy5 1.00'; # Load HTML::Lint here for the imports if ( not eval "use $module; 1;" ) { plan skip_all => "Optional $module is not installed, cannot test autotidy."; } plan tests => 5; } subtest 'Accessor and mutator' => sub { plan tests => 17; my $tidy = HTML::Tidy5->new; isa_ok( $tidy, 'HTML::Tidy5' ); ACCESSOR: { my $mech = Test::WWW::Mechanize->new(); ok( !$mech->autotidy(), 'no autotidy to new yields autotidy off' ); $mech = Test::WWW::Mechanize->new( autotidy => undef ); ok( !$mech->autotidy(), 'undef to new yields autotidy off' ); $mech = Test::WWW::Mechanize->new( autotidy => 0 ); ok( !$mech->autotidy(), '0 to new yields autotidy off' ); $mech = Test::WWW::Mechanize->new( autotidy => 1 ); ok( $mech->autotidy(), '1 to new yields autotidy on' ); $mech = Test::WWW::Mechanize->new( autotidy => [] ); ok( $mech->autotidy(), 'non-false, non-object to new yields autotidy on' ); $mech = Test::WWW::Mechanize->new( autotidy => $tidy ); ok( $mech->autotidy(), 'HTML::Tidy5 object to new yields autotidy on' ); } MUTATOR: { my $mech = Test::WWW::Mechanize->new(); ok( !$mech->autotidy(0), '0 returns autotidy off' ); ok( !$mech->autotidy(), '0 autotidy really off' ); ok( !$mech->autotidy(''), '"" returns autotidy off' ); ok( !$mech->autotidy(), '"" autotidy really off' ); ok( !$mech->autotidy(1), '1 returns autotidy off (prior state)' ); ok( $mech->autotidy(), '1 autotidy really on' ); ok( $mech->autotidy($tidy), 'HTML::Tidy5 object returns autotidy on (prior state)' ); ok( $mech->autotidy(), 'HTML::Tidy5 object autotidy really on' ); my $ret = $mech->autotidy( 0 ); isa_ok( $ret, 'HTML::Tidy5' ); ok( !$mech->autotidy(), 'autotidy off after nuking HTML::Tidy5 object' ); } }; subtest 'Fluffy page has errors' => sub { plan tests => 2; my $mech = Test::WWW::Mechanize->new( autotidy => 1 ); isa_ok( $mech, 'Test::WWW::Mechanize' ); my $uri = URI::file->new_abs( 't/fluffy.html' )->as_string; test_out( "not ok 1 - GET $uri" ); test_fail( +5 ); test_err( "# HTML::Tidy5 messages for $uri" ); test_err( '# (1:1) Warning: missing declaration' ); test_err( '# (10:9) Warning: lacks "alt" attribute' ); test_err( '# 2 messages on the page' ); $mech->get_ok( $uri ); test_test( 'Fluffy page should have fluffy errors' ); }; subtest 'Custom tidy ignores fluffy errors' => sub { plan tests => 4; my $tidy = HTML::Tidy5->new( { show_warnings => 0 } ); isa_ok( $tidy, 'HTML::Tidy5' ); my $mech = Test::WWW::Mechanize->new( autotidy => $tidy ); isa_ok( $mech, 'Test::WWW::Mechanize' ); my $uri = URI::file->new_abs( 't/fluffy.html' )->as_string; $mech->get_ok( $uri, 'Fluffy page should not have errors' ); # And if we go to another page, the autolint object has been reset. $mech->get_ok( $uri, 'Second pass at the fluffy page should not have errors, either' ); }; subtest 'Get good HTML' => sub { plan tests => 3; my $mech = Test::WWW::Mechanize->new( autotidy => 1 ); isa_ok( $mech, 'Test::WWW::Mechanize' ); my $uri = URI::file->new_abs( 't/good.html' )->as_string; $mech->get_ok( $uri ); test_out( "ok 1 - GET $uri" ); $mech->get_ok( $uri, "GET $uri" ); test_test( 'Good GET, good HTML' ); }; subtest 'Get bad HTML' => sub { plan tests => 3; my $mech = Test::WWW::Mechanize->new( autotidy => 1 ); isa_ok( $mech, 'Test::WWW::Mechanize' ); my $uri = URI::file->new_abs( 't/bad.html' )->as_string; # Test via get_ok test_out( "not ok 1 - GET $uri" ); test_fail( +6 ); test_err( "# HTML::Tidy5 messages for $uri" ); test_err( '# (1:1) Warning: missing declaration' ); test_err( '# (8:33) Warning: discarding unexpected ' ); test_err( '# (8:9) Warning: missing ' ); test_err( '# 3 messages on the page' ); $mech->get_ok( $uri, "GET $uri" ); test_test( 'get_ok complains about bad HTML' ); # Test via follow_link_ok test_out( 'not ok 1 - Following link back to bad.html' ); test_fail( +6 ); test_err( "# HTML::Tidy5 messages for $uri" ); test_err( '# (1:1) Warning: missing declaration' ); test_err( '# (8:33) Warning: discarding unexpected ' ); test_err( '# (8:9) Warning: missing ' ); test_err( '# 3 messages on the page' ); $mech->follow_link_ok( { text => 'Back to bad' }, 'Following link back to bad.html' ); test_test( 'follow_link_ok complains about bad HTML' ); }; done_testing(); exit 0; Test-WWW-Mechanize-1.60/t/has_tag.t0000644000175000017500000000460214343263442015457 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 15; use Test::Builder::Tester; use URI::file; use Test::WWW::Mechanize (); my $mech = Test::WWW::Mechanize->new(); isa_ok($mech,'Test::WWW::Mechanize'); my $uri = URI::file->new_abs( 't/goodlinks.html' )->as_string; $mech->get_ok( $uri ); test_out( 'ok 1 - looking for "Test" link' ); $mech->has_tag( h1 => 'Test Page', 'looking for "Test" link' ); test_test( 'Handles finding tag by content' ); # default desc test_out( 'ok 1 - Page has h1 tag with "Test Page"' ); $mech->has_tag( h1 => 'Test Page' ); test_test( 'Handles finding tag by content - default desc' ); test_out( 'not ok 1 - looking for "Quiz" link' ); test_fail( +1 ); $mech->has_tag( h1 => 'Quiz', 'looking for "Quiz" link' ); test_test( 'Handles unfindable tag by content' ); test_out( 'ok 1 - Should have qr/Test 3/i link' ); $mech->has_tag_like( a => qr/Test 3/, 'Should have qr/Test 3/i link' ); test_test( 'Handles finding tag by content regexp' ); test_out( 'not ok 1 - Should be missing qr/goof/i link' ); test_fail( +1 ); $mech->has_tag_like( a => qr/goof/i, 'Should be missing qr/goof/i link' ); test_test( 'Handles unfindable tag by content regexp' ); ## nested table tag my $table_uri = URI::file->new_abs( 't/table.html' )->as_string; $mech->get_ok( $table_uri ); test_out( 'ok 1 - Page has td tag with "Foobar"' ); $mech->has_tag('td' => 'Foobar' ); test_test( 'Handles finding text in table data tag' ); test_out( 'ok 1 - User company' ); $mech->has_tag('td', 'company', 'User company'); test_test( 'Handles finding text in nested table data tag' ); test_out( 'ok 1 - Page has td tag with "company,email,employee,website"' ); $mech->has_tag('td', 'company,email,employee,website'); test_test( 'Handles finding text in nested table data second tag' ); test_out( 'ok 1 - Page has th tag with "Groups"' ); $mech->has_tag('th', 'Groups'); test_test( 'Handles finding text in nested table header' ); test_out( 'ok 1 - Page has h3 tag with "Show all users and groups"' ); $mech->has_tag('h3', 'Show all users and groups'); test_test( 'Handles finding text in h3 in table' ); test_out( 'ok 1 - Page has p tag with "Its been said:"' ); $mech->has_tag('p', 'Its been said:'); test_test( 'Checks finding text in sub inline element in p' ); test_out( 'ok 1 - Page has p tag with "Hi"'); $mech->has_tag( 'p', 'Hi' ); test_test( 'Finding text in sub inline element in p' ); done_testing(); Test-WWW-Mechanize-1.60/t/headers.t0000644000175000017500000001013214343270541015455 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 26; use Test::Builder::Tester; use lib 't'; use TestServer; my $server = TestServer->new; my $pid = $server->background; my $server_root = $server->root; use Test::WWW::Mechanize (); my $mech = do { local @ENV{qw( http_proxy HTTP_PROXY )}; Test::WWW::Mechanize->new( autocheck => 0 ); }; isa_ok($mech,'Test::WWW::Mechanize'); $mech->get_ok( "$server_root/form.html" ); GOOD_EXISTS: { test_out( 'ok 1 - Has Content-Type' ); my $ok = $mech->header_exists_ok('Content-Type', 'Has Content-Type'); test_test( 'Gets existing header and reports success' ); is( ref($ok), '', 'get_ok() should only return a scalar' ); ok( $ok, 'And the result should be true' ); # default desc test_out( 'ok 1 - Response has Content-Type header' ); $mech->header_exists_ok('Content-Type'); test_test( 'Gets existing header and reports success - default desc' ); } BAD_EXISTS: { test_out( 'not ok 1 - Try to get a bad header' ); test_fail( +1 ); my $ok = $mech->header_exists_ok('Server', 'Try to get a bad header'); test_test( 'Fails to get nonexistent header and reports failure' ); is( ref($ok), '', 'get_ok() should only return a scalar' ); ok( !$ok, 'And the result should be false' ); } GOOD_LACKS: { test_out( 'ok 1 - Lacks Bongotronic-X' ); my $ok = $mech->lacks_header_ok( 'Bongotronic-X', 'Lacks Bongotronic-X' ); test_test( 'Gets existing header and reports success' ); is( ref($ok), '', 'get_ok() should only return a scalar' ); ok( $ok, 'And the result should be true' ); test_out( 'ok 1 - Response lacks Bongotronic-X header' ); $mech->lacks_header_ok( 'Bongotronic-X' ); test_test( 'Gives reasonable default to lacks_header_ok' ); } BAD_LACKS: { test_out( 'not ok 1 - Hoping Content-Type is missing' ); test_fail( +1 ); my $ok = $mech->lacks_header_ok( 'Content-Type', 'Hoping Content-Type is missing' ); test_test( 'The header we expected to lack is indeed there.' ); is( ref($ok), '', 'get_ok() should only return a scalar' ); ok( !$ok, 'And the result should be false' ); } GOOD_IS: { test_out( 'ok 1 - Content-Type is "text/html"' ); my $ok = $mech->header_is('Content-Type', 'text/html', 'Content-Type is "text/html"'); test_test( 'Matches existing header and reports success' ); is( ref($ok), '', 'get_ok() should only return a scalar' ); ok( $ok, 'And the result should be true' ); # default desc test_out( 'ok 1 - Response has Content-Type header with value "text/html"' ); $mech->header_is('Content-Type', 'text/html'); test_test( 'Matches existing header and reports success - default desc' ); } BAD_IS: { test_out( 'not ok 1 - Try to match a nonexistent header' ); test_fail( +2 ); test_diag( 'Header Bongotronic-X does not exist' ); my $ok = $mech->header_is('Bongotronic-X', 'GitHub.com', 'Try to match a nonexistent header'); test_test( 'Fails to match nonexistent header and reports failure' ); is( ref($ok), '', 'get_ok() should only return a scalar' ); ok( !$ok, 'And the result should be false' ); test_out( 'not ok 1 - Content-Type is "text/plain"' ); test_fail( +3 ); test_diag(q( got: 'text/html')); test_diag(q( expected: 'text/plain')); $mech->header_is('Content-Type', 'text/plain', 'Content-Type is "text/plain"'); test_test( 'Fails to match header and reports failure' ); } GOOD_LIKE: { test_out( 'ok 1 - Content-Type matches /^text\\/html$/' ); $mech->header_like('Content-Type', qr/^text\/html$/, 'Content-Type matches /^text\\/html$/'); test_test( 'Matches existing header and reports success - regex' ); } BAD_LIKE: { my $pattern = qr{^text/plain$}; test_out( 'not ok 1 - Content-Type matches /^text\\/plain$/' ); test_fail( +3 ); test_diag( q( 'text/html')); test_diag(qq( doesn't match '$pattern')); $mech->header_like('Content-Type', $pattern, 'Content-Type matches /^text\\/plain$/'); test_test( 'Fails to match header and reports failure - regex' ); } $server->stop; done_testing(); Test-WWW-Mechanize-1.60/t/post_ok.t0000644000175000017500000000073014343270541015523 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 2; use Test::Builder::Tester; use Test::WWW::Mechanize (); my $mech = Test::WWW::Mechanize->new( autocheck => 0 ); isa_ok($mech,'Test::WWW::Mechanize'); UNDEF_URL: { test_out( 'not ok 1 - Passing undef for a URL' ); test_fail( +2 ); test_diag( 'URL cannot be undef.' ); my $ok = $mech->post_ok( undef, 'Passing undef for a URL' ); test_test( 'Undef URLs' ); } done_testing(); exit 0; Test-WWW-Mechanize-1.60/t/lacks_uncapped_inputs.t0000644000175000017500000000223714343263442020431 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 5; use Test::Builder::Tester; use URI::file; use 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_ok( $uri ) or die; 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_ok( $uri ) or die; test_out( 'not ok 1 - This should have three errors found' ); test_fail( +6 ); 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"} ); test_diag( q{bingo has an invalid maxlength attribute of ""} ); test_diag( q{bongo has an invalid maxlength attribute of " "} ); $mech->lacks_uncapped_inputs( 'This should have three errors found' ); test_test( 'Detect uncapped' ); } done_testing(); Test-WWW-Mechanize-1.60/t/id_exists.t0000644000175000017500000000262114343263442016043 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 23; use Test::Builder::Tester; use Test::WWW::Mechanize (); use URI::file (); my @valid_ids = ( 'user-block', 'name', 'address' ); my @invalid_ids = ( 'bingo', 'bongo' ); my $mech = Test::WWW::Mechanize->new(); isa_ok( $mech,'Test::WWW::Mechanize' ); my $uri = URI::file->new_abs( 't/id_exists.html' )->as_string; $mech->get_ok( $uri ); for my $id ( @valid_ids ) { ok( $mech->id_exists( $id ), "$id found" ); $mech->id_exists_ok( $id ); $mech->ids_exist_ok( [$id] ); } for my $id ( @invalid_ids ) { ok( !$mech->id_exists( $id ), "$id not found" ); $mech->lacks_id_ok( $id ); $mech->lacks_ids_ok( [$id] ); } $mech->ids_exist_ok( [@valid_ids], 'Valid IDs found' ); $mech->lacks_ids_ok( [@invalid_ids], 'Valid IDs found' ); # Now test output specifics. # id_exists_ok test_out( 'not ok 1 - ID "bongo" should exist' ); test_fail( +1 ); $mech->id_exists_ok( 'bongo' ); test_test( 'Proper id_exists_ok results for nonexistent ID' ); # lacks_id_ok test_out( 'not ok 1 - ID "name" should not exist' ); test_fail( +1 ); $mech->lacks_id_ok( 'name' ); test_test( 'Proper lacks_id_ok results for ID that is there' ); # Now go get a new page and do tests again. $mech->update_html( '

Very boring page

id_exists_ok( 'boring' ); $mech->lacks_ids_ok( [@valid_ids, @invalid_ids] ); exit 0 Test-WWW-Mechanize-1.60/t/lacks_uncapped_inputs-good.html0000644000175000017500000000053414343263442022056 0ustar andyandy Title
Test-WWW-Mechanize-1.60/t/stuff_inputs.html0000644000175000017500000000012714343263442017301 0ustar andyandy Title
Test-WWW-Mechanize-1.60/t/autolint.t0000644000175000017500000001114614343263442015711 0ustar andyandy#!/usr/bin/env perl -T use strict; use warnings; use Test::Builder::Tester; use Test::More; use URI::file; use Test::WWW::Mechanize; BEGIN { my $module = 'HTML::Lint 2.20'; # Load HTML::Lint here for the imports if ( not eval "use $module; 1;" ) { plan skip_all => "$module is not installed, cannot test autolint"; } plan tests => 27; } ACCESSOR_MUTATOR: { my $lint = HTML::Lint->new( only_types => HTML::Lint::Error::STRUCTURE ); ACCESSOR: { my $mech = Test::WWW::Mechanize->new(); ok( !$mech->autolint(), 'no autolint to new yields autolint off' ); $mech = Test::WWW::Mechanize->new( autolint => undef ); ok( !$mech->autolint(), 'undef to new yields autolint off' ); $mech = Test::WWW::Mechanize->new( autolint => 0 ); ok( !$mech->autolint(), '0 to new yields autolint off' ); $mech = Test::WWW::Mechanize->new( autolint => 1 ); ok( $mech->autolint(), '1 to new yields autolint on' ); $mech = Test::WWW::Mechanize->new( autolint => [] ); ok( $mech->autolint(), 'non-false, non-object to new yields autolint on' ); $mech = Test::WWW::Mechanize->new( autolint => $lint ); ok( $mech->autolint(), 'HTML::Lint object to new yields autolint on' ); } MUTATOR: { my $mech = Test::WWW::Mechanize->new(); ok( !$mech->autolint(0), '0 returns autolint off' ); ok( !$mech->autolint(), '0 autolint really off' ); ok( !$mech->autolint(''), '"" returns autolint off' ); ok( !$mech->autolint(), '"" autolint really off' ); ok( !$mech->autolint(1), '1 returns autolint off (prior state)' ); ok( $mech->autolint(), '1 autolint really on' ); ok( $mech->autolint($lint), 'HTML::Lint object returns autolint on (prior state)' ); ok( $mech->autolint(), 'HTML::Lint object autolint really on' ); my $ret = $mech->autolint( 0 ); isa_ok( $ret, 'HTML::Lint' ); ok( !$mech->autolint(), 'autolint off after nuking HTML::Lint object' ); } } FLUFFY_PAGE_HAS_ERRORS: { my $mech = Test::WWW::Mechanize->new( autolint => 1 ); isa_ok( $mech, 'Test::WWW::Mechanize' ); my $uri = URI::file->new_abs( 't/fluffy.html' )->as_string; test_out( "not ok 1 - GET $uri" ); test_fail( +5 ); test_err( "# HTML::Lint errors for $uri" ); test_err( '# (10:9) tag has no HEIGHT and WIDTH attributes' ); test_err( '# (10:9) does not have ALT text defined' ); test_err( '# 2 errors on the page' ); $mech->get_ok( $uri ); test_test( 'Fluffy page should have fluffy errors' ); } CUSTOM_LINTER_IGNORES_FLUFFY_ERRORS: { my $lint = HTML::Lint->new( only_types => HTML::Lint::Error::STRUCTURE ); my $mech = Test::WWW::Mechanize->new( autolint => $lint ); isa_ok( $mech, 'Test::WWW::Mechanize' ); my $uri = URI::file->new_abs( 't/fluffy.html' )->as_string; $mech->get_ok( $uri, 'Fluffy page should not have errors' ); # And if we go to another page, the autolint object has been reset. $mech->get_ok( $uri, 'Second pass at the fluffy page should not have errors, either' ); } GOOD_GET_GOOD_HTML: { my $mech = Test::WWW::Mechanize->new( autolint => 1 ); isa_ok( $mech, 'Test::WWW::Mechanize' ); my $uri = URI::file->new_abs( 't/good.html' )->as_string; $mech->get_ok( $uri ); test_out( "ok 1 - GET $uri" ); $mech->get_ok( $uri, "GET $uri" ); test_test( 'Good GET, good HTML' ); } GOOD_GET_BAD_HTML: { my $mech = Test::WWW::Mechanize->new( autolint => 1 ); isa_ok( $mech, 'Test::WWW::Mechanize' ); my $uri = URI::file->new_abs( 't/bad.html' )->as_string; # Test via get_ok test_out( "not ok 1 - GET $uri" ); test_fail( +6 ); test_err( "# HTML::Lint errors for $uri" ); test_err( '# (7:9) Unknown attribute "hrex" for tag ' ); test_err( '# (8:33) with no opening ' ); test_err( '# (9:5) at (8:9) is never closed' ); test_err( '# 3 errors on the page' ); $mech->get_ok( $uri, "GET $uri" ); test_test( 'get_ok complains about bad HTML' ); # Test via follow_link_ok test_out( 'not ok 1 - Following link back to bad.html' ); test_fail( +6 ); test_err( "# HTML::Lint errors for $uri" ); test_err( '# (7:9) Unknown attribute "hrex" for tag ' ); test_err( '# (8:33) with no opening ' ); test_err( '# (9:5) at (8:9) is never closed' ); test_err( '# 3 errors on the page' ); $mech->follow_link_ok( { text => 'Back to bad' }, 'Following link back to bad.html' ); test_test( 'follow_link_ok complains about bad HTML' ); } done_testing(); Test-WWW-Mechanize-1.60/t/good.html0000644000175000017500000000032014343263442015473 0ustar andyandy Test Page Test Page good Test Test-WWW-Mechanize-1.60/t/stuff_inputs.t0000644000175000017500000001116414343263442016603 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 43; use URI::file; use Test::WWW::Mechanize (); MAIN: { my $mech = Test::WWW::Mechanize->new(); my $uri = URI::file->new_abs( 't/stuff_inputs.html' )->as_string; EMPTY_FIELDS: { $mech->get_ok( $uri ) or die; add_test_fields( $mech ); $mech->stuff_inputs(); field_checks( $mech, { text0 => '', text1 => '@', text10 => '@' x 10, text70k => '@' x 70_000, textunlimited => '@' x 66_000, textarea => '@' x 66_000, }, 'filling empty fields' ); } MULTICHAR_FILL: { $mech->get_ok( $uri ) or die; add_test_fields( $mech ); $mech->stuff_inputs( { fill => '123' } ); field_checks( $mech, { text0 => '', text1 => '1', text10 => '1231231231', text70k => ('123' x 23_333) . '1', textunlimited => '123' x 22_000, textarea => '123' x 22_000, }, 'multichar_fill' ); } OVERWRITE: { $mech->get_ok( $uri ) or die; add_test_fields( $mech ); $mech->stuff_inputs(); is( $mech->value('text10'), '@' x 10, 'overwriting fields: initial fill as expected' ); $mech->stuff_inputs( { fill => 'X' } ); field_checks( $mech, { text0 => '', text1 => 'X', text10 => 'X' x 10, text70k => 'X' x 70_000, textunlimited => 'X' x 66_000, textarea => 'X' x 66_000, }, 'overwriting fields' ); } CUSTOM_FILL: { $mech->get_ok( $uri ) or die; add_test_fields( $mech ); $mech->stuff_inputs( { fill => 'z', specs => { text10 => { fill=>'#' }, textarea => { fill=>'*' }, } } ); field_checks( $mech, { text0 => '', text1 => 'z', text10 => '#' x 10, text70k => 'z' x 70_000, textunlimited => 'z' x 66_000, textarea => '*' x 66_000, }, 'custom fill' ); } MAXLENGTH: { $mech->get_ok( $uri ) or die; add_test_fields( $mech ); $mech->stuff_inputs( { specs => { text10 => { maxlength=>7 }, textarea => { fill=>'*', maxlength=>9 }, } } ); field_checks( $mech, { text0 => '', text1 => '@', text10 => '@' x 7, text70k => '@' x 70_000, textunlimited => '@' x 66_000, textarea => '*' x 9, }, 'maxlength' ); } IGNORE: { $mech->get_ok( $uri ) or die; add_test_fields( $mech ); $mech->stuff_inputs( { ignore => [ 'text10' ] } ); field_checks( $mech, { text0 => '', text1 => '@', text10 => undef, text70k => '@' x 70_000, textunlimited => '@' x 66_000, textarea => '@' x 66_000, }, 'ignore' ); } } done_testing(); sub add_test_fields { my $mech = shift; HTML::Form::Input->new( type=>'text', name=>'text0', maxlength=>0 )->add_to_form( $mech->current_form() ); HTML::Form::Input->new( type=>'text', name=>'text1', maxlength=>1 )->add_to_form( $mech->current_form() ); HTML::Form::Input->new( type=>'text', name=>'text10', maxlength=>10 )->add_to_form( $mech->current_form() ); HTML::Form::Input->new( type=>'text', name=>'text70k', maxlength=>70_000 )->add_to_form( $mech->current_form() ); HTML::Form::Input->new( type=>'text', name=>'textunlimited' )->add_to_form( $mech->current_form() ); HTML::Form::Input->new( type=>'textarea', name=>'textarea' )->add_to_form( $mech->current_form() ); return; } sub field_checks { my $mech = shift; my $expected = shift; my $desc = shift; foreach my $key ( qw( text0 text1 text10 text70k textunlimited textarea ) ) { is( $mech->value($key), $expected->{$key}, "$desc: field $key" ); } return; } Test-WWW-Mechanize-1.60/t/table.html0000644000175000017500000000131614343263442015640 0ustar andyandy nested table for mech

Show all users and groups

UserGroups
company company,email,employee,website
Foobar

Its been said: so it was

Hi bye Hi

Test-WWW-Mechanize-1.60/t/put_ok.t0000644000175000017500000000255014343270541015350 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 8; use Test::Builder::Tester; use Test::WWW::Mechanize (); use lib 't'; use TestServer; my $server = TestServer->new; my $pid = $server->background; my $server_root = $server->root; my $text = 'This is what we are putting'; GOOD_PUT: { local @ENV{qw( http_proxy HTTP_PROXY )}; my $mech = Test::WWW::Mechanize->new( autocheck => 0 ); isa_ok($mech,'Test::WWW::Mechanize'); my $scratch = "$server_root/scratch.html"; $mech->put_ok($scratch, {content => $text}); ok($mech->success, 'sanity check: we can load scratch.html'); test_out('ok 1 - Try to PUT scratch.html'); my $ok = $mech->put_ok($scratch, 'Try to PUT scratch.html'); test_test('PUTs existing URI and reports success'); is( ref($ok), '', 'put_ok() should only return a scalar' ); ok( $ok, 'And the result should be true' ); # default desc test_out("ok 1 - PUT $scratch"); $mech->put_ok($scratch); test_test('PUTs existing URI and reports success - default desc'); } UNDEF_URL: { my $mech = Test::WWW::Mechanize->new(); test_out( 'not ok 1 - Passing undef for a URL' ); test_fail( +2 ); test_diag( 'URL cannot be undef.' ); my $ok = $mech->put_ok( undef, 'Passing undef for a URL' ); test_test( 'Undef URLs' ); } $server->stop; done_testing(); exit 0; Test-WWW-Mechanize-1.60/t/content_lacks.t0000644000175000017500000000242014343263442016674 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 5; use Test::Builder::Tester; use URI::file; use Test::WWW::Mechanize (); my $mech=Test::WWW::Mechanize->new(); isa_ok($mech,'Test::WWW::Mechanize'); my $uri = URI::file->new_abs( 't/goodlinks.html' )->as_string; $mech->get_ok( $uri ); # test regex test_out( 'ok 1 - Does it say Mungo eats cheese?' ); $mech->content_lacks( 'Mungo eats cheese', 'Does it say Mungo eats cheese?' ); test_test( 'Finds the lacks' ); # default desc test_out( 'ok 1 - Content lacks "Mungo eats cheese"' ); $mech->content_lacks( 'Mungo eats cheese'); test_test( 'Finds the lacks - default desc' ); test_out( q{not ok 1 - Shouldn't say it's a test page} ); test_fail(+11); if ( $^O eq 'MSWin32' ) { test_diag(q( searched: "\x{0d}\x{0a} \x{0d}\x{0a} Test Page</titl"...) ); test_diag(q( and found: "Test Page") ); test_diag(q( at position: 35 (line 3 column 16)) ); } else { test_diag(q( searched: "<html>\x{0a} <head>\x{0a} <title>Test Page"...) ); test_diag(q( and found: "Test Page") ); test_diag(q( at position: 33 (line 3 column 16)) ); } $mech->content_lacks( 'Test Page', q{Shouldn't say it's a test page} ); test_test( 'Handles not finding it' ); done_testing(); Test-WWW-Mechanize-1.60/t/goodlinks.html0000644000175000017500000000037514343263442016546 0ustar andyandy Test Page

Test Page

Test 1 Test 2 Test 3 Test-WWW-Mechanize-1.60/t/followable_links.t0000644000175000017500000000127114343263442017376 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 3; use URI::file; use Test::WWW::Mechanize (); my $mech = Test::WWW::Mechanize->new(); isa_ok($mech,'Test::WWW::Mechanize'); my $uri = URI::file->new_abs( 't/manylinks.html' )->as_string; $mech->get_ok( $uri ); # Good links. my @links = $mech->followable_links(); @links = map { $_->url_abs } @links; my @expected = ( URI::file->new_abs( 't/goodlinks.html' )->as_string, 'http://bongo.com/wang.html', 'https://secure.bongo.com/', URI::file->new_abs( 't/badlinks.html' )->as_string, URI::file->new_abs( 't/goodlinks.html' )->as_string, ); is_deeply( \@links, \@expected, 'Got the right links' ); done_testing(); Test-WWW-Mechanize-1.60/t/get_ok.t0000644000175000017500000000324214343270541015316 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 11; use Test::Builder::Tester; use URI::file (); use Test::WWW::Mechanize (); my $mech = Test::WWW::Mechanize->new( autocheck => 0 ); isa_ok($mech,'Test::WWW::Mechanize'); GOOD_GET: { my $goodlinks = URI::file->new_abs( 't/goodlinks.html' )->as_string; $mech->get_ok($goodlinks); test_out('ok 1 - Try to get goodlinks.html'); my $ok = $mech->get_ok($goodlinks, 'Try to get goodlinks.html'); test_test('Gets existing URI and reports success'); is( ref($ok), '', 'get_ok() should only return a scalar' ); ok( $ok, 'And the result should be true' ); # default desc test_out("ok 1 - GET $goodlinks"); $mech->get_ok($goodlinks); test_test('Gets existing URI and reports success - default desc'); } BAD_GET: { my $badurl = URI::file->new_abs('t/no-such-file'); my $abs_path = $badurl->file; $mech->get( $badurl->as_string ); ok(!$mech->success, qq{sanity check: we can't load $badurl}); test_out( 'not ok 1 - Try to get bad URL' ); test_fail( +4 ); test_diag( $badurl ); test_diag( '404' ); test_diag( qq{File `$abs_path' does not exist} ); my $ok = $mech->get_ok( $badurl->as_string, 'Try to get bad URL' ); test_test( 'Fails to get nonexistent URI and reports failure' ); is( ref($ok), '', 'get_ok() should only return a scalar' ); ok( !$ok, 'And the result should be false' ); } UNDEF_URL: { test_out( 'not ok 1 - Passing undef for a URL' ); test_fail( +2 ); test_diag( 'URL cannot be undef.' ); my $ok = $mech->get_ok( undef, 'Passing undef for a URL' ); test_test( 'Undef URLs' ); } done_testing(); exit 0; Test-WWW-Mechanize-1.60/t/new.t0000644000175000017500000000151614343263442014643 0ustar andyandy#!perl -T use warnings; use strict; use Test::More tests => 2; use Test::WWW::Mechanize (); subtest 'basic new' => sub { my $mech = Test::WWW::Mechanize->new; isa_ok( $mech, 'Test::WWW::Mechanize' ); }; # Stolen from WWW::Mechanize's t/new.t. # If this works, then subclassing works OK. subtest 'constructor parms' => sub { my $alias = 'Windows IE 6'; my $mech = Test::WWW::Mechanize->new( agent => $alias ); isa_ok( $mech, 'Test::WWW::Mechanize' ); can_ok( $mech, 'request' ); is( $mech->agent, $alias, q{Aliases don't get translated in the constructor} ); $mech->agent_alias( $alias ); like( $mech->agent, qr/^Mozilla.+compatible.+Windows/, 'Alias sets the agent' ); $mech->agent( 'ratso/bongo v.43' ); is( $mech->agent, 'ratso/bongo v.43', 'Can still set the agent' ); }; done_testing(); Test-WWW-Mechanize-1.60/t/link_content.t0000644000175000017500000000467114343263442016546 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 11; use Test::Builder::Tester; use URI::file; use Test::WWW::Mechanize; my $mech=Test::WWW::Mechanize->new(); isa_ok($mech,'Test::WWW::Mechanize'); my $uri = URI::file->new_abs( 't/goodlinks.html' )->as_string; $mech->get_ok( $uri ); my @urls = $mech->links(); is( scalar @urls, 3, 'Got links from the HTTP server'); # test regex test_out('not ok 1 - link_content_like'); test_fail(+2); test_diag(q{ "blah" doesn't look much like a regex to me.}); $mech->link_content_like(\@urls,'blah','Testing the regex'); test_test('Handles bad regexs'); # like test_out('ok 1 - Checking all page links contain: Test'); $mech->link_content_like(\@urls,qr/Test/,'Checking all page links contain: Test'); test_test('Handles All page links contents successful'); # like - default desc my $re_string = ($] < 5.014) ? '(?-xism:Test)' : '(?^:Test)'; test_out('ok 1 - ' . scalar(@urls) . qq{ links are like "$re_string"} ); $mech->link_content_like(\@urls,qr/Test/); test_test('Handles All page links contents successful - default desc'); test_out('not ok 1 - Checking all page link content failures'); test_fail(+4); test_diag('goodlinks.html'); test_diag('badlinks.html'); test_diag('goodlinks.html'); $mech->link_content_like(\@urls,qr/BadTest/,'Checking all page link content failures'); test_test('Handles link content not found'); # unlike # test regex test_out('not ok 1 - link_content_unlike'); test_fail(+2); test_diag(q{ "blah" doesn't look much like a regex to me.}); $mech->link_content_unlike(\@urls,'blah','Testing the regex'); test_test('Handles bad regexs'); test_out('ok 1 - Checking all page links do not contain: BadTest'); $mech->link_content_unlike(\@urls,qr/BadTest/,'Checking all page links do not contain: BadTest'); test_test('Handles All page links unlike contents successful'); # unlike - default desc $re_string = ($] < 5.014) ? '(?-xism:BadTest)' : '(?^:BadTest)'; test_out('ok 1 - ' . scalar(@urls) . qq{ links are not like "$re_string"}); $mech->link_content_unlike(\@urls,qr/BadTest/); test_test('Handles All page links unlike contents successful - default desc'); test_out('not ok 1 - Checking all page link unlike content failures'); test_fail(+4); test_diag('goodlinks.html'); test_diag('badlinks.html'); test_diag('goodlinks.html'); $mech->link_content_unlike(\@urls,qr/Test/,'Checking all page link unlike content failures'); test_test('Handles link unlike content found'); done_testing(); Test-WWW-Mechanize-1.60/Changes0000644000175000017500000003533314343270541014717 0ustar andyandyRevision history for Test-WWW-Mechanize WWW::Mechanize and Test::WWW::Mechanize do not use rt.cpan.org for bug tracking. They are now being tracked via GitHub at https://github.com/petdance/test-www-mechanize/issues 1.60 Sun Dec 4 10:18:28 PM CST 2022 ------------------------------------ [ENHANCMENTS] Added default test messages for button_exists_ok and lacks_button_ok methods. Thanks, Daniel Böhmer (GH#70) get_ok(), post_ok(), head_ok(), put_ok() and delete_ok() now all fail if an undef URL is passed, rather than passing the undef URL into the underlying LWP functions. Thanks, Jess Robinson. (GH #40) [FIXES] Disable proxies in some of the tests that look at a local test server. (GH#55, GH#74) [DOCUMENTATION] Clarified some wording. Thanks, Daniel Böhmer (GH#70) 1.58 Fri Apr 29 11:23:39 CDT 2022 ------------------------------------ [ENHANCEMENTS] Failed get_ok, post_ok, head_ok, put_ok, delete_ok calls now show the URL as a diagnostic if there's a problem accessing the URL. This apply to functions like submit_form_ok() and follow_link_ok() that are wrappers around these methods. 1.56 Tue Apr 26 22:14:12 CDT 2022 ------------------------------------ This version of Test::WWW::Mechanize requires Perl 5.10. [ENHANCEMENTS] Add check_all_images_ok(). (GH #17) Thanks, Julien Fiegehenn. This is the first version of this function, and its functionality may change in the near future. [DOCUMENTATION] Fixed some incorrect docs. Thanks, Daniel Böhmer. [INTERNALS] Require Perl 5.10. Explicitly requires HTTP::Message 6.29 or higher. 1.54 Tue Dec 8 23:25:06 CST 2020 ------------------------------------ [ENHANCEMENTS] Use ok() instead of cmp_ok() inside of lacks_uncapped_inputs(). This output makes more sense. lacks_uncapped_inputs() now has a a default message if one isn't supplied. [FIXES] Fixed the subtest name inside of C. Fixed the minimum version of Carp::Assert::More in Makefile.PL. 1.52 Wed Dec 5 10:00:56 CST 2018 ------------------------------------ [ENHANCEMENTS] click_ok() method can now take a button with X/Y coordinates. Thanks to GitHub user @marderh. (GH #45) Added the ability to modify the HTML that the html_tidy_ok() validates. See the content_for_validation() method. (GH #61) Add a set of methods for existence of IDs: id_exists(), id_exists_ok(), ids_exist_ok(), lacks_id_ok() and lacks_ids_ok(). (GH #48) Add button_exists(), button_exists_ok() and lacks_button_ok() methods. (GH #50) [FIXES] Clarified warnings to make it clear that certain modules are optional. Thanks, Matthew Chae. 1.50 Mon Apr 16 15:16:59 CDT 2018 ------------------------------------ [FIXES] Added html_tidy_ok() methods, analogous to html_lint_ok(). Remove unnecessary dependency on HTML::TreeBuilder. Thanks, Kent Fredric. 1.49_01 Mon Mar 26 10:58:51 CDT 2018 ------------------------------------ [ENHANCEMENTS] Adding autotidy functionality. autotidy lets you validate every page that Mech gets using the HTML::Tidy5 module, just like the autolint feature does with the HTML::Lint module. HTML::Tidy5 is a much more complete HTML checking tool, and validates HTML5 which HTML::Lint does not. You must have HTML::Tidy5 1.00 installed to use autotidy. 1.48 Thu Dec 29 22:45:29 CST 2016 ------------------------------------ [FIXES] The linting method html_lint_ok() was not calling the HTML::Lint API correctly, so may have missed some HTML errors at the end of a page. This also applies to get, post, etc if you have the autolint argument on. 1.46 ------------------------------------ [ENHANCEMENTS] Added header_exists_ok(), lacks_header(), header_is() and header_like() methods. Thanks to Eric A. Zarko for the original patches. The scraped_id_is() method used to assign a description for the test if one was not passed. Now it does not. scraped_id_is() now gives proper diagnostics if an ID is not found in the HTML. Added a delete_ok() method. Thanks, moznion. content_contains() now fails if it's called with a regex. content_like() now fails if it's not called with a regex. [FIXES] The test server run during the test suite allowed URLs outside of the document tree, which could potentially be a security problem. This has been fixed. Thanks, Tynovsky. https://github.com/petdance/test-www-mechanize/issues/33 Fixed an overly-restrictive optimization in scrape_text_by_id(), plus scraped_id_is() and scraped_id_like() which wrap it. The method checks to make sure that it doesn't bother looking for an ID on the page if the ID doesn't exist. It did this by looking for the text id="foo" where foo is the ID being searched for. However, that would mean that tags like

would be seen as not existing. This has been fixed by making scrape_text_by_id() search for the string "foo" anywhere on the page. 1.44 Sat Jun 30 20:32:04 CDT 2012 ------------------------------------ There is no new functionality in this release. [FIXES] Fixed test failures on Win32. Thanks, Jerry Gay. 1.42 Thu May 31 11:35:26 CDT 2012 ------------------------------------ If you want to use the autolint functionality, you'll have to have HTML::Lint 2.20. [FIXES] Custom lint objects don't get reset before they get used, making autolint with a custom lint object practically useless. https://github.com/petdance/test-www-mechanize/issues/25 1.40 Fri Apr 13 15:14:39 CDT 2012 ------------------------------------ [ENHANCEMENTS] Added a $mech->autolint() method so you can turn autolinting on and off in mid-program. Thanks, Mike O'Regan. New functions $mech->scrape_text_by_id() and $mech->scrape_text_by_attr() let you extract text from your pages. Convenience function $mech->scraped_id_is() makes it easy to scrape and compare in one function.

My Awesome Page!

# Verify that HTML is there with: $mech->scraped_id_is( 'pagetitle', 'My Awesome Page!' ); [FIXES] $mech->has_tag() now handles nested tags more sensibly. This fixes Google Code ticket #1. [INTERNALS] Explicitly requires Test::Simple 0.94 or higher. Brought over t/TestServer.pm from WWW::Mechanize which fixes a number of problems. 1.38 Fri Oct 28 10:12:48 CDT 2011 ------------------------------------ [FIXES] Now passes tests even if HTML::Lint is not installed. There are no other changes in 1.38. 1.36 Thu Oct 27 00:09:21 CDT 2011 ------------------------------------ [ENHANCEMENTS] The $mech object autolint argument can now take an HTML::Lint object. This lets you pass your own HTML::Lint object that does less stringent checking than the one T:W:M creates. 1.34 Tue Jul 5 16:23:24 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. $mech->followable_links() now finds file: URLs, too. $mech->content_contains(), $mech->content_lacks(), $mech->text_contains(0 and $mech->text_lacks() all fail if a reference is passed instead of a string. [FIXES] $mech->text_contains() was not calling $mech->text(), so was not taking advantage of the caching of the parsed text. [INTERNALS] Most tests no longer use TestServer.pm class. All tests now run under -T and have plan counts. 1.32 Wed May 11 10:12:25 CDT 2011 ------------------------------------ No changes from 1.31_01. 1.31_01 Wed May 4 16:07:31 CDT 2011 ------------------------------------ [ENHANCEMENTS] The methods that look at the text of the page, ->text_like() and ->text_unlike(), now use the WWW::Mechanize method ->text() which caches the text. This will be a big speedup if you call these methods more than once. [FIXED] Normalized the use of single vs. double quotes in the default descriptions. Fixed tests that fail under newer versions of LWP. Fixed tests that fail if http_proxy or HTTP_PROXY are set. Fixed tests that fail on Perl 5.14. 1.30 Wed Jun 9 12:23:48 CDT 2010 ------------------------------------ [ENHANCEMENTS] autolint used to only work on get_ok() calls. Now it works with post_ok(), submit_form_ok(), follow_link_ok() and click_ok(). Added $mech->text_contains(), $mech->text_like() and $mech->text_unlike() methods. These check the text of an HTML page separate from the HTML markup. Thanks to Ashley Pond V. [FIXED] t/head_ok.t should no longer fail if your ISP "helpfully" returns an IP address for non-existent DNS records. Thanks, Schwern. 1.28 Tue Apr 13 00:44:27 CDT 2010 ------------------------------------ [FIXED] t/put_ok.t finally passes. 1.26 Mon Apr 5 00:54:46 CDT 2010 ------------------------------------ [FIXED] Description of error in $mech->content_unlike() was wrong. Now requires Test::LongString 0.12. t/put_ok.t now passes, but with a handful of warnings. Help in figuring out why would be appreciated. [INTERNALS] Hoisted common code out of get_ok, post_ok, etc. [DOCUMENTATION] Updated copyright and licensing information. 1.24 Sat Jan 17 13:26:47 CST 2009 ------------------------------------ Tests run on port 13432 instead of 8080. It should really be a random open port, but for now, something other than 8080 will do. 1.23_01 Mon Dec 22 17:43:46 CST 2008 ------------------------------------ [FIXED] Tests would fail because we weren't unsetting http_proxy. Fixed many failed tests. Overhauled the test server setup. [ENHANCEMENTS] Added autolinting capability, so you can do this: my $mech = Test::WWW::Mechanize->new( autolint => 1 ); $mech->get_ok( $url ); and the get_ok() will fail if the page is fetched, but the resultant HTML (if it is indeed text/html) does not pass HTML::Lint. Added $mech->click_ok(). The user agent is now "Test-WWW-Mechanize/version" by default. 1.22 Thu Nov 20 00:33:36 CST 2008 ------------------------------------ [ENHANCEMENTS] Added $mech->head_ok() and $mech->put_ok() methods. Thanks to Jaldhar Vyas. 1.20 Wed Mar 12 23:56:11 CDT 2008 ------------------------------------ [FIXES] stuff_inputs() used to do nothing. Now it works. http://code.google.com/p/www-mechanize/issues/detail?id=9 Fixed punctuation in some error messages. Fixed compatibility with WWW::Mechanize 1.36. 1.18 Thu Dec 6 10:12:14 CST 2007 ------------------------------------ [ENHANCEMENTS] Added default descriptions for most test assertions. [FIXES] HTML::Lint is now properly optional. Added delays in all the tests that use HTTP::Server::Simple to give it time to correctly fire up. 1.16 Mon Oct 29 15:34:21 CDT 2007 ------------------------------------ [ENHANCEMENTS] Added $mech->post_ok(). Thanks, Greg Sheard. Added $mech->submit_form_ok(). Thanks, Mark Stosberg. Added $mech->html_lint_ok() [FIXES] Fixed some bugs that were causing test failures. 1.14 Fri May 11 16:22:02 CDT 2007 ------------------------------------ [FIXES] Fixes test failures. Thanks to Mark Blackman for RT #26602: The module tests currently spawn a server (based on HTTP::Server::Simple::CGI) which is killed when a __DIE__ signal is received, normally only when the invoking perl dies. However, as perlvar makes clear, the __DIE__ signal is received when eval blocks die as well. The new version (1.22) of WWW::Mechanize now calles HTTP::Message::decoded_content which calls Encode.pm which has a eval block that require's Encode::ConfigLocal which is usually not present, so the eval dies and the HTTP server is killed as soon as the $mech object tries to do a 'get'. It's simple to use a system variable, $^S to find out if the __DIE__ signal is being called for an eval so we ignore that case with the patch attached. [DOCUMENTATION] * Made the synopsis show that T:W:M doesn't take the tests=>$x like other Test::* modules. It'd be nice if it did, though. 1.12 Thu Jul 6 23:47:59 CDT 2006 ------------------------------------ [ENHANCEMENTS] Added followable_links() method to return only those links that your mech can actually follow. 1.10 Sun Jun 18 22:58:41 CDT 2006 ------------------------------------ [FIXES] RT #19147: Tests turn off the http_proxy environment variable before starting. Thanks to Matt Trout. RT #18779: makes stuff_inputs() conform to the documentation, changing the implementation to expect an arrayref for $options->{ignore}, as opposed to a hashref. Thanks to Mike O'Regan. [ENHANCEMENTS] Added base_is, base_like and base_unlike. Thanks to MATSUNO Tokuhiro. 1.08 Mon Nov 21 10:35:23 CST 2005 ------------------------------------ [FIXES] has_tag_like()'s regex was reversed, so would match when it shouldn't. Thanks to Chris Dolan. [DOCUMENTATION] Added links to support sites. 1.06 Jun 29 2005 ------------------------------------ [INTERNALS] Updated test suite to use HTTP::Server::Simple. Thanks to Shawn Sorichetti for it. 1.05_02 Sun Apr 3 12:19:05 CDT 2005 ------------------------------------ [ENHANCEMENTS] Added has_tag() and has_tag_like(). Thanks RJBS. 1.05_01 Tue Mar 8 16:24:36 CST 2005 ------------------------------------ [ENHANCEMENTS] get_ok() now shows the status line for the mech if the test fails. get_ok() now returns true/false, not an HTTP::Response. 1.04 Fri Mar 4 00:08:42 CST 2005 ------------------------------------ [ENHANCEMENTS] Added follow_link_ok(). Thanks to Mike O'Regan. Added get_ok(). Thanks to Dan Friedman. 1.02 Wed Dec 15 17:35:23 CST 2004 ------------------------------------ [ENHANCEMENTS] Added content_lacks() [DOCUMENTATION] Fixed some documentation bugs. Thanks to Drew Taylor. 1.00 Thu Dec 9 11:41:50 CST 2004 ------------------------------------ [ENHANCEMENTS] Added content_contains() Fixed diagnostic errors to work the same way regardless of which version of Test::Builder you have. 0.99 Sun Oct 24 11:17:59 CDT 2004 ------------------------------------ [ENHANCEMENTS] Added $mech->content_unlike and $mech->title_unlike Made the reporting of where the error happened reflect the caller's code. 0.06 Thu Sep 30 21:49:08 CDT 2004 ------------------------------------ [ENHANCEMENTS] New funcs - page_links_content_like() - page_links_content_unlike() - link_content_like() - link_content_unlike() - link_status_isnt() 0.04 Mon Jul 12 22:16:10 CDT 2004 ------------------------------------ [THINGS THAT MAY BREAK YOUR CODE] Renamed link_status() to link_status_is(). [FIXES] Fixed a bug in link_status_is(). 0.02 July 4 2004 ------------------------------------ [ENHANCEMENTS] Added links_ok() and page_links_ok() methods. Thanks to Shawn Sorichetti. 0.01 Mon Jun 28 16:38:45 CDT 2004 ------------------------------------ First version, released on an unsuspecting world. Test-WWW-Mechanize-1.60/MANIFEST0000644000175000017500000000200414343270553014545 0ustar andyandyChanges MANIFEST Makefile.PL Mechanize.pm README.md t/00-load.t t/autolint.t t/autotidy.t t/bad.html t/badlinks.html t/button_exists.t t/click_ok.t t/content_contains.t t/content_lacks.t t/delete_ok.t t/fluffy.html t/followable_links.t t/follow_link_ok.t t/get_ok-parms.t t/get_ok.t t/good.html t/goodlinks.html t/has_tag.t t/head_ok-parms.t t/head_ok.t t/headers.t t/html/form.html t/html_lint_ok.t t/html_tidy_ok.t t/html/scratch.html t/id_exists.t t/id_exists.html t/lacks_uncapped_inputs-bad.html t/lacks_uncapped_inputs-good.html t/lacks_uncapped_inputs.t t/link_content.t t/links_ok.t t/link_status.t t/manylinks.html t/new.t t/page_links_content.t t/page_links_ok.t t/pod-coverage.t t/pod.t t/post_ok.t t/put_ok.t t/scrape_text_by_id.t t/stuff_inputs.html t/stuff_inputs.t t/submit_form_ok.t t/table.html t/TestServer.pm t/text_contains.t t/title_is.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Test-WWW-Mechanize-1.60/README.md0000644000175000017500000000550314343263442014701 0ustar andyandy# Test-WWW-Mechanize * Build status: [![Build Status](https://github.com/petdance/test-www-mechanize/workflows/testsuite/badge.svg?branch=dev)](https://github.com/petdance/test-www-mechanize/actions?query=workflow%3Atestsuite+branch%3Adev) * cpantesters.org: [summary](http://www.cpantesters.org/distro/T/Test-WWW-Mechanize.html) and [dev FAILures](http://www.cpantesters.org/distro/T/Test-WWW-Mechanize.html?grade=3&perlmat=2&patches=2&oncpan=2&distmat=3&perlver=ALL&osname=ALL&version=1.44) ---- Test::WWW::Mechanize is a subclass of the Perl module WWW::Mechanize that incorporates features for web application testing. For example: use Test::WWW::Mechanize; my $mech = Test::WWW::Mechanize->new; $mech->get_ok( $page ); $mech->base_is( 'http://petdance.com/', 'Proper ' ); $mech->title_is( 'Invoice Status', "Make sure we're on the invoice page" ); $mech->text_contains( 'Andy Lester', 'My name somewhere' ); $mech->content_like( qr/(cpan|perl)\.org/, 'Link to perl.org or CPAN' ); $mech->header_is( 'Cache-Control', 'private', 'Caching is turned off' ); $mech->lacks_header_ok( 'X-Foo', 'Does not have the X-Foo header' ); This is equivalent to: use WWW::Mechanize; my $mech = WWW::Mechanize->new; $mech->get( $page ); ok( $mech->success ); is( $mech->base, 'http://petdance.com', 'Proper ' ); is( $mech->title, 'Invoice Status', "Make sure we're on the invoice page" ); ok( index( $mech->content( format => 'text' ), 'Andy Lester' ) >= 0, 'My name somewhere' ); like( $mech->content, qr/(cpan|perl)\.org/, 'Link to perl.org or CPAN' ); is( $mech->response->header( 'Cache-Control' ), 'private', 'Caching is turned off' ); ok( !defined $mech->response->header( 'X-Foo' ), 'Does not have the X-Foo header' ); but has nicer diagnostics if they fail. Test::WWW::Mechanize also has functionality to automatically validate every page it goes to. use Test::WWW::Mechanize; my $mech = Test::WWW::Mechanize->new( autotidy => 1 ); $mech->get_ok( $url ); which can give errors like this: not ok 1 - GET $url # Failed test '$url' # at foo.pl line 7. # HTML::Tidy5 messages for $url # (11:1) Warning: missing before # (7:18) Warning: escaping malformed URI reference # (7:18) Warning: illegal characters found in URI # (11:1) Warning: trimming empty The autotidy feature requires the HTML::Tidy5 module. The similar, but less robust, autolint feature requires the HTML::Lint module. # INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install # COPYRIGHT AND LICENSE Copyright (C) 2004-2018 Andy Lester This library is free software; you can redistribute it and/or modify it under the terms of the Artistic License version 2.0. Test-WWW-Mechanize-1.60/Makefile.PL0000644000175000017500000000541014343270541015367 0ustar andyandyuse strict; use warnings; use ExtUtils::MakeMaker; my $parms = { NAME => 'Test::WWW::Mechanize', AUTHOR => 'Andy Lester ', VERSION_FROM => 'Mechanize.pm', ABSTRACT_FROM => 'Mechanize.pm', PL_FILES => {}, PREREQ_PM => { 'Carp' => 0, 'Carp::Assert::More' => '1.16', 'HTML::Form' => 0, 'HTML::TokeParser' => 0, 'HTTP::Message' => '6.29', 'LWP' => '6.02', 'Test::Builder' => 0, 'Test::LongString' => '0.15', 'WWW::Mechanize' => '1.68', 'parent' => 0, }, TEST_REQUIRES => { 'HTTP::Server::Simple' => '0.42', 'HTTP::Server::Simple::CGI' => 0, 'Test::Builder::Tester' => '1.09', 'Test::More' => '0.96', # subtest() and done_testing() 'URI::file' => 0, }, MIN_PERL_VERSION => 5.010, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Test-WWW-Mechanize-*' }, }; my $eumm_version = $ExtUtils::MakeMaker::VERSION; $eumm_version =~ tr/_//d; # TEST_REQUIRES is not supported in EUMM <= 6.63_03, so collapse the test # prereqs into the build prereqs. if ( $eumm_version <= 6.63_03 ) { $parms->{BUILD_REQUIRES} = { %{ $parms->{BUILD_REQUIRES} }, %{ delete $parms->{TEST_REQUIRES} || {} }, }; } # BUILD_REQUIRES is not supported in EUMM <= 6.55_01, so collapse the build # preereqs into the standard prereqs. if ( $eumm_version <= 6.63_03 ) { $parms->{PREPREQ_PM} = { %{ $parms->{PREPREQ_PM} }, %{ delete $parms->{BUILD_REQUIRES} || {} }, }; } if ( $eumm_version > 6.30 ) { $parms->{LICENSE} = 'artistic_2'; } if ( $eumm_version >= 6.46 ) { $parms->{META_MERGE} = { resources => { license => 'https://opensource.org/licenses/artistic-license-2.0', homepage => 'https://github.com/petdance/test-www-mechanize', bugtracker => 'https://github.com/petdance/test-www-mechanize/issues', repository => 'https://github.com/petdance/test-www-mechanize', } }; } my $module = 'HTML::Lint 2.20'; if ( not eval "use $module; 1;" ) { print "You don't have $module installed, so cannot use autolinting.\n"; } WriteMakefile( %{$parms} ); sub MY::postamble { return <<'MAKE_FRAG'; .PHONY: critic tags critic: perlcritic -1 -q -profile perlcriticrc Mechanize.pm t/ tags: ctags -f tags --recurse --totals \ --exclude=blib \ --exclude=.svn \ --exclude='*~' \ --languages=Perl --langmap=Perl:+.t \ MAKE_FRAG } Test-WWW-Mechanize-1.60/Mechanize.pm0000644000175000017500000016600614343270541015667 0ustar andyandypackage Test::WWW::Mechanize; use strict; use warnings; use 5.010; =head1 NAME Test::WWW::Mechanize - Testing-specific WWW::Mechanize subclass =head1 VERSION Version 1.60 =cut our $VERSION = '1.60'; =head1 SYNOPSIS Test::WWW::Mechanize is a subclass of L that incorporates features for web application testing. For example: use Test::More tests => 5; use Test::WWW::Mechanize; my $mech = Test::WWW::Mechanize->new; $mech->get_ok( $page ); $mech->base_is( 'http://petdance.com/', 'Proper ' ); $mech->title_is( 'Invoice Status', "Make sure we're on the invoice page" ); $mech->text_contains( 'Andy Lester', 'My name somewhere' ); $mech->content_like( qr/(cpan|perl)\.org/, 'Link to perl.org or CPAN' ); This is equivalent to: use Test::More tests => 5; use WWW::Mechanize; my $mech = WWW::Mechanize->new; $mech->get( $page ); ok( $mech->success ); is( $mech->base, 'http://petdance.com', 'Proper ' ); is( $mech->title, 'Invoice Status', "Make sure we're on the invoice page" ); ok( index( $mech->content( format => 'text' ), 'Andy Lester' ) >= 0, 'My name somewhere' ); like( $mech->content, qr/(cpan|perl)\.org/, 'Link to perl.org or CPAN' ); but has nicer diagnostics if they fail. Default descriptions will be supplied for most methods if you omit them. e.g. my $mech = Test::WWW::Mechanize->new; $mech->get_ok( 'http://petdance.com/' ); $mech->base_is( 'http://petdance.com/' ); $mech->title_is( 'Invoice Status' ); $mech->content_contains( 'Andy Lester' ); $mech->content_like( qr/(cpan|perl)\.org/ ); results in ok - Got 'http://petdance.com/' ok ok - Base is 'http://petdance.com/' ok - Title is 'Invoice Status' ok - Text contains 'Andy Lester' ok - Content is like '(?-xism:(cpan|perl)\.org)' =cut use HTML::TokeParser (); use WWW::Mechanize (); use Test::LongString; use Test::Builder (); use Carp (); use Carp::Assert::More qw( assert_arrayref assert_in assert_is assert_isa assert_nonblank ); use parent 'WWW::Mechanize'; my $TB = Test::Builder->new(); =head1 CONSTRUCTOR =head2 new( %args ) Behaves like, and calls, L's C method. Any parms passed in get passed to WWW::Mechanize's constructor. You can pass in C<< autolint => 1 >> to make Test::WWW::Mechanize automatically run HTML::Lint after any of the following methods are called. You can also pass in an HTML::Lint object like this: my $lint = HTML::Lint->new( only_types => HTML::Lint::Error::STRUCTURE ); my $mech = Test::WWW::Mechanize->new( autolint => $lint ); The same is also possible with C<< autotidy => 1 >> to use HTML::Tidy5. =over =item * get_ok() =item * post_ok() =item * submit_form_ok() =item * follow_link_ok() =item * click_ok() =back This means you no longer have to do the following: my $mech = Test::WWW::Mechanize->new(); $mech->get_ok( $url, 'Fetch the intro page' ); $mech->html_lint_ok( 'Intro page looks OK' ); and can simply do my $mech = Test::WWW::Mechanize->new( autolint => 1 ); $mech->get_ok( $url, 'Fetch the intro page' ); The C<< $mech->get_ok() >> only counts as one test in the test count. Both the main IO operation and the linting must pass for the entire test to pass. You can control autolint and autotidy on the fly with the C and C methods. =cut sub new { my $class = shift; my %args = ( agent => "Test-WWW-Mechanize/$VERSION", @_ ); my $autolint = delete $args{autolint}; my $autotidy = delete $args{autotidy}; my $self = $class->SUPER::new( %args ); $self->autolint( $autolint ); $self->autotidy( $autotidy ); return $self; } # Override WWW::Mechanize->_reset_page() to handle Test::WWW::Mechanize-specific data. sub _reset_page { my $self = shift; # Parent object stuff $self->SUPER::_reset_page( @_ ); $self->{ids} = undef; return; } =head1 METHODS: HTTP VERBS =head2 $mech->get_ok($url, [ \%LWP_options ,] $desc) A wrapper around WWW::Mechanize's get(), with similar options, except the second argument needs to be a hash reference, not a hash. Like well-behaved C<*_ok()> functions, it returns true if the test passed, or false if not. A default description of "GET $url" is used if none if provided. =cut sub get_ok { my $self = shift; my ($url,$desc,%opts) = $self->_unpack_args( 'GET', @_ ); if ( !defined($url) ) { my $ok = $TB->ok( 0, $desc ); $TB->diag( 'URL cannot be undef.' ); return $ok; } $self->get( $url, %opts ); my $ok = $self->success; $ok = $self->_post_load_validation( $ok, $desc ); return $ok; } sub _post_load_validation { my $self = shift; my $ok = shift; my $desc = shift; local $Test::Builder::Level = $Test::Builder::Level + 1; if ( $ok ) { my $emitted_ok = 0; if ( $self->is_html ) { if ( $self->autolint && $self->autotidy ) { my $msg = 'autolint & autotidy'; $msg .= ": $desc" if defined $desc; $TB->subtest( $desc, sub { $self->_lint_content_ok(); $self->_tidy_content_ok(); } ); ++$emitted_ok; } else { if ( $self->autolint ) { $ok = $self->_lint_content_ok( $desc ); ++$emitted_ok; } elsif ( $self->autotidy ) { $ok = $self->_tidy_content_ok( $desc ); ++$emitted_ok; } } } if ( !$emitted_ok ) { $TB->ok( $ok, $desc ); if ( !$ok ) { # Only show the URL and not the response message, because the # problem is with the lint/tidy, not the fetching of the URL. my $url = $self->_diag_url(); $TB->diag( $url ) if $url; } } } else { $TB->ok( $ok, $desc ); my $url = $self->_diag_url(); $TB->diag( $url ) if $url; $TB->diag( $self->status ); $TB->diag( $self->response->message ) if $self->response; } return $ok; } =head2 $mech->head_ok($url, [ \%LWP_options ,] $desc) A wrapper around WWW::Mechanize's head(), with similar options, except the second argument needs to be a hash reference, not a hash. Like well-behaved C<*_ok()> functions, it returns true if the test passed, or false if not. A default description of "HEAD $url" is used if none if provided. =cut sub head_ok { my $self = shift; my ($url,$desc,%opts) = $self->_unpack_args( 'HEAD', @_ ); if ( !defined($url) ) { my $ok = $TB->ok( 0, $desc ); $TB->diag( 'URL cannot be undef.' ); return $ok; } $self->head( $url, %opts ); my $ok = $self->success; $TB->ok( $ok, $desc ); if ( !$ok ) { my $url = $self->_diag_url(); $TB->diag( $url ) if $url; $TB->diag( $self->status ); $TB->diag( $self->response->message ) if $self->response; } return $ok; } =head2 $mech->post_ok( $url, [ \%LWP_options ,] $desc ) A wrapper around WWW::Mechanize's post(), with similar options, except the second argument needs to be a hash reference, not a hash. Like well-behaved C<*_ok()> functions, it returns true if the test passed, or false if not. B Due to compatibility reasons it is not possible to pass additional LWP_options beyond form data via this method (such as Content or Content-Type). It is recommend that you use WWW::Mechanize's post() directly for instances where more granular control of the post is needed. A default description of "POST to $url" is used if none if provided. =cut sub post_ok { my $self = shift; my ($url,$desc,%opts) = $self->_unpack_args( 'POST', @_ ); if ( !defined($url) ) { my $ok = $TB->ok( 0, $desc ); $TB->diag( 'URL cannot be undef.' ); return $ok; } $self->post( $url, \%opts ); my $ok = $self->success; $ok = $self->_post_load_validation( $ok, $desc ); return $ok; } =head2 $mech->put_ok( $url, [ \%LWP_options ,] $desc ) A wrapper around WWW::Mechanize's put(), with similar options, except the second argument needs to be a hash reference, not a hash. Like well-behaved C<*_ok()> functions, it returns true if the test passed, or false if not. A default description of "PUT to $url" is used if none if provided. =cut sub put_ok { my $self = shift; my ($url,$desc,%opts) = $self->_unpack_args( 'PUT', @_ ); if ( !defined($url) ) { my $ok = $TB->ok( 0, $desc ); $TB->diag( 'URL cannot be undef.' ); return $ok; } $opts{content} = '' if !exists $opts{content}; $self->put( $url, %opts ); my $ok = $self->success; $TB->ok( $ok, $desc ); if ( !$ok ) { my $url = $self->_diag_url(); $TB->diag( $url ) if $url; $TB->diag( $self->status ); $TB->diag( $self->response->message ) if $self->response; } return $ok; } =head2 $mech->delete_ok( $url, [ \%LWP_options ,] $desc ) A wrapper around WWW::Mechanize's delete(), with similar options, except the second argument needs to be a hash reference, not a hash. Like well-behaved C<*_ok()> functions, it returns true if the test passed, or false if not. A default description of "DELETE to $url" is used if none if provided. =cut sub delete_ok { my $self = shift; my ($url,$desc,%opts) = $self->_unpack_args( 'DELETE', @_ ); if ( !defined($url) ) { my $ok = $TB->ok( 0, $desc ); $TB->diag( 'URL cannot be undef.' ); return $ok; } if ($self->can('delete')) { $self->delete( $url, %opts ); } else { # When version of LWP::UserAgent is older than 6.04. $self->_delete( $url, %opts ); } my $ok = $self->success; $ok = $self->_post_load_validation( $ok, $desc ); return $ok; } sub _delete { require URI; require HTTP::Request::Common; my $self = shift; my $uri = shift; $uri = $uri->url if ref($uri) eq 'WWW::Mechanize::Link'; $uri = $self->base ? URI->new_abs( $uri, $self->base ) : URI->new($uri); my @parameters = ( $uri->as_string, @_ ); my @suff = $self->_process_colonic_headers( \@parameters, 1 ); return $self->request( HTTP::Request::Common::DELETE(@parameters), @suff ); } =head2 $mech->submit_form_ok( \%parms [, $desc] ) Makes a C call and executes tests on the results. The form must be found, and then submitted successfully. Otherwise, this test fails. I<%parms> is a hashref containing the parms to pass to C. Note that the parms to C are a hash whereas the parms to this function are a hashref. You have to call this function like: $mech->submit_form_ok( { form_number => 3, fields => { answer => 42 }, }, 'now we just need the question' ); As with other test functions, C<$desc> is optional. If it is supplied then it will display when running the test harness in verbose mode. Returns true value if the specified link was found and followed successfully. The L object returned by submit_form() is not available. =cut sub submit_form_ok { my $self = shift; my $parms = shift || {}; my $desc = shift; if ( ref $parms ne 'HASH' ) { Carp::croak 'FATAL: parameters must be given as a hashref'; } # return from submit_form() is an HTTP::Response or undef my $response = $self->submit_form( %{$parms} ); my $ok = $response && $response->is_success; $ok = $self->_post_load_validation( $ok, $desc ); return $ok; } =head2 $mech->follow_link_ok( \%parms [, $desc] ) Makes a C call and executes tests on the results. The link must be found, and then followed successfully. Otherwise, this test fails. I<%parms> is a hashref containing the parms to pass to C. Note that the parms to C are a hash whereas the parms to this function are a hashref. You have to call this function like: $mech->follow_link_ok( {n=>3}, 'looking for 3rd link' ); As with other test functions, C<$desc> is optional. If it is supplied then it will display when running the test harness in verbose mode. Returns a true value if the specified link was found and followed successfully. The L object returned by follow_link() is not available. =cut sub follow_link_ok { my $self = shift; my $parms = shift || {}; my $desc = shift; if (!defined($desc)) { my $parms_str = join(', ', map { join('=', $_, $parms->{$_}) } keys(%{$parms})); $desc = qq{Followed link with "$parms_str"} if !defined($desc); } if ( ref $parms ne 'HASH' ) { Carp::croak 'FATAL: parameters must be given as a hashref'; } # The return from follow_link() is an HTTP::Response or undef. my $response = $self->follow_link( %{$parms} ); my $ok = $response && $response->is_success; $ok = $self->_post_load_validation( $ok, $desc ); return $ok; } =head2 $mech->click_ok( $button[, $desc] ) =head2 $mech->click_ok( \@button-and-coordinates [, $desc ] ) Clicks the button named by C<$button>. An optional C<$desc> can be given for the test. $mech->click_ok( 'continue', 'Clicking the "Continue" button' ); Alternatively the first argument can be an arrayref with three elements: The name of the button and the X and Y coordinates of the button. $mech->click_ok( [ 'continue', 12, 47 ], 'Clicking the "Continue" button' ); =cut sub click_ok { my $self = shift; my $button = shift; my $desc = shift; my $response; if ( ref($button) eq 'ARRAY' ) { $response = $self->click( $button->[0], $button->[1], $button->[2] ); } else { $response = $self->click( $button ); } if ( !$response ) { return $TB->ok( 0, $desc ); } my $ok = $response->is_success; $ok = $self->_post_load_validation( $ok, $desc ); return $ok; } sub _unpack_args { my $self = shift; my $method = shift; my $url = shift; my $desc; my %opts; if ( @_ ) { my $flex = shift; # The flexible argument if ( !defined( $flex ) ) { $desc = shift; } elsif ( ref $flex eq 'HASH' ) { %opts = %{$flex}; $desc = shift; } elsif ( ref $flex eq 'ARRAY' ) { %opts = @{$flex}; $desc = shift; } else { $desc = $flex; } } # parms left if ( not defined $desc ) { $url = $url->url if ref($url) eq 'WWW::Mechanize::Link'; $desc = "$method $url"; } return ($url, $desc, %opts); } =head1 METHODS: HEADER CHECKING =head2 $mech->header_exists_ok( $header [, $desc ] ) Assures that a given response header exists. The actual value of the response header is not checked, only that the header exists. =cut sub header_exists_ok { my $self = shift; my $header = shift; my $desc = shift || qq{Response has $header header}; return $TB->ok( defined($self->response->header($header)), $desc ); } =head2 $mech->lacks_header_ok( $header [, $desc ] ) Assures that a given response header does NOT exist. =cut sub lacks_header_ok { my $self = shift; my $header = shift; my $desc = shift || qq{Response lacks $header header}; return $TB->ok( !defined($self->response->header($header)), $desc ); } =head2 $mech->header_is( $header, $value [, $desc ] ) Assures that a given response header exists and has the given value. =cut sub header_is { my $self = shift; my $header = shift; my $value = shift; my $desc = shift || qq{Response has $header header with value "$value"}; # Force scalar context. my $actual_value = $self->response->header($header); my $ok; if ( defined( $actual_value ) ) { $ok = $TB->is_eq( $actual_value, $value, $desc ); } else { $ok = $TB->ok( 0, $desc ); $TB->diag( "Header $header does not exist" ); } return $ok; } =head2 $mech->header_like( $header, $value [, $desc ] ) Assures that a given response header exists and has the given value. =cut sub header_like { my $self = shift; my $header = shift; my $regex = shift; my $desc = shift || qq{Response has $header header that matches regex $regex}; # Force scalar context. my $actual_value = $self->response->header($header); return $TB->like( $self->response->header($header), $regex, $desc ); } =head1 METHODS: CONTENT CHECKING =head2 $mech->html_lint_ok( [$desc] ) Checks the validity of the HTML on the current page using the HTML::Lint module. If the page is not HTML, then it fails. The URI is automatically appended to the I<$desc>. Note that HTML::Lint must be installed for this to work. Otherwise, it will blow up. =cut sub html_lint_ok { my $self = shift; my $desc = shift; my $uri = $self->uri; $desc = $desc ? "$desc ($uri)" : $uri; my $ok; if ( $self->is_html ) { $ok = $self->_lint_content_ok( $desc ); } else { $ok = $TB->ok( 0, $desc ); $TB->diag( q{This page doesn't appear to be HTML, or didn't get the proper text/html content type returned.} ); } return $ok; } sub _lint_content_ok { local $Test::Builder::Level = $Test::Builder::Level + 1; my $self = shift; my $desc = shift; my $module = "HTML::Lint 2.20"; if ( not ( eval "use $module; 1;" ) ) { die "Test::WWW::Mechanize can't do linting without $module: $@"; } my $lint = $self->{autolint}; if ( ref $lint && $lint->isa('HTML::Lint') ) { $lint->newfile; $lint->clear_errors; } else { $lint = HTML::Lint->new(); } $lint->parse( $self->content ); $lint->eof(); my @errors = $lint->errors; my $nerrors = @errors; my $ok; if ( $nerrors ) { $ok = $TB->ok( 0, $desc ); $TB->diag( 'HTML::Lint errors for ' . $self->uri ); $TB->diag( $_->as_string ) for @errors; my $s = $nerrors == 1 ? '' : 's'; $TB->diag( "$nerrors error$s on the page" ); } else { $ok = $TB->ok( 1, $desc ); } return $ok; } =head2 $mech->html_tidy_ok( [$desc] ) Checks the validity of the HTML on the current page using the HTML::Tidy module. If the page is not HTML, then it fails. The URI is automatically appended to the I<$desc>. Note that HTML::tidy must be installed for this to work. Otherwise, it will blow up. =cut sub html_tidy_ok { my $self = shift; my $desc = shift; my $uri = $self->uri; $desc = $desc ? "$desc ($uri)" : $uri; my $ok; if ( $self->is_html ) { $ok = $self->_tidy_content_ok( $desc ); } else { $ok = $TB->ok( 0, $desc ); $TB->diag( q{This page doesn't appear to be HTML, or didn't get the proper text/html content type returned.} ); } return $ok; } sub _tidy_content_ok { local $Test::Builder::Level = $Test::Builder::Level + 1; my $self = shift; my $desc = shift; my $module = 'HTML::Tidy5 1.00'; if ( not ( eval "use $module; 1;" ) ) { die "Test::WWW::Mechanize can't do tidying without $module: $@"; } my $tidy = $self->{autotidy}; if ( ref $tidy && $tidy->isa('HTML::Tidy5') ) { $tidy->clear_messages(); } else { $tidy = HTML::Tidy5->new(); } $tidy->parse( '', $self->content_for_tidy ); my @messages = $tidy->messages; my $nmessages = @messages; my $ok; if ( $nmessages ) { $ok = $TB->ok( 0, $desc ); $TB->diag( 'HTML::Tidy5 messages for ' . $self->uri ); $TB->diag( $_->as_string ) for @messages; my $s = $nmessages == 1 ? '' : 's'; $TB->diag( "$nmessages message$s on the page" ); } else { $ok = $TB->ok( 1, $desc ); } return $ok; } =head2 $mech->content_for_tidy() This method is called by C to get the content that should be validated by HTML::Tidy5. By default, this is just C, but subclasses can override it to modify the content before validation. This method should not change any state in the Mech object. Specifically, it should not actually modify any of the actual content. =cut sub content_for_tidy { my $self = shift; return $self->content; } =head2 $mech->title_is( $str [, $desc ] ) Tells if the title of the page is the given string. $mech->title_is( 'Invoice Summary' ); =cut sub title_is { my $self = shift; my $str = shift; my $desc = shift; $desc = qq{Title is "$str"} if !defined($desc); local $Test::Builder::Level = $Test::Builder::Level + 1; return is_string( $self->title, $str, $desc ); } =head2 $mech->title_like( $regex [, $desc ] ) Tells if the title of the page matches the given regex. $mech->title_like( qr/Invoices for (.+)/ ); =cut sub title_like { my $self = shift; my $regex = shift; my $desc = shift; $desc = qq{Title is like "$regex"} if !defined($desc); local $Test::Builder::Level = $Test::Builder::Level + 1; return like_string( $self->title, $regex, $desc ); } =head2 $mech->title_unlike( $regex [, $desc ] ) Tells if the title of the page matches the given regex. $mech->title_unlike( qr/Invoices for (.+)/ ); =cut sub title_unlike { my $self = shift; my $regex = shift; my $desc = shift; $desc = qq{Title is unlike "$regex"} if !defined($desc); local $Test::Builder::Level = $Test::Builder::Level + 1; return unlike_string( $self->title, $regex, $desc ); } =head2 $mech->base_is( $str [, $desc ] ) Tells if the base of the page is the given string. $mech->base_is( 'http://example.com/' ); =cut sub base_is { my $self = shift; my $str = shift; my $desc = shift; $desc = qq{Base is "$str"} if !defined($desc); local $Test::Builder::Level = $Test::Builder::Level + 1; return is_string( $self->base, $str, $desc ); } =head2 $mech->base_like( $regex [, $desc ] ) Tells if the base of the page matches the given regex. $mech->base_like( qr{http://example.com/index.php?PHPSESSID=(.+)}); =cut sub base_like { my $self = shift; my $regex = shift; my $desc = shift; $desc = qq{Base is like "$regex"} if !defined($desc); local $Test::Builder::Level = $Test::Builder::Level + 1; return like_string( $self->base, $regex, $desc ); } =head2 $mech->base_unlike( $regex [, $desc ] ) Tells if the base of the page matches the given regex. $mech->base_unlike( qr{http://example.com/index.php?PHPSESSID=(.+)}); =cut sub base_unlike { my $self = shift; my $regex = shift; my $desc = shift; $desc = qq{Base is unlike "$regex"} if !defined($desc); local $Test::Builder::Level = $Test::Builder::Level + 1; return unlike_string( $self->base, $regex, $desc ); } =head2 $mech->content_is( $str [, $desc ] ) Tells if the content of the page matches the given string =cut sub content_is { my $self = shift; my $str = shift; my $desc = shift; local $Test::Builder::Level = $Test::Builder::Level + 1; $desc = qq{Content is "$str"} if !defined($desc); return is_string( $self->content, $str, $desc ); } =head2 $mech->content_contains( $str [, $desc ] ) Tells if the content of the page contains I<$str>. =cut sub content_contains { my $self = shift; my $str = shift; my $desc = shift; local $Test::Builder::Level = $Test::Builder::Level + 1; if ( ref($str) ) { return $TB->ok( 0, 'Test::WWW::Mechanize->content_contains called incorrectly. It requires a scalar, not a reference.' ); } $desc = qq{Content contains "$str"} if !defined($desc); return contains_string( $self->content, $str, $desc ); } =head2 $mech->content_lacks( $str [, $desc ] ) Tells if the content of the page lacks I<$str>. =cut sub content_lacks { my $self = shift; my $str = shift; my $desc = shift; local $Test::Builder::Level = $Test::Builder::Level + 1; if ( ref($str) ) { return $TB->ok( 0, 'Test::WWW::Mechanize->content_lacks called incorrectly. It requires a scalar, not a reference.' ); } $desc = qq{Content lacks "$str"} if !defined($desc); return lacks_string( $self->content, $str, $desc ); } =head2 $mech->content_like( $regex [, $desc ] ) Tells if the content of the page matches I<$regex>. =cut sub content_like { my $self = shift; my $regex = shift; my $desc = shift; $desc = qq{Content is like "$regex"} if !defined($desc); local $Test::Builder::Level = $Test::Builder::Level + 1; return like_string( $self->content, $regex, $desc ); } =head2 $mech->content_unlike( $regex [, $desc ] ) Tells if the content of the page does NOT match I<$regex>. =cut sub content_unlike { my $self = shift; my $regex = shift; my $desc = shift || qq{Content is unlike "$regex"}; local $Test::Builder::Level = $Test::Builder::Level + 1; return unlike_string( $self->content, $regex, $desc ); } =head2 $mech->text_contains( $str [, $desc ] ) Tells if the text form of the page's content contains I<$str>. When your page contains HTML which is difficult, unimportant, or unlikely to match over time as designers alter markup, use C instead of C. # Hi, User! $mech->content_contains('Hi, User'); # Fails. $mech->text_contains('Hi, User'); # Passes. Text is determined by calling C<< $mech->text() >>. See L. =cut sub text_contains { my $self = shift; my $str = shift; my $desc = shift || qq{Text contains "$str"}; local $Test::Builder::Level = $Test::Builder::Level + 1; if ( ref($str) ) { return $TB->ok( 0, 'Test::WWW::Mechanize->text_contains called incorrectly. It requires a scalar, not a reference.' ); } return contains_string( $self->text, $str, $desc ); } =head2 $mech->text_lacks( $str [, $desc ] ) Tells if the text of the page lacks I<$str>. =cut sub text_lacks { my $self = shift; my $str = shift; my $desc = shift; local $Test::Builder::Level = $Test::Builder::Level + 1; if ( ref($str) ) { return $TB->ok( 0, 'Test::WWW::Mechanize->text_lacks called incorrectly. It requires a scalar, not a reference.' ); } $desc = qq{Text lacks "$str"} if !defined($desc); return lacks_string( $self->text, $str, $desc ); } =head2 $mech->text_like( $regex [, $desc ] ) Tells if the text form of the page's content matches I<$regex>. =cut sub text_like { my $self = shift; my $regex = shift; my $desc = shift || qq{Text is like "$regex"}; local $Test::Builder::Level = $Test::Builder::Level + 1; return like_string( $self->text, $regex, $desc ); } =head2 $mech->text_unlike( $regex [, $desc ] ) Tells if the text format of the page's content does NOT match I<$regex>. =cut sub text_unlike { my $self = shift; my $regex = shift; my $desc = shift || qq{Text is unlike "$regex"}; local $Test::Builder::Level = $Test::Builder::Level + 1; return unlike_string( $self->text, $regex, $desc ); } =head2 $mech->has_tag( $tag, $text [, $desc ] ) Tells if the page has a C<$tag> tag with the given content in its text. =cut sub has_tag { my $self = shift; my $tag = shift; my $text = shift; my $desc = shift || qq{Page has $tag tag with "$text"}; my $found = $self->_tag_walk( $tag, sub { $text eq $_[0] } ); return $TB->ok( $found, $desc ); } =head2 $mech->has_tag_like( $tag, $regex [, $desc ] ) Tells if the page has a C<$tag> tag with the given content in its text. =cut sub has_tag_like { my $self = shift; my $tag = shift; my $regex = shift; my $desc = shift; $desc = qq{Page has $tag tag like "$regex"} if !defined($desc); my $found = $self->_tag_walk( $tag, sub { $_[0] =~ $regex } ); return $TB->ok( $found, $desc ); } sub _tag_walk { my $self = shift; my $tag = shift; my $match = shift; my $p = HTML::TokeParser->new( \($self->content) ); while ( my $token = $p->get_tag( $tag ) ) { my $tagtext = $p->get_trimmed_text(); return 1 if $match->( $tagtext ); } return; } =head2 $mech->page_links_ok( [ $desc ] ) Follow all links on the current page and test for HTTP status 200 $mech->page_links_ok('Check all links'); =cut sub page_links_ok { my $self = shift; my $desc = shift; $desc = 'All links ok' unless defined $desc; my @links = $self->followable_links(); my @urls = _format_links(\@links); my @failures = $self->_check_links_status( \@urls ); my $ok = (@failures==0); $TB->ok( $ok, $desc ); $TB->diag( $_ ) for @failures; return $ok; } =head2 $mech->page_links_content_like( $regex [, $desc ] ) Follow all links on the current page and test their contents for I<$regex>. $mech->page_links_content_like( qr/foo/, 'Check all links contain "foo"' ); =cut sub page_links_content_like { my $self = shift; my $regex = shift; my $desc = shift; $desc = qq{All links are like "$regex"} unless defined $desc; my $usable_regex=$TB->maybe_regex( $regex ); if ( !defined( $usable_regex ) ) { my $ok = $TB->ok( 0, 'page_links_content_like' ); $TB->diag(qq{ "$regex" doesn't look much like a regex to me.}); return $ok; } my @links = $self->followable_links(); my @urls = _format_links(\@links); my @failures = $self->_check_links_content( \@urls, $regex ); my $ok = (@failures==0); $TB->ok( $ok, $desc ); $TB->diag( $_ ) for @failures; return $ok; } =head2 $mech->page_links_content_unlike( $regex [, $desc ] ) Follow all links on the current page and test their contents do not contain the specified regex. $mech->page_links_content_unlike(qr/Restricted/, 'Check all links do not contain Restricted'); =cut sub page_links_content_unlike { my $self = shift; my $regex = shift; my $desc = shift; $desc = qq{All links are unlike "$regex"} unless defined($desc); my $usable_regex=$TB->maybe_regex( $regex ); if ( !defined( $usable_regex ) ) { my $ok = $TB->ok( 0, 'page_links_content_unlike' ); $TB->diag(qq{ "$regex" doesn't look much like a regex to me.}); return $ok; } my @links = $self->followable_links(); my @urls = _format_links(\@links); my @failures = $self->_check_links_content( \@urls, $regex, 'unlike' ); my $ok = (@failures==0); $TB->ok( $ok, $desc ); $TB->diag( $_ ) for @failures; return $ok; } =head2 $mech->links_ok( $links [, $desc ] ) Follow specified links on the current page and test for HTTP status 200. The links may be specified as a reference to an array containing L objects, an array of URLs, or a scalar URL name. my @links = $mech->find_all_links( url_regex => qr/cnn\.com$/ ); $mech->links_ok( \@links, 'Check all links for cnn.com' ); my @links = qw( index.html search.html about.html ); $mech->links_ok( \@links, 'Check main links' ); $mech->links_ok( 'index.html', 'Check link to index' ); =cut sub links_ok { my $self = shift; my $links = shift; my $desc = shift; my @urls = _format_links( $links ); $desc = _default_links_desc(\@urls, 'are ok') unless defined $desc; my @failures = $self->_check_links_status( \@urls ); my $ok = (@failures == 0); $TB->ok( $ok, $desc ); $TB->diag( $_ ) for @failures; return $ok; } =head2 $mech->link_status_is( $links, $status [, $desc ] ) Follow specified links on the current page and test for HTTP status passed. The links may be specified as a reference to an array containing L objects, an array of URLs, or a scalar URL name. my @links = $mech->followable_links(); $mech->link_status_is( \@links, 403, 'Check all links are restricted' ); =cut sub link_status_is { my $self = shift; my $links = shift; my $status = shift; my $desc = shift; my @urls = _format_links( $links ); $desc = _default_links_desc(\@urls, "have status $status") if !defined($desc); my @failures = $self->_check_links_status( \@urls, $status ); my $ok = (@failures == 0); $TB->ok( $ok, $desc ); $TB->diag( $_ ) for @failures; return $ok; } =head2 $mech->link_status_isnt( $links, $status [, $desc ] ) Follow specified links on the current page and test for HTTP status passed. The links may be specified as a reference to an array containing L objects, an array of URLs, or a scalar URL name. my @links = $mech->followable_links(); $mech->link_status_isnt( \@links, 404, 'Check all links are not 404' ); =cut sub link_status_isnt { my $self = shift; my $links = shift; my $status = shift; my $desc = shift; my @urls = _format_links( $links ); $desc = _default_links_desc(\@urls, "do not have status $status") if !defined($desc); my @failures = $self->_check_links_status( \@urls, $status, 'isnt' ); my $ok = (@failures == 0); $TB->ok( $ok, $desc ); $TB->diag( $_ ) for @failures; return $ok; } =head2 $mech->link_content_like( $links, $regex [, $desc ] ) Follow specified links on the current page and test the resulting content of each against I<$regex>. The links may be specified as a reference to an array containing L objects, an array of URLs, or a scalar URL name. my @links = $mech->followable_links(); $mech->link_content_like( \@links, qr/Restricted/, 'Check all links are restricted' ); =cut sub link_content_like { my $self = shift; my $links = shift; my $regex = shift; my $desc = shift; my $usable_regex=$TB->maybe_regex( $regex ); if ( !defined( $usable_regex ) ) { my $ok = $TB->ok( 0, 'link_content_like' ); $TB->diag(qq{ "$regex" doesn't look much like a regex to me.}); return $ok; } my @urls = _format_links( $links ); $desc = _default_links_desc( \@urls, qq{are like "$regex"} ) if !defined($desc); my @failures = $self->_check_links_content( \@urls, $regex ); my $ok = (@failures == 0); $TB->ok( $ok, $desc ); $TB->diag( $_ ) for @failures; return $ok; } =head2 $mech->link_content_unlike( $links, $regex [, $desc ] ) Follow specified links on the current page and test that the resulting content of each does not match I<$regex>. The links may be specified as a reference to an array containing L objects, an array of URLs, or a scalar URL name. my @links = $mech->followable_links(); $mech->link_content_unlike( \@links, qr/Restricted/, 'No restricted links' ); =cut sub link_content_unlike { my $self = shift; my $links = shift; my $regex = shift; my $desc = shift; my $usable_regex=$TB->maybe_regex( $regex ); if ( !defined( $usable_regex ) ) { my $ok = $TB->ok( 0, 'link_content_unlike' ); $TB->diag(qq{ "$regex" doesn't look much like a regex to me.}); return $ok; } my @urls = _format_links( $links ); $desc = _default_links_desc( \@urls, qq{are not like "$regex"} ) if !defined($desc); my @failures = $self->_check_links_content( \@urls, $regex, 'unlike' ); my $ok = (@failures == 0); $TB->ok( $ok, $desc ); $TB->diag( $_ ) for @failures; return $ok; } # Create a default description for the link_* methods, including the link count. sub _default_links_desc { my ($urls, $desc_suffix) = @_; my $url_count = scalar(@{$urls}); return sprintf( '%d link%s %s', $url_count, $url_count == 1 ? '' : 's', $desc_suffix ); } # This actually performs the status check of each URL. sub _check_links_status { my $self = shift; my $urls = shift; my $status = shift || 200; my $test = shift || 'is'; # Create a clone of the $mech used during the test as to not disrupt # the original. my $mech = $self->clone(); my @failures; for my $url ( @{$urls} ) { if ( $mech->follow_link( url => $url ) ) { if ( $test eq 'is' ) { push( @failures, $url ) unless $mech->status() == $status; } else { push( @failures, $url ) if $mech->status() == $status; } $mech->back(); } else { push( @failures, $url ); } } # for return @failures; } # This actually performs the content check of each URL. sub _check_links_content { my $self = shift; my $urls = shift; my $regex = shift || qr//; my $test = shift || 'like'; # Create a clone of the $mech used during the test as to not disrupt # the original. my $mech = $self->clone(); my @failures; for my $url ( @{$urls} ) { if ( $mech->follow_link( url => $url ) ) { my $content=$mech->content(); if ( $test eq 'like' ) { push( @failures, $url ) unless $content =~ /$regex/; } else { push( @failures, $url ) if $content =~ /$regex/; } $mech->back(); } else { push( @failures, $url ); } } # for return @failures; } # Return a list of URLs to match for Mech to follow. sub _format_links { my $links = shift; my @urls; if (ref($links) eq 'ARRAY') { my $link = $links->[0]; if ( defined($link) ) { if ( ref($link) eq 'WWW::Mechanize::Link' ) { @urls = map { $_->url() } @{$links}; } else { @urls = @{$links}; } } } else { push(@urls,$links); } return @urls; } =head1 METHODS: SCRAPING =head2 $mech->scrape_text_by_attr( $attr, $attr_value [, $html ] ) =head2 $mech->scrape_text_by_attr( $attr, $attr_regex [, $html ] ) Returns a list of strings, each string the text surrounded by an element with attribute I<$attr> of value I<$value>. You can also pass in a regular expression. If nothing is found the return is an empty list. In scalar context the return is the first string found. If passed, I<$html> is scraped instead of the current page's content. =cut sub scrape_text_by_attr { my $self = shift; my $attr = shift; my $value = shift; my $html = $self->_get_optional_html( @_ ); my @results; if ( defined $html ) { my $parser = HTML::TokeParser->new(\$html); while ( my $token = $parser->get_tag() ) { if ( ref $token->[1] eq 'HASH' ) { if ( exists $token->[1]->{$attr} ) { my $matched = (ref $value eq 'Regexp') ? $token->[1]->{$attr} =~ $value : $token->[1]->{$attr} eq $value; if ( $matched ) { my $tag = $token->[ 0 ]; push @results, $parser->get_trimmed_text( "/$tag" ); if ( !wantarray ) { last; } } } } } } return $results[0] if !wantarray; return @results; } =head2 $mech->scrape_text_by_id( $id [, $html ] ) Finds all elements with the given ID attribute and pulls out the text that that element encloses. In list context, returns a list of all strings found. In scalar context, returns the first one found. If C<$html> is not provided then the current content is used. =cut sub scrape_text_by_id { my $self = shift; my $id = shift; my $html = $self->_get_optional_html( @_ ); my @results; if ( defined $html ) { # If the ID doesn't appear anywhere in the text, then there's no point in parsing. my $found = index( $html, $id ); if ( $found >= 0 ) { my $parser = HTML::TokeParser->new( \$html ); while ( my $token = $parser->get_tag() ) { if ( ref $token->[1] eq 'HASH' ) { my $actual_id = $token->[1]->{id}; $actual_id = '' unless defined $actual_id; if ( $actual_id eq $id ) { my $tag = $token->[ 0 ]; push @results, $parser->get_trimmed_text( "/$tag" ); if ( !wantarray ) { last; } } } } } } return $results[0] if !wantarray; return @results; } sub _get_optional_html { my $self = shift; my $html; if ( @_ ) { $html = shift; assert_nonblank( $html, '$html passed in is a populated scalar' ); } else { if ( $self->is_html ) { $html = $self->content(); } } return $html; } =head2 $mech->scraped_id_is( $id, $expected [, $msg] ) Scrapes the current page for given ID and tests that it matches the expected value. =cut sub scraped_id_is { my $self = shift; my $id = shift; my $expected = shift; my $msg = shift; my $ok; my $got = $self->scrape_text_by_id( $id ); if ( defined( $got ) ) { $ok = $TB->is_eq( $got, $expected, $msg ); } else { $ok = $TB->ok( 0, $msg ); $TB->diag( qq{Can't find ID "$id" to compare to "$expected"} ); } return $ok; } =head2 $mech->scraped_id_like( $id, $expected_regex [, $msg] ) Scrapes the current page for given id and tests that it matches the expected regex. =cut sub scraped_id_like { my $self = shift; my $id = shift; my $expected = shift; my $msg = shift; my $ok; my $got = $self->scrape_text_by_id( $id ); if ( defined($got) ) { $ok = $TB->like( $got, $expected, $msg ); } else { $ok = $TB->ok( 0, $msg ); $TB->diag( qq{Can't find ID "$id" to match against $expected} ); } return $ok; } =head2 $mech->id_exists( $id ) Returns TRUE/FALSE if the given ID exists in the given HTML, or if none is provided, then the current page. The Mech object caches the IDs so that it doesn't bother reparsing every time it's asked about an ID. =cut sub id_exists { my $self = shift; my $id = shift; assert_is( $self->ct, 'text/html', 'Can only call id_exists on HTML pages' ); if ( !$self->{ids} ) { my $ids = $self->{ids} = {}; my $p = HTML::Parser->new( handlers => { start => [ sub { my $attr = shift; if ( my $id = $attr->{id} ) { $ids->{$id} = 1; } }, 'attr' ], }, ); $p->parse( $self->content ); $p->eof; } return $self->{ids}->{$id}; } =head2 $agent->id_exists_ok( $id [, $msg] ) Verifies there is an HTML element with ID C<$id> in the page. =cut sub id_exists_ok { local $Test::Builder::Level = $Test::Builder::Level + 1; my $self = shift; my $id = shift; my $msg = shift || ('ID "' . ($id || '') . '" should exist'); my $exists = $self->id_exists( $id ); return $TB->ok( $exists, $msg ); } =head2 $agent->ids_exist_ok( \@ids [, $msg] ) Verifies an HTML element exists with each ID in C<\@ids>. =cut sub ids_exist_ok { local $Test::Builder::Level = $Test::Builder::Level + 1; my $self = shift; my $ids = shift; my $msg = shift; assert_arrayref( $ids ); my $subtest_name = 'ids_exist_ok( [' . join( ', ', @{$ids} ) . ']'; $subtest_name .= ", $msg" if defined $msg; $subtest_name .= ' )'; return $TB->subtest( $subtest_name, sub { $TB->plan( tests => scalar @{$ids} ); foreach my $id ( @$ids ) { $self->id_exists_ok( $id ); } } ); } =head2 $agent->lacks_id_ok( $id [, $msg] ) Verifies there is NOT an HTML element with ID C<$id> in the page. =cut sub lacks_id_ok { local $Test::Builder::Level = $Test::Builder::Level + 1; my $self = shift; my $id = shift; my $msg = shift || ('ID "' . ($id || '') . '" should not exist'); assert_nonblank( $id ); my $exists = $self->id_exists( $id ); return $TB->ok( !$exists, $msg ); } =head2 $agent->lacks_ids_ok( \@ids [, $msg] ) Verifies there are no HTML elements with any of the ids given in C<\@ids>. =cut sub lacks_ids_ok { local $Test::Builder::Level = $Test::Builder::Level + 1; my $self = shift; my $ids = shift; my $msg = shift; assert_arrayref( $ids ); my $subtest_name = 'lacks_ids_ok( [' . join( ', ', @{$ids} ) . ']'; $subtest_name .= ", $msg" if defined $msg; $subtest_name .= ' )'; return $TB->subtest( $subtest_name, sub { $TB->plan( tests => scalar @{$ids} ); foreach my $id ( @$ids ) { my $id_disp = defined($id) ? $id : ''; $self->lacks_id_ok( $id, "ID '$id_disp' should not exist" ); } } ); } =head2 $mech->button_exists( $button ) Returns a boolean saying whether a submit button with the name C<$button> exists. Does not do a test. For that you want C or C. =cut sub button_exists { my $self = shift; my $button = shift; my $input = $self->grep_inputs( { type => qr/^submit$/, name => qr/^$button$/ } ); return !!$input; } =head2 $mech->button_exists_ok( $button [, $msg] ) Asserts that the button exists on the page. =cut sub button_exists_ok { local $Test::Builder::Level = $Test::Builder::Level + 1; my $self = shift; my $button = shift; my $msg = shift || qq{Button named "$button" exists}; return $TB->ok( $self->button_exists( $button ), $msg ); } =head2 $mech->lacks_button_ok( $button [, $msg] ) Asserts that no button named C<$button> exists on the page. =cut sub lacks_button_ok { local $Test::Builder::Level = $Test::Builder::Level + 1; my $self = shift; my $button = shift; my $msg = shift || qq{No button named "$button" exists}; return $TB->ok( !$self->button_exists( $button ), $msg ); } =head1 METHODS: MISCELLANEOUS =head2 $mech->autolint( [$status] ) Without an argument, this method returns a true or false value indicating whether autolint is active. When passed an argument, autolint is turned on or off depending on whether the argument is true or false, and the previous autolint status is returned. As with the autolint option of C<< new >>, C<< $status >> can be an L<< HTML::Lint >> object. If autolint is currently using an L<< HTML::Lint >> object you provided, the return is that object, so you can change and exactly restore autolint status: my $old_status = $mech->autolint( 0 ); ... operations that should not be linted ... $mech->autolint( $old_status ); =cut sub autolint { my $self = shift; my $ret = $self->{autolint}; if ( @_ ) { $self->{autolint} = shift; } return $ret; } =head2 $mech->autotidy( [$status] ) Without an argument, this method returns a true or false value indicating whether autotidy is active. When passed an argument, autotidy is turned on or off depending on whether the argument is true or false, and the previous autotidy status is returned. As with the autotidy option of C<< new >>, C<< $status >> can be an L<< HTML::Tidy5 >> object. If autotidy is currently using an L<< HTML::Tidy5 >> object you provided, the return is that object, so you can change and exactly restore autotidy status: my $old_status = $mech->autotidy( 0 ); ... operations that should not be tidied ... $mech->autotidy( $old_status ); =cut sub autotidy { my $self = shift; my $ret = $self->{autotidy}; if ( @_ ) { $self->{autotidy} = shift; } return $ret; } =head2 $mech->grep_inputs( \%properties ) Returns a list of all the input controls in the current form whose properties match all of the regexes in C<$properties>. The controls returned are all descended from HTML::Form::Input. If C<$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 list. # 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 a list 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 $pattern_key ( keys %{$patterns} ) { $matches_everything = 0 unless exists $hash->{$pattern_key} && $hash->{$pattern_key} =~ $patterns->{$pattern_key}; last if !$matches_everything; } push @found, $hash if $matches_everything; } } return @found; } =head2 $mech->stuff_inputs( [\%options] ) Finds all free-text input fields (text, textarea, and password) in the current form and fills them to their maximum length in hopes of finding application code that can't handle it. Fields with no maximum length and all textarea fields are set to 66000 bytes, which will often be enough to overflow the data's eventual receptacle. There is no return value. If there is no current form then nothing is done. The hashref $options can contain the following keys: =over =item * ignore hash value is arrayref of field names to not touch, e.g.: $mech->stuff_inputs( { ignore => [qw( specialfield1 specialfield2 )], } ); =item * fill hash value is default string to use when stuffing fields. Copies of the string are repeated up to the max length of each field. E.g.: $mech->stuff_inputs( { fill => '@' # stuff all fields with something easy to recognize } ); =item * specs hash value is arrayref of hashrefs with which you can pass detailed instructions about how to stuff a given field. E.g.: $mech->stuff_inputs( { specs=>{ # Some fields are datatype-constrained. It's most common to # want the field stuffed with valid data. widget_quantity => { fill=>'9' }, notes => { maxlength=>2000 }, } } ); The specs allowed are I (use this fill for the field rather than the default) and I (use this as the field's maxlength instead of any maxlength specified in the HTML). =back =cut sub stuff_inputs { my $self = shift; my $options = shift || {}; assert_isa( $options, 'HASH' ); assert_in( $_, ['ignore', 'fill', 'specs'] ) foreach ( keys %{$options} ); # Set up the fill we'll use unless a field overrides it. my $default_fill = '@'; if ( defined $options->{fill} && length($options->{fill}) > 0 ) { $default_fill = $options->{fill}; } # Fields in the form to not stuff my $ignore = {}; if ( exists $options->{ignore} ) { assert_isa( $options->{ignore}, 'ARRAY' ); $ignore = { map {($_, 1)} @{$options->{ignore}} }; } my $specs = {}; if ( exists $options->{specs} ) { assert_isa( $options->{specs}, 'HASH' ); $specs = $options->{specs}; foreach my $field_name ( keys %{$specs} ) { assert_isa( $specs->{$field_name}, 'HASH' ); assert_in( $_, ['fill', 'maxlength'] ) foreach ( keys %{$specs->{$field_name}} ); } } my @inputs = $self->find_all_inputs( type_regex => qr/^(text|textarea|password)$/ ); foreach my $field ( @inputs ) { next if $field->readonly(); next if $field->disabled(); # TODO: HTML::Form::TextInput allows setting disabled--allow it here? my $name = $field->name(); # Skip if it's one of the fields to ignore. next if exists $ignore->{ $name }; # Fields with no maxlength will get this many characters. my $maxlength = 66000; # maxlength from the HTML if ( $field->type ne 'textarea' ) { if ( exists $field->{maxlength} ) { $maxlength = $field->{maxlength}; # TODO: what to do about maxlength==0 ? non-numeric? less than 0 ? } } my $fill = $default_fill; if ( exists $specs->{$name} ) { # Process the per-field info. if ( exists $specs->{$name}->{fill} && defined $specs->{$name}->{fill} && length($specs->{$name}->{fill}) > 0 ) { $fill = $specs->{$name}->{fill}; } # maxlength override from specs if ( exists $specs->{$name}->{maxlength} && defined $specs->{$name}->{maxlength} ) { $maxlength = $specs->{$name}->{maxlength}; # TODO: what to do about maxlength==0 ? non-numeric? less than 0? } } # stuff it if ( ($maxlength % length($fill)) == 0 ) { $field->value( $fill x ($maxlength/length($fill)) ); } else { $field->value( substr( $fill x int(($maxlength + length($fill) - 1)/length($fill)), 0, $maxlength ) ); } } # for @inputs return; } =head2 $mech->followable_links() Returns a list of links that Mech can follow. This is only http and https links. =cut sub followable_links { my $self = shift; return $self->find_all_links( url_abs_regex => qr{^(?:https?|file)://} ); } =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. Checks that all text input fields in the current form 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 return is true if the test succeeded, false otherwise. =cut sub lacks_uncapped_inputs { my $self = shift; my $comment = shift; $comment = 'All text inputs should have maxlength attributes' unless defined($comment); 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 = $TB->ok( @uncapped == 0, $comment ); $TB->diag( $_ ) for @uncapped; return $ok; } =head2 $mech->check_all_images_ok( [%criterium ], [$comment] ) Executes a test to make sure all images in the page can be downloaded. It does this by running C requests on them. The current page content stays the same. The test fails if any image cannot be found, but reports all of the ones that were not found. For a definition of I, see L<< Cin WWW::Mechanize|WWW::Mechanize/$mech->images >>. The optional C<%criterium> argument can be passed in before the C<$comment> and will be used to define which images should be considered. This is useful to filter out specific paths. $mech->check_all_images_ok( url_regex => qr{^/}, 'All absolute images should exist'); $mech->check_all_images_ok( url_regex => qr{\.(?:gif|jpg)$}, 'All gif and jpg images should exist'); $mech->check_all_images_ok( url_regex => qr{^((?!\Qhttps://googleads.g.doubleclick.net/\E).)*$}, 'All images should exist, but Ignore the ones from Doubleclick' ); For a full list of possible arguments see L<< Cin WWW::Mechanize|WWW::Mechanize/$mech->find_all_images >>. The return is true if the test succeeded, false otherwise. =cut sub check_all_images_ok { my $self = shift; my @args = @_; my $comment; if ( @args % 2 ) { $comment = pop @args; } $comment = 'All images in the page should exist' unless defined($comment); require HTTP::Request::Common; my @not_ok; foreach my $img ( map { $_->URI } $self->find_all_images(@args) ) { my $abs = $img->abs; state $head_cache; # Cache images we've already checked between calls. if ( !$head_cache->{$abs}++ ) { # WWW::Mechanize->_make_request makes a raw LWP::UserAgent request that does # not show up in our history and does not mess with our current content. my $res = $self->_make_request( HTTP::Request::Common::HEAD($abs) ); if ( not $res->is_success ) { push( @not_ok, $img . ' returned code ' . $res->code ); } } } my $ok = $TB->ok( @not_ok == 0, $comment ); $TB->diag($_) for @not_ok; return $ok; } sub _diag_url { my $self = shift; my $uri = $self->uri; return $uri ? $uri->as_string : 'Unable to determine URL'; } =head1 TODO Other ideas for features are at https://github.com/petdance/test-www-mechanize =head1 AUTHOR Andy Lester, C<< >> =head1 BUGS Please report any bugs or feature requests to . =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::WWW::Mechanize You can also look for information at: =over 4 =item * Bug tracker L =item * CPAN Ratings L =item * Search CPAN L =back =head1 ACKNOWLEDGEMENTS Thanks to Julien Fiegehenn, @marderh, Eric A. Zarko, @moznion, Robert Stone, @tynovsky, Jerry Gay, Jonathan "Duke" Leto, Philip G. Potter, Niko Tyni, Greg Sheard, Michael Schwern, Mark Blackman, Mike O'Regan, Shawn Sorichetti, Chris Dolan, Matt Trout, MATSUNO Tokuhiro, and Pete Krawczyk for patches. =head1 COPYRIGHT & LICENSE Copyright 2004-2022 Andy Lester. This library is free software; you can redistribute it and/or modify it under the terms of the Artistic License version 2.0. =cut 1; # End of Test::WWW::Mechanize Test-WWW-Mechanize-1.60/META.yml0000644000175000017500000000214414343270553014672 0ustar andyandy--- abstract: 'Testing-specific WWW::Mechanize subclass' author: - 'Andy Lester ' build_requires: ExtUtils::MakeMaker: '0' HTTP::Server::Simple: '0.42' HTTP::Server::Simple::CGI: '0' Test::Builder::Tester: '1.09' Test::More: '0.96' URI::file: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.64, CPAN::Meta::Converter version 2.143240' license: artistic_2 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Test-WWW-Mechanize no_index: directory: - t - inc requires: Carp: '0' Carp::Assert::More: '1.16' HTML::Form: '0' HTML::TokeParser: '0' HTTP::Message: '6.29' LWP: '6.02' Test::Builder: '0' Test::LongString: '0.15' WWW::Mechanize: '1.68' parent: '0' perl: '5.010' resources: bugtracker: https://github.com/petdance/test-www-mechanize/issues homepage: https://github.com/petdance/test-www-mechanize license: https://opensource.org/licenses/artistic-license-2.0 repository: https://github.com/petdance/test-www-mechanize version: '1.60' Test-WWW-Mechanize-1.60/META.json0000644000175000017500000000355014343270553015044 0ustar andyandy{ "abstract" : "Testing-specific WWW::Mechanize subclass", "author" : [ "Andy Lester " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.64, CPAN::Meta::Converter version 2.143240", "license" : [ "artistic_2" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Test-WWW-Mechanize", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Carp" : "0", "Carp::Assert::More" : "1.16", "HTML::Form" : "0", "HTML::TokeParser" : "0", "HTTP::Message" : "6.29", "LWP" : "6.02", "Test::Builder" : "0", "Test::LongString" : "0.15", "WWW::Mechanize" : "1.68", "parent" : "0", "perl" : "5.010" } }, "test" : { "requires" : { "HTTP::Server::Simple" : "0.42", "HTTP::Server::Simple::CGI" : "0", "Test::Builder::Tester" : "1.09", "Test::More" : "0.96", "URI::file" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/petdance/test-www-mechanize/issues" }, "homepage" : "https://github.com/petdance/test-www-mechanize", "license" : [ "https://opensource.org/licenses/artistic-license-2.0" ], "repository" : { "url" : "https://github.com/petdance/test-www-mechanize" } }, "version" : "1.60" }