Test-WWW-Mechanize-1.42/000755 000765 000024 00000000000 11761716752 015561 5ustar00alesterstaff000000 000000 Test-WWW-Mechanize-1.42/Changes000644 000765 000024 00000023643 11761716734 017064 0ustar00alesterstaff000000 000000 Revision 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 Google Code at http://code.google.com/p/www-mechanize/issues/list 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.42/Makefile.PL000644 000765 000024 00000004030 11761716534 017526 0ustar00alesterstaff000000 000000 use 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::Assert::More' => 0, 'HTML::TreeBuilder' => 0, 'HTTP::Server::Simple' => '0.42', 'HTTP::Server::Simple::CGI' => 0, 'LWP' => 6.02, 'Test::Builder::Tester' => '1.09', 'Test::LongString' => '0.15', 'Test::More' => '0.96', # subtest() and done_testing() 'URI::file' => 0, 'WWW::Mechanize' => '1.68', }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Test-WWW-Mechanize-*' }, }; if ( $ExtUtils::MakeMaker::VERSION =~ /^\d\.\d\d$/ and $ExtUtils::MakeMaker::VERSION > 6.30 ) { $parms->{LICENSE} = 'artistic_2'; } if ( $ExtUtils::MakeMaker::VERSION ge '6.46' ) { $parms->{META_MERGE} = { resources => { license => 'http://www.opensource.org/licenses/artistic-license-2.0', homepage => 'https://github.com/petdance/test-www-mechanize', bugtracker => 'http://code.google.com/p/www-mechanize/issues/list', repository => 'https://github.com/petdance/test-www-mechanize', } }; } if ( $ExtUtils::MakeMaker::VERSION ge '6.48' ) { $parms->{MIN_PERL_VERSION} = 5.008; } 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.42/MANIFEST000644 000765 000024 00000001617 11761716752 016717 0ustar00alesterstaff000000 000000 Changes MANIFEST Makefile.PL Mechanize.pm README.md t/00-load.t t/autolint.t t/bad.html t/badlinks.html t/click_ok.t t/content_contains.t t/content_lacks.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/html/form.html t/html_lint_ok.t t/html/scratch.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/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.42/Mechanize.pm000644 000765 000024 00000125437 11761716655 020040 0ustar00alesterstaff000000 000000 package Test::WWW::Mechanize; use strict; use warnings; =head1 NAME Test::WWW::Mechanize - Testing-specific WWW::Mechanize subclass =head1 VERSION Version 1.42 =cut our $VERSION = '1.42'; =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 WWW::Mechanize (); use Test::LongString; use Test::Builder (); use Carp (); use Carp::Assert::More; use base '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 ); =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 on the fly with the C<< autolint >> method. =cut sub new { my $class = shift; my %args = ( agent => "Test-WWW-Mechanize/$VERSION", @_ ); my $autolint = delete $args{autolint}; my $self = $class->SUPER::new( %args ); $self->autolint( $autolint ); return $self; } =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', @_ ); $self->get( $url, %opts ); my $ok = $self->success; $ok = $self->_maybe_lint( $ok, $desc ); return $ok; } sub _maybe_lint { my $self = shift; my $ok = shift; my $desc = shift; local $Test::Builder::Level = $Test::Builder::Level + 1; if ( $ok ) { if ( $self->is_html && $self->autolint ) { $ok = $self->_lint_content_ok( $desc ); } else { $TB->ok( $ok, $desc ); } } else { $TB->ok( $ok, $desc ); $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', @_ ); $self->head( $url, %opts ); my $ok = $self->success; $TB->ok( $ok, $desc ); if ( !$ok ) { $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. 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', @_ ); $self->post( $url, \%opts ); my $ok = $self->success; $ok = $self->_maybe_lint( $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', @_ ); $opts{content} = '' if !exists $opts{content}; $self->put( $url, %opts ); my $ok = $self->success; $TB->ok( $ok, $desc ); if ( !$ok ) { $TB->diag( $self->status ); $TB->diag( $self->response->message ) if $self->response; } return $ok; } =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->_maybe_lint( $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'; } # return from follow_link() is an HTTP::Response or undef my $response = $self->follow_link( %{$parms} ); my $ok = $response && $response->is_success; $ok = $self->_maybe_lint( $ok, $desc ); return $ok; } =head2 click_ok( $button[, $desc] ) Clicks the button named by C<$button>. An optional C<$desc> can be given for the test. =cut sub click_ok { my $self = shift; my $button = shift; my $desc = shift; my $response = $self->click( $button ); if ( !$response ) { return $TB->ok( 0, $desc ); } my $ok = $response->is_success; $ok = $self->_maybe_lint( $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: CONTENT CHECKING =head2 $mech->html_lint_ok( [$desc] ) Checks the validity of the HTML on the current page. 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 { my $self = shift; my $desc = shift; local $Test::Builder::Level = $Test::Builder::Level + 1; 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 ); 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->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 L. # 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->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->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; } # Create an array 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; } =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 recepticle. 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 ( exists $options->{fill} && 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 ) { # the simple case $field->value( $fill x ($maxlength/length($fill)) ); } else { # can be improved later $field->value( substr( $fill x int(($maxlength + length($fill) - 1)/length($fill)), 0, $maxlength ) ); } } # for @inputs return; } =head2 $mech->lacks_uncapped_inputs( [$comment] ) Executes a test to make sure that the current form content has no text input fields that lack the C attribute, and that each C value is a positive integer. The test fails if the current form has such a field, and succeeds otherwise. Returns an array containing all text input fields in the current form that do not specify a maximum input length. Fields for which the concept of input length is irrelevant, and controls that HTML does not allow to be capped (e.g. textarea) are ignored. The inputs in the returned array are descended from HTML::Form::Input. The return is true if the test succeeded, false otherwise. =cut sub lacks_uncapped_inputs { my $self = shift; my $comment = shift; local $Test::Builder::Level = $Test::Builder::Level + 1; my @uncapped; my @inputs = $self->grep_inputs( { type => qr/^(?:text|password)$/ } ); foreach my $field ( @inputs ) { next if $field->readonly(); next if $field->disabled(); if ( not defined($field->{maxlength}) ) { push( @uncapped, $field->name . ' has no maxlength attribute' ); next; } my $val = $field->{maxlength}; if ( ($val !~ /^\s*\d+\s*$/) || ($val+0 <= 0) ) { push( @uncapped, $field->name . qq{ has an invalid maxlength attribute of "$val"} ); } } my $ok = $TB->cmp_ok( scalar @uncapped, '==', 0, $comment ); $TB->diag( $_ ) for @uncapped; return $ok; } =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->grep_inputs( \%properties ) grep_inputs() returns an array of all the input controls in the current form whose properties match all of the regexes in $properties. The controls returned are all descended from HTML::Form::Input. If $properties is undef or empty then all inputs will be returned. If there is no current page, there is no form on the current page, or there are no submit controls in the current form then the return will be an empty array. # get all text controls whose names begin with "customer" my @customer_text_inputs = $mech->grep_inputs( { type => qr/^(text|textarea)$/, name => qr/^customer/ } ); =cut sub grep_inputs { my $self = shift; my $properties = shift; my @found; my $form = $self->current_form(); if ( $form ) { my @inputs = $form->inputs(); @found = _grep_hashes( \@inputs, $properties ); } return @found; } =head2 $mech->grep_submits( \%properties ) grep_submits() does the same thing as grep_inputs() except that it only returns controls that are submit controls, ignoring other types of input controls like text and checkboxes. =cut sub grep_submits { my $self = shift; my $properties = shift || {}; $properties->{type} = qr/^(?:submit|image)$/; # submits only my @found = $self->grep_inputs( $properties ); return @found; } # search an array of hashrefs, returning an array of the incoming # hashrefs that match *all* the pattern in $patterns. sub _grep_hashes { my $hashes = shift; my $patterns = shift || {}; my @found; if ( ! %{$patterns} ) { # nothing to match on, so return them all @found = @{$hashes}; } else { foreach my $hash ( @{$hashes} ) { # check every pattern for a match on the current hash my $matches_everything = 1; foreach my $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->scrape_text_by_attr( $attr, $attr_value [, $html ] ) =head2 $mech->scrape_text_by_attr( $attr, $attr_regex [, $html ] ) Returns an array 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 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 ) { my $found = index( $html, "id=\"$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; if ( not defined $msg ) { my $what = defined( $expected ) ? $expected : '(undef)'; $msg = qq{scraped id "$id" is "$what"}; } local $Test::Builder::Level = $Test::Builder::Level + 1; my $got = $self->scrape_text_by_id($id); is( $got, $expected, $msg ); return; } =head1 TODO Add HTML::Tidy capabilities. 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 * AnnoCPAN: Annotated CPAN documentation L =item * CPAN Ratings L =item * Search CPAN L =back =head1 ACKNOWLEDGEMENTS Thanks to 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-2012 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.42/META.json000644 000765 000024 00000003213 11761716752 017201 0ustar00alesterstaff000000 000000 { "abstract" : "Testing-specific WWW::Mechanize subclass", "author" : [ "Andy Lester " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.120530", "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::Assert::More" : "0", "HTML::TreeBuilder" : "0", "HTTP::Server::Simple" : "0.42", "HTTP::Server::Simple::CGI" : "0", "LWP" : "6.02", "Test::Builder::Tester" : "1.09", "Test::LongString" : "0.15", "Test::More" : "0.96", "URI::file" : "0", "WWW::Mechanize" : "1.68", "perl" : "5.008" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://code.google.com/p/www-mechanize/issues/list" }, "homepage" : "https://github.com/petdance/test-www-mechanize", "license" : [ "http://www.opensource.org/licenses/artistic-license-2.0" ], "repository" : { "url" : "https://github.com/petdance/test-www-mechanize" } }, "version" : "1.42" } Test-WWW-Mechanize-1.42/META.yml000644 000765 000024 00000001753 11761716752 017040 0ustar00alesterstaff000000 000000 --- abstract: 'Testing-specific WWW::Mechanize subclass' author: - 'Andy Lester ' build_requires: ExtUtils::MakeMaker: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.120530' 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::Assert::More: 0 HTML::TreeBuilder: 0 HTTP::Server::Simple: 0.42 HTTP::Server::Simple::CGI: 0 LWP: 6.02 Test::Builder::Tester: 1.09 Test::LongString: 0.15 Test::More: 0.96 URI::file: 0 WWW::Mechanize: 1.68 perl: 5.008 resources: bugtracker: http://code.google.com/p/www-mechanize/issues/list homepage: https://github.com/petdance/test-www-mechanize license: http://www.opensource.org/licenses/artistic-license-2.0 repository: https://github.com/petdance/test-www-mechanize version: 1.42 Test-WWW-Mechanize-1.42/README.md000644 000765 000024 00000002632 11761713456 017041 0ustar00alesterstaff000000 000000 # Test-WWW-Mechanize Test::WWW::Mechanize is a subclass of the Perl module WWW::Mechanize 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. # INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install # COPYRIGHT AND LICENSE Copyright (C) 2004-2012 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.42/t/000755 000765 000024 00000000000 11761716752 016024 5ustar00alesterstaff000000 000000 Test-WWW-Mechanize-1.42/t/00-load.t000644 000765 000024 00000000535 11742107053 017333 0ustar00alesterstaff000000 000000 #!perl -T use warnings; use strict; use Test::More tests => 1; use LWP; use WWW::Mechanize; use Test::WWW::Mechanize; pass( 'Modules loaded' ); diag( "Testing Test::WWW::Mechanize $Test::WWW::Mechanize::VERSION, with WWW::Mechanize $WWW::Mechanize::VERSION, LWP $LWP::VERSION, Test::More $Test::More::VERSION, Perl $], $^X" ); done_testing(); Test-WWW-Mechanize-1.42/t/autolint.t000644 000765 000024 00000011146 11761715616 020051 0ustar00alesterstaff000000 000000 #!/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.42/t/bad.html000644 000765 000024 00000000343 11741627105 017427 0ustar00alesterstaff000000 000000 Test Page Test Page Back to bad good Test Test-WWW-Mechanize-1.42/t/badlinks.html000644 000765 000024 00000000411 11741627105 020464 0ustar00alesterstaff000000 000000 Test Page Test Page good Test Test Test Test-WWW-Mechanize-1.42/t/click_ok.t000644 000765 000024 00000000775 11741645447 020000 0ustar00alesterstaff000000 000000 #!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: { 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' ); } $server->stop; done_testing(); Test-WWW-Mechanize-1.42/t/content_contains.t000644 000765 000024 00000002745 11741644255 021565 0ustar00alesterstaff000000 000000 #!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(+5); test_diag(q( searched: "\x{0a} \x{0a} 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.42/t/content_lacks.t000644 000765 000024 00000002012 11741644301 021017 0ustar00alesterstaff000000 000000 #!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(+4); test_diag(q( searched: "\x{0a} \x{0a} 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.42/t/fluffy.html000644 000765 000024 00000000517 11761713456 020206 0ustar00alesterstaff000000 000000 Test Page This page has valid structure, but contains errors that HTML::Lint categorizes as fluff. good Test Test-WWW-Mechanize-1.42/t/follow_link_ok.t000644 000765 000024 00000002140 11742057477 021217 0ustar00alesterstaff000000 000000 #!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' )->as_string; my $path = $uri; $path =~ s{file://}{}; $path =~ s{\Qbadlinks.html}{bad1.html}; $mech->get_ok( $uri ); test_out('not ok 1 - Go after bad link'); test_fail(+3); 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.42/t/followable_links.t000644 000765 000024 00000001271 11741645426 021535 0ustar00alesterstaff000000 000000 #!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.42/t/get_ok-parms.t000644 000765 000024 00000002270 11741644611 020572 0ustar00alesterstaff000000 000000 #!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.42/t/get_ok.t000644 000765 000024 00000002631 11743044307 017451 0ustar00alesterstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 10; 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')->as_string; (my $abs_path = $badurl) =~ s{^file://}{}; $mech->get($badurl); ok(!$mech->success, qq{sanity check: we can't load $badurl}); test_out( 'not ok 1 - Try to get bad URL' ); test_fail( +3 ); test_diag( '404' ); test_diag( qq{File `$abs_path' does not exist} ); my $ok = $mech->get_ok( $badurl, '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' ); } done_testing(); Test-WWW-Mechanize-1.42/t/good.html000644 000765 000024 00000000300 11741627105 017622 0ustar00alesterstaff000000 000000 Test Page Test Page good Test Test-WWW-Mechanize-1.42/t/goodlinks.html000644 000765 000024 00000000375 11741627105 020677 0ustar00alesterstaff000000 000000 Test Page

Test Page

Test 1 Test 2 Test 3 Test-WWW-Mechanize-1.42/t/has_tag.t000644 000765 000024 00000004602 11742103425 017603 0ustar00alesterstaff000000 000000 #!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.42/t/head_ok-parms.t000644 000765 000024 00000002372 11741645573 020727 0ustar00alesterstaff000000 000000 #!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.42/t/head_ok.t000644 000765 000024 00000003010 11743042330 017555 0ustar00alesterstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 11; use Test::Builder::Tester; use URI::file; require_ok( 'Test::WWW::Mechanize' ); 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')->as_string; ( my $abs_path = $badurl ) =~ s{^file://}{}; $mech->head($badurl); ok(!$mech->success, qq{sanity check: we can't load $badurl} ); test_out( 'not ok 1 - Try to HEAD bad URL' ); test_fail( +3 ); test_diag( '404' ); test_diag( qq{File `$abs_path' does not exist} ); my $ok = $mech->head_ok( $badurl, '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' ); } done_testing(); Test-WWW-Mechanize-1.42/t/html/000755 000765 000024 00000000000 11761716752 016770 5ustar00alesterstaff000000 000000 Test-WWW-Mechanize-1.42/t/html_lint_ok.t000644 000765 000024 00000001745 11741645717 020703 0ustar00alesterstaff000000 000000 #!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 if ( not eval 'use HTML::Lint;' ) { plan skip_all => 'HTML::Lint is not installed, cannot test autolint' 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(); Test-WWW-Mechanize-1.42/t/lacks_uncapped_inputs-bad.html000644 000765 000024 00000001236 11741627105 024005 0ustar00alesterstaff000000 000000 Title
Test-WWW-Mechanize-1.42/t/lacks_uncapped_inputs-good.html000644 000765 000024 00000000534 11741627105 024207 0ustar00alesterstaff000000 000000 Title
Test-WWW-Mechanize-1.42/t/lacks_uncapped_inputs.t000644 000765 000024 00000002137 11741645605 022566 0ustar00alesterstaff000000 000000 #!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{ got: 3} ); test_diag( q{ expected: 0} ); test_diag( q{foo has no maxlength attribute} ); test_diag( q{quux has an invalid maxlength attribute of "dogs"} ); test_diag( q{crunchy has an invalid maxlength attribute of "-1"} ); $mech->lacks_uncapped_inputs( 'This should have three errors found' ); test_test( 'Detect uncapped' ); } done_testing(); Test-WWW-Mechanize-1.42/t/link_content.t000644 000765 000024 00000004671 11741642576 020710 0ustar00alesterstaff000000 000000 #!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.42/t/link_status.t000644 000765 000024 00000002760 11741645723 020553 0ustar00alesterstaff000000 000000 #!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.42/t/links_ok.t000644 000765 000024 00000002332 11741642645 020017 0ustar00alesterstaff000000 000000 #!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.42/t/manylinks.html000644 000765 000024 00000001011 11741627105 020677 0ustar00alesterstaff000000 000000 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.42/t/new.t000644 000765 000024 00000001516 11742103425 016767 0ustar00alesterstaff000000 000000 #!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.42/t/page_links_content.t000644 000765 000024 00000004067 11741643741 022061 0ustar00alesterstaff000000 000000 #!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.42/t/page_links_ok.t000644 000765 000024 00000001726 11741643747 021025 0ustar00alesterstaff000000 000000 #!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.42/t/pod-coverage.t000644 000765 000024 00000000354 11741645504 020560 0ustar00alesterstaff000000 000000 #!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.42/t/pod.t000644 000765 000024 00000000273 11741645727 016776 0ustar00alesterstaff000000 000000 #!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.42/t/put_ok.t000644 000765 000024 00000002027 11741643775 017515 0ustar00alesterstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 7; 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 $mech = Test::WWW::Mechanize->new( autocheck => 0 ); isa_ok($mech,'Test::WWW::Mechanize'); my $text = 'This is what we are putting'; GOOD_PUT: { 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'); } $server->stop; done_testing(); Test-WWW-Mechanize-1.42/t/scrape-text-by-id.t000644 000765 000024 00000005126 11742057477 021457 0ustar00alesterstaff000000 000000 #!/usr/bin/perl -T use strict; use warnings; use Test::More tests => 1; use Test::Builder; 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' ); }; }; done_testing(); exit 0; Test-WWW-Mechanize-1.42/t/stuff_inputs.html000644 000765 000024 00000000127 11741627105 021432 0ustar00alesterstaff000000 000000 Title
Test-WWW-Mechanize-1.42/t/stuff_inputs.t000644 000765 000024 00000011164 11741644121 020731 0ustar00alesterstaff000000 000000 #!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.42/t/submit_form_ok.t000644 000765 000024 00000001010 11761713456 021216 0ustar00alesterstaff000000 000000 #!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: { 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.42/t/table.html000644 000765 000024 00000001316 11741627106 017772 0ustar00alesterstaff000000 000000 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.42/t/TestServer.pm000644 000765 000024 00000004513 11742103425 020455 0ustar00alesterstaff000000 000000 package TestServer; use warnings; use strict; use Test::More; use HTTP::Server::Simple::CGI; use base 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"; if ( -r $filename ) { if (my $response=do { local (@ARGV, $/) = $filename; <> }) { print "HTTP/1.0 200 OK\r\n"; print "Content-Type: text/html\r\nContent-Length: ", length($response), "\r\n\r\n", $response; return; } } else { print "HTTP/1.0 404 Not found\r\n"; print $cgi->header, $cgi->start_html('Not found'), $cgi->h1('Not found'), $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.42/t/text_contains.t000644 000765 000024 00000002206 11741644063 021064 0ustar00alesterstaff000000 000000 #!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.42/t/title_is.t000644 000765 000024 00000001313 11742121256 020007 0ustar00alesterstaff000000 000000 #!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.42/t/html/form.html000644 000765 000024 00000000470 11741627105 020611 0ustar00alesterstaff000000 000000 Test Page

Test Page

Test-WWW-Mechanize-1.42/t/html/scratch.html000644 000765 000024 00000000375 11741627105 021301 0ustar00alesterstaff000000 000000 Test Page

Test Page

Test 1 Test 2 Test 3