1package Test::WWW::Mechanize; 2 3use strict; 4use warnings; 5 6=head1 NAME 7 8Test::WWW::Mechanize - Testing-specific WWW::Mechanize subclass 9 10=head1 VERSION 11 12Version 1.54 13 14=cut 15 16our $VERSION = '1.54'; 17 18=head1 SYNOPSIS 19 20Test::WWW::Mechanize is a subclass of L<WWW::Mechanize> that incorporates 21features for web application testing. For example: 22 23 use Test::More tests => 5; 24 use Test::WWW::Mechanize; 25 26 my $mech = Test::WWW::Mechanize->new; 27 $mech->get_ok( $page ); 28 $mech->base_is( 'http://petdance.com/', 'Proper <BASE HREF>' ); 29 $mech->title_is( 'Invoice Status', "Make sure we're on the invoice page" ); 30 $mech->text_contains( 'Andy Lester', 'My name somewhere' ); 31 $mech->content_like( qr/(cpan|perl)\.org/, 'Link to perl.org or CPAN' ); 32 33This is equivalent to: 34 35 use Test::More tests => 5; 36 use WWW::Mechanize; 37 38 my $mech = WWW::Mechanize->new; 39 $mech->get( $page ); 40 ok( $mech->success ); 41 is( $mech->base, 'http://petdance.com', 'Proper <BASE HREF>' ); 42 is( $mech->title, 'Invoice Status', "Make sure we're on the invoice page" ); 43 ok( index( $mech->content( format => 'text' ), 'Andy Lester' ) >= 0, 'My name somewhere' ); 44 like( $mech->content, qr/(cpan|perl)\.org/, 'Link to perl.org or CPAN' ); 45 46but has nicer diagnostics if they fail. 47 48Default descriptions will be supplied for most methods if you omit them. e.g. 49 50 my $mech = Test::WWW::Mechanize->new; 51 $mech->get_ok( 'http://petdance.com/' ); 52 $mech->base_is( 'http://petdance.com/' ); 53 $mech->title_is( 'Invoice Status' ); 54 $mech->content_contains( 'Andy Lester' ); 55 $mech->content_like( qr/(cpan|perl)\.org/ ); 56 57results in 58 59 ok - Got 'http://petdance.com/' ok 60 ok - Base is 'http://petdance.com/' 61 ok - Title is 'Invoice Status' 62 ok - Text contains 'Andy Lester' 63 ok - Content is like '(?-xism:(cpan|perl)\.org)' 64 65=cut 66 67use HTML::TokeParser (); 68use WWW::Mechanize (); 69use Test::LongString; 70use Test::Builder (); 71use Carp (); 72use Carp::Assert::More; 73 74use parent 'WWW::Mechanize'; 75 76my $TB = Test::Builder->new(); 77 78 79=head1 CONSTRUCTOR 80 81=head2 new( %args ) 82 83Behaves like, and calls, L<WWW::Mechanize>'s C<new> method. Any parms 84passed in get passed to WWW::Mechanize's constructor. 85 86You can pass in C<< autolint => 1 >> to make Test::WWW::Mechanize 87automatically run HTML::Lint after any of the following methods are 88called. You can also pass in an HTML::Lint object like this: 89 90 my $lint = HTML::Lint->new( only_types => HTML::Lint::Error::STRUCTURE ); 91 my $mech = Test::WWW::Mechanize->new( autolint => $lint ); 92 93The same is also possible with C<< autotidy => 1 >> to use HTML::Tidy5. 94 95=over 96 97=item * get_ok() 98 99=item * post_ok() 100 101=item * submit_form_ok() 102 103=item * follow_link_ok() 104 105=item * click_ok() 106 107=back 108 109This means you no longer have to do the following: 110 111 my $mech = Test::WWW::Mechanize->new(); 112 $mech->get_ok( $url, 'Fetch the intro page' ); 113 $mech->html_lint_ok( 'Intro page looks OK' ); 114 115and can simply do 116 117 my $mech = Test::WWW::Mechanize->new( autolint => 1 ); 118 $mech->get_ok( $url, 'Fetch the intro page' ); 119 120The C<< $mech->get_ok() >> only counts as one test in the test count. Both the 121main IO operation and the linting must pass for the entire test to pass. 122 123You can control autolint and autotidy on the fly with the C<autolint> 124and C<autotidy> methods. 125 126=cut 127 128sub new { 129 my $class = shift; 130 131 my %args = ( 132 agent => "Test-WWW-Mechanize/$VERSION", 133 @_ 134 ); 135 136 my $autolint = delete $args{autolint}; 137 my $autotidy = delete $args{autotidy}; 138 139 my $self = $class->SUPER::new( %args ); 140 141 $self->autolint( $autolint ); 142 $self->autotidy( $autotidy ); 143 144 return $self; 145} 146 147 148# Override WWW::Mechanize->_reset_page() to handle Test::WWW::Mechanize-specific data. 149sub _reset_page { 150 my $self = shift; 151 152 # Parent object stuff 153 $self->SUPER::_reset_page( @_ ); 154 155 $self->{ids} = undef; 156 157 return; 158} 159 160 161=head1 METHODS: HTTP VERBS 162 163=head2 $mech->get_ok($url, [ \%LWP_options ,] $desc) 164 165A wrapper around WWW::Mechanize's get(), with similar options, except 166the second argument needs to be a hash reference, not a hash. Like 167well-behaved C<*_ok()> functions, it returns true if the test passed, 168or false if not. 169 170A default description of "GET $url" is used if none if provided. 171 172=cut 173 174sub get_ok { 175 my $self = shift; 176 177 my ($url,$desc,%opts) = $self->_unpack_args( 'GET', @_ ); 178 179 $self->get( $url, %opts ); 180 my $ok = $self->success; 181 182 $ok = $self->_post_load_validation( $ok, $desc ); 183 184 return $ok; 185} 186 187sub _post_load_validation { 188 my $self = shift; 189 my $ok = shift; 190 my $desc = shift; 191 192 local $Test::Builder::Level = $Test::Builder::Level + 1; 193 194 if ( $ok ) { 195 my $emitted_ok = 0; 196 if ( $self->is_html ) { 197 if ( $self->autolint && $self->autotidy ) { 198 my $msg = 'autolint & autotidy'; 199 $msg .= ": $desc" if defined $desc; 200 $TB->subtest( 201 $desc, 202 sub { 203 $self->_lint_content_ok(); 204 $self->_tidy_content_ok(); 205 } 206 ); 207 ++$emitted_ok; 208 } 209 else { 210 if ( $self->autolint ) { 211 $ok = $self->_lint_content_ok( $desc ); 212 ++$emitted_ok; 213 } 214 elsif ( $self->autotidy ) { 215 $ok = $self->_tidy_content_ok( $desc ); 216 ++$emitted_ok; 217 } 218 } 219 } 220 221 if ( !$emitted_ok ) { 222 $TB->ok( $ok, $desc ); 223 } 224 } 225 else { 226 $TB->ok( $ok, $desc ); 227 $TB->diag( $self->status ); 228 $TB->diag( $self->response->message ) if $self->response; 229 } 230 231 return $ok; 232} 233 234=head2 $mech->head_ok($url, [ \%LWP_options ,] $desc) 235 236A wrapper around WWW::Mechanize's head(), with similar options, except 237the second argument needs to be a hash reference, not a hash. Like 238well-behaved C<*_ok()> functions, it returns true if the test passed, 239or false if not. 240 241A default description of "HEAD $url" is used if none if provided. 242 243=cut 244 245sub head_ok { 246 my $self = shift; 247 248 my ($url,$desc,%opts) = $self->_unpack_args( 'HEAD', @_ ); 249 250 $self->head( $url, %opts ); 251 my $ok = $self->success; 252 253 $TB->ok( $ok, $desc ); 254 if ( !$ok ) { 255 $TB->diag( $self->status ); 256 $TB->diag( $self->response->message ) if $self->response; 257 } 258 259 return $ok; 260} 261 262 263=head2 $mech->post_ok( $url, [ \%LWP_options ,] $desc ) 264 265A wrapper around WWW::Mechanize's post(), with similar options, except 266the second argument needs to be a hash reference, not a hash. Like 267well-behaved C<*_ok()> functions, it returns true if the test passed, 268or false if not. 269 270B<NOTE> Due to compatibility reasons it is not possible to pass 271additional LWP_options beyond form data via this method (such as 272Content or Content-Type). It is recommend that you use WWW::Mechanize's 273post() directly for instances where more granular control of the post 274is needed. 275 276A default description of "POST to $url" is used if none if provided. 277 278=cut 279 280sub post_ok { 281 my $self = shift; 282 283 my ($url,$desc,%opts) = $self->_unpack_args( 'POST', @_ ); 284 285 $self->post( $url, \%opts ); 286 my $ok = $self->success; 287 $ok = $self->_post_load_validation( $ok, $desc ); 288 289 return $ok; 290} 291 292=head2 $mech->put_ok( $url, [ \%LWP_options ,] $desc ) 293 294A wrapper around WWW::Mechanize's put(), with similar options, except 295the second argument needs to be a hash reference, not a hash. Like 296well-behaved C<*_ok()> functions, it returns true if the test passed, 297or false if not. 298 299A default description of "PUT to $url" is used if none if provided. 300 301=cut 302 303sub put_ok { 304 my $self = shift; 305 306 my ($url,$desc,%opts) = $self->_unpack_args( 'PUT', @_ ); 307 $opts{content} = '' if !exists $opts{content}; 308 $self->put( $url, %opts ); 309 310 my $ok = $self->success; 311 $TB->ok( $ok, $desc ); 312 if ( !$ok ) { 313 $TB->diag( $self->status ); 314 $TB->diag( $self->response->message ) if $self->response; 315 } 316 317 return $ok; 318} 319 320=head2 $mech->delete_ok( $url, [ \%LWP_options ,] $desc ) 321 322A wrapper around WWW::Mechanize's delete(), with similar options, except 323the second argument needs to be a hash reference, not a hash. Like 324well-behaved C<*_ok()> functions, it returns true if the test passed, 325or false if not. 326 327A default description of "DELETE to $url" is used if none if provided. 328 329=cut 330 331sub delete_ok { 332 my $self = shift; 333 334 my ($url,$desc,%opts) = $self->_unpack_args( 'DELETE', @_ ); 335 336 if ($self->can('delete')) { 337 $self->delete( $url, %opts ); 338 } 339 else { 340 # When version of LWP::UserAgent is older than 6.04. 341 $self->_delete( $url, %opts ); 342 } 343 my $ok = $self->success; 344 345 $ok = $self->_post_load_validation( $ok, $desc ); 346 347 return $ok; 348} 349 350sub _delete { 351 require URI; 352 require HTTP::Request::Common; 353 my $self = shift; 354 my $uri = shift; 355 356 $uri = $uri->url if ref($uri) eq 'WWW::Mechanize::Link'; 357 $uri = $self->base 358 ? URI->new_abs( $uri, $self->base ) 359 : URI->new($uri); 360 361 my @parameters = ( $uri->as_string, @_ ); 362 my @suff = $self->_process_colonic_headers( \@parameters, 1 ); 363 return $self->request( HTTP::Request::Common::DELETE(@parameters), @suff ); 364} 365 366=head2 $mech->submit_form_ok( \%parms [, $desc] ) 367 368Makes a C<submit_form()> call and executes tests on the results. 369The form must be found, and then submitted successfully. Otherwise, 370this test fails. 371 372I<%parms> is a hashref containing the parms to pass to C<submit_form()>. 373Note that the parms to C<submit_form()> are a hash whereas the parms to 374this function are a hashref. You have to call this function like: 375 376 $mech->submit_form_ok( { 377 form_number => 3, 378 fields => { 379 answer => 42 380 }, 381 }, 'now we just need the question' 382 ); 383 384As with other test functions, C<$desc> is optional. If it is supplied 385then it will display when running the test harness in verbose mode. 386 387Returns true value if the specified link was found and followed 388successfully. The L<HTTP::Response> object returned by submit_form() 389is not available. 390 391=cut 392 393sub submit_form_ok { 394 my $self = shift; 395 my $parms = shift || {}; 396 my $desc = shift; 397 398 if ( ref $parms ne 'HASH' ) { 399 Carp::croak 'FATAL: parameters must be given as a hashref'; 400 } 401 402 # return from submit_form() is an HTTP::Response or undef 403 my $response = $self->submit_form( %{$parms} ); 404 405 my $ok = $response && $response->is_success; 406 $ok = $self->_post_load_validation( $ok, $desc ); 407 408 return $ok; 409} 410 411 412=head2 $mech->follow_link_ok( \%parms [, $desc] ) 413 414Makes a C<follow_link()> call and executes tests on the results. 415The link must be found, and then followed successfully. Otherwise, 416this test fails. 417 418I<%parms> is a hashref containing the parms to pass to C<follow_link()>. 419Note that the parms to C<follow_link()> are a hash whereas the parms to 420this function are a hashref. You have to call this function like: 421 422 $mech->follow_link_ok( {n=>3}, 'looking for 3rd link' ); 423 424As with other test functions, C<$desc> is optional. If it is supplied 425then it will display when running the test harness in verbose mode. 426 427Returns a true value if the specified link was found and followed 428successfully. The L<HTTP::Response> object returned by follow_link() 429is not available. 430 431=cut 432 433sub follow_link_ok { 434 my $self = shift; 435 my $parms = shift || {}; 436 my $desc = shift; 437 438 if (!defined($desc)) { 439 my $parms_str = join(', ', map { join('=', $_, $parms->{$_}) } keys(%{$parms})); 440 $desc = qq{Followed link with "$parms_str"} if !defined($desc); 441 } 442 443 if ( ref $parms ne 'HASH' ) { 444 Carp::croak 'FATAL: parameters must be given as a hashref'; 445 } 446 447 # return from follow_link() is an HTTP::Response or undef 448 my $response = $self->follow_link( %{$parms} ); 449 450 my $ok = $response && $response->is_success; 451 $ok = $self->_post_load_validation( $ok, $desc ); 452 453 return $ok; 454} 455 456 457=head2 $mech->click_ok( $button[, $desc] ) 458 459=head2 $mech->click_ok( \@button-and-coordinates [, $desc ] ) 460 461Clicks the button named by C<$button>. An optional C<$desc> can be 462given for the test. 463 464 $mech->click_ok( 'continue', 'Clicking the "Continue" button' ); 465 466Alternatively the first argument can be an arrayref with three elements: 467The name of the button and the X and Y coordinates of the button. 468 469 $mech->click_ok( [ 'continue', 12, 47 ], 'Clicking the "Continue" button' ); 470 471=cut 472 473sub click_ok { 474 my $self = shift; 475 my $button = shift; 476 my $desc = shift; 477 478 my $response; 479 if ( ref($button) eq 'ARRAY' ) { 480 $response = $self->click( $button->[0], $button->[1], $button->[2] ); 481 } 482 else { 483 $response = $self->click( $button ); 484 } 485 486 if ( !$response ) { 487 return $TB->ok( 0, $desc ); 488 } 489 490 my $ok = $response->is_success; 491 492 $ok = $self->_post_load_validation( $ok, $desc ); 493 494 return $ok; 495} 496 497 498sub _unpack_args { 499 my $self = shift; 500 my $method = shift; 501 my $url = shift; 502 503 my $desc; 504 my %opts; 505 506 if ( @_ ) { 507 my $flex = shift; # The flexible argument 508 509 if ( !defined( $flex ) ) { 510 $desc = shift; 511 } 512 elsif ( ref $flex eq 'HASH' ) { 513 %opts = %{$flex}; 514 $desc = shift; 515 } 516 elsif ( ref $flex eq 'ARRAY' ) { 517 %opts = @{$flex}; 518 $desc = shift; 519 } 520 else { 521 $desc = $flex; 522 } 523 } # parms left 524 525 if ( not defined $desc ) { 526 $url = $url->url if ref($url) eq 'WWW::Mechanize::Link'; 527 $desc = "$method $url"; 528 } 529 530 return ($url, $desc, %opts); 531} 532 533 534=head1 METHODS: HEADER CHECKING 535 536=head2 $mech->header_exists_ok( $header [, $desc ] ) 537 538Assures that a given response header exists. The actual value of the 539response header is not checked, only that the header exists. 540 541=cut 542 543sub header_exists_ok { 544 my $self = shift; 545 my $header = shift; 546 my $desc = shift || qq{Response has $header header}; 547 548 return $TB->ok( defined($self->response->header($header)), $desc ); 549} 550 551 552=head2 $mech->lacks_header_ok( $header [, $desc ] ) 553 554Assures that a given response header does NOT exist. 555 556=cut 557 558sub lacks_header_ok { 559 my $self = shift; 560 my $header = shift; 561 my $desc = shift || qq{Response lacks $header header}; 562 563 return $TB->ok( !defined($self->response->header($header)), $desc ); 564} 565 566 567=head2 $mech->header_is( $header, $value [, $desc ] ) 568 569Assures that a given response header exists and has the given value. 570 571=cut 572 573sub header_is { 574 my $self = shift; 575 my $header = shift; 576 my $value = shift; 577 my $desc = shift || qq{Response has $header header with value "$value"}; 578 579 # Force scalar context. 580 my $actual_value = $self->response->header($header); 581 582 my $ok; 583 if ( defined( $actual_value ) ) { 584 $ok = $TB->is_eq( $actual_value, $value, $desc ); 585 } 586 else { 587 $ok = $TB->ok( 0, $desc ); 588 $TB->diag( "Header $header does not exist" ); 589 } 590 591 return $ok; 592} 593 594 595=head2 $mech->header_like( $header, $value [, $desc ] ) 596 597Assures that a given response header exists and has the given value. 598 599=cut 600 601sub header_like { 602 my $self = shift; 603 my $header = shift; 604 my $regex = shift; 605 my $desc = shift || qq{Response has $header header that matches regex $regex}; 606 607 # Force scalar context. 608 my $actual_value = $self->response->header($header); 609 return $TB->like( $self->response->header($header), $regex, $desc ); 610} 611 612 613=head1 METHODS: CONTENT CHECKING 614 615=head2 $mech->html_lint_ok( [$desc] ) 616 617Checks the validity of the HTML on the current page using the HTML::Lint 618module. If the page is not HTML, then it fails. The URI is automatically 619appended to the I<$desc>. 620 621Note that HTML::Lint must be installed for this to work. Otherwise, 622it will blow up. 623 624=cut 625 626sub html_lint_ok { 627 my $self = shift; 628 my $desc = shift; 629 630 my $uri = $self->uri; 631 $desc = $desc ? "$desc ($uri)" : $uri; 632 633 my $ok; 634 635 if ( $self->is_html ) { 636 $ok = $self->_lint_content_ok( $desc ); 637 } 638 else { 639 $ok = $TB->ok( 0, $desc ); 640 $TB->diag( q{This page doesn't appear to be HTML, or didn't get the proper text/html content type returned.} ); 641 } 642 643 return $ok; 644} 645 646 647sub _lint_content_ok { 648 local $Test::Builder::Level = $Test::Builder::Level + 1; 649 650 my $self = shift; 651 my $desc = shift; 652 653 my $module = "HTML::Lint 2.20"; 654 if ( not ( eval "use $module; 1;" ) ) { 655 die "Test::WWW::Mechanize can't do linting without $module: $@"; 656 } 657 658 my $lint = $self->{autolint}; 659 if ( ref $lint && $lint->isa('HTML::Lint') ) { 660 $lint->newfile; 661 $lint->clear_errors; 662 } 663 else { 664 $lint = HTML::Lint->new(); 665 } 666 667 $lint->parse( $self->content ); 668 $lint->eof(); 669 670 my @errors = $lint->errors; 671 my $nerrors = @errors; 672 my $ok; 673 if ( $nerrors ) { 674 $ok = $TB->ok( 0, $desc ); 675 $TB->diag( 'HTML::Lint errors for ' . $self->uri ); 676 $TB->diag( $_->as_string ) for @errors; 677 my $s = $nerrors == 1 ? '' : 's'; 678 $TB->diag( "$nerrors error$s on the page" ); 679 } 680 else { 681 $ok = $TB->ok( 1, $desc ); 682 } 683 684 return $ok; 685} 686 687 688=head2 $mech->html_tidy_ok( [$desc] ) 689 690Checks the validity of the HTML on the current page using the HTML::Tidy 691module. If the page is not HTML, then it fails. The URI is automatically 692appended to the I<$desc>. 693 694Note that HTML::tidy must be installed for this to work. Otherwise, 695it will blow up. 696 697=cut 698 699sub html_tidy_ok { 700 my $self = shift; 701 my $desc = shift; 702 703 my $uri = $self->uri; 704 $desc = $desc ? "$desc ($uri)" : $uri; 705 706 my $ok; 707 708 if ( $self->is_html ) { 709 $ok = $self->_tidy_content_ok( $desc ); 710 } 711 else { 712 $ok = $TB->ok( 0, $desc ); 713 $TB->diag( q{This page doesn't appear to be HTML, or didn't get the proper text/html content type returned.} ); 714 } 715 716 return $ok; 717} 718 719 720sub _tidy_content_ok { 721 local $Test::Builder::Level = $Test::Builder::Level + 1; 722 723 my $self = shift; 724 my $desc = shift; 725 726 my $module = 'HTML::Tidy5 1.00'; 727 728 if ( not ( eval "use $module; 1;" ) ) { 729 die "Test::WWW::Mechanize can't do tidying without $module: $@"; 730 } 731 732 my $tidy = $self->{autotidy}; 733 if ( ref $tidy && $tidy->isa('HTML::Tidy5') ) { 734 $tidy->clear_messages(); 735 } 736 else { 737 $tidy = HTML::Tidy5->new(); 738 } 739 740 $tidy->parse( '', $self->content_for_tidy ); 741 742 my @messages = $tidy->messages; 743 my $nmessages = @messages; 744 my $ok; 745 if ( $nmessages ) { 746 $ok = $TB->ok( 0, $desc ); 747 $TB->diag( 'HTML::Tidy5 messages for ' . $self->uri ); 748 $TB->diag( $_->as_string ) for @messages; 749 my $s = $nmessages == 1 ? '' : 's'; 750 $TB->diag( "$nmessages message$s on the page" ); 751 } 752 else { 753 $ok = $TB->ok( 1, $desc ); 754 } 755 756 return $ok; 757} 758 759 760=head2 $mech->content_for_tidy() 761 762This method is called by C<html_tidy_ok()> to get the content that should 763be validated by HTML::Tidy5. By default, this is just C<content()>, 764but subclasses can override it to modify the content before validation. 765 766This method should not change any state in the Mech object. Specifically, 767it should not actually modify any of the actual content. 768 769=cut 770 771sub content_for_tidy { 772 my $self = shift; 773 774 return $self->content; 775} 776 777 778=head2 $mech->title_is( $str [, $desc ] ) 779 780Tells if the title of the page is the given string. 781 782 $mech->title_is( 'Invoice Summary' ); 783 784=cut 785 786sub title_is { 787 my $self = shift; 788 my $str = shift; 789 my $desc = shift; 790 $desc = qq{Title is "$str"} if !defined($desc); 791 792 local $Test::Builder::Level = $Test::Builder::Level + 1; 793 return is_string( $self->title, $str, $desc ); 794} 795 796=head2 $mech->title_like( $regex [, $desc ] ) 797 798Tells if the title of the page matches the given regex. 799 800 $mech->title_like( qr/Invoices for (.+)/ ); 801 802=cut 803 804sub title_like { 805 my $self = shift; 806 my $regex = shift; 807 my $desc = shift; 808 $desc = qq{Title is like "$regex"} if !defined($desc); 809 810 local $Test::Builder::Level = $Test::Builder::Level + 1; 811 return like_string( $self->title, $regex, $desc ); 812} 813 814=head2 $mech->title_unlike( $regex [, $desc ] ) 815 816Tells if the title of the page matches the given regex. 817 818 $mech->title_unlike( qr/Invoices for (.+)/ ); 819 820=cut 821 822sub title_unlike { 823 my $self = shift; 824 my $regex = shift; 825 my $desc = shift; 826 $desc = qq{Title is unlike "$regex"} if !defined($desc); 827 828 local $Test::Builder::Level = $Test::Builder::Level + 1; 829 return unlike_string( $self->title, $regex, $desc ); 830} 831 832=head2 $mech->base_is( $str [, $desc ] ) 833 834Tells if the base of the page is the given string. 835 836 $mech->base_is( 'http://example.com/' ); 837 838=cut 839 840sub base_is { 841 my $self = shift; 842 my $str = shift; 843 my $desc = shift; 844 $desc = qq{Base is "$str"} if !defined($desc); 845 846 local $Test::Builder::Level = $Test::Builder::Level + 1; 847 return is_string( $self->base, $str, $desc ); 848} 849 850=head2 $mech->base_like( $regex [, $desc ] ) 851 852Tells if the base of the page matches the given regex. 853 854 $mech->base_like( qr{http://example.com/index.php?PHPSESSID=(.+)}); 855 856=cut 857 858sub base_like { 859 my $self = shift; 860 my $regex = shift; 861 my $desc = shift; 862 $desc = qq{Base is like "$regex"} if !defined($desc); 863 864 local $Test::Builder::Level = $Test::Builder::Level + 1; 865 return like_string( $self->base, $regex, $desc ); 866} 867 868=head2 $mech->base_unlike( $regex [, $desc ] ) 869 870Tells if the base of the page matches the given regex. 871 872 $mech->base_unlike( qr{http://example.com/index.php?PHPSESSID=(.+)}); 873 874=cut 875 876sub base_unlike { 877 my $self = shift; 878 my $regex = shift; 879 my $desc = shift; 880 $desc = qq{Base is unlike "$regex"} if !defined($desc); 881 882 local $Test::Builder::Level = $Test::Builder::Level + 1; 883 return unlike_string( $self->base, $regex, $desc ); 884} 885 886=head2 $mech->content_is( $str [, $desc ] ) 887 888Tells if the content of the page matches the given string 889 890=cut 891 892sub content_is { 893 my $self = shift; 894 my $str = shift; 895 my $desc = shift; 896 897 local $Test::Builder::Level = $Test::Builder::Level + 1; 898 $desc = qq{Content is "$str"} if !defined($desc); 899 900 return is_string( $self->content, $str, $desc ); 901} 902 903=head2 $mech->content_contains( $str [, $desc ] ) 904 905Tells if the content of the page contains I<$str>. 906 907=cut 908 909sub content_contains { 910 my $self = shift; 911 my $str = shift; 912 my $desc = shift; 913 914 local $Test::Builder::Level = $Test::Builder::Level + 1; 915 916 if ( ref($str) ) { 917 return $TB->ok( 0, 'Test::WWW::Mechanize->content_contains called incorrectly. It requires a scalar, not a reference.' ); 918 } 919 $desc = qq{Content contains "$str"} if !defined($desc); 920 921 return contains_string( $self->content, $str, $desc ); 922} 923 924=head2 $mech->content_lacks( $str [, $desc ] ) 925 926Tells if the content of the page lacks I<$str>. 927 928=cut 929 930sub content_lacks { 931 my $self = shift; 932 my $str = shift; 933 my $desc = shift; 934 935 local $Test::Builder::Level = $Test::Builder::Level + 1; 936 if ( ref($str) ) { 937 return $TB->ok( 0, 'Test::WWW::Mechanize->content_lacks called incorrectly. It requires a scalar, not a reference.' ); 938 } 939 $desc = qq{Content lacks "$str"} if !defined($desc); 940 941 return lacks_string( $self->content, $str, $desc ); 942} 943 944=head2 $mech->content_like( $regex [, $desc ] ) 945 946Tells if the content of the page matches I<$regex>. 947 948=cut 949 950sub content_like { 951 my $self = shift; 952 my $regex = shift; 953 my $desc = shift; 954 $desc = qq{Content is like "$regex"} if !defined($desc); 955 956 local $Test::Builder::Level = $Test::Builder::Level + 1; 957 return like_string( $self->content, $regex, $desc ); 958} 959 960=head2 $mech->content_unlike( $regex [, $desc ] ) 961 962Tells if the content of the page does NOT match I<$regex>. 963 964=cut 965 966sub content_unlike { 967 my $self = shift; 968 my $regex = shift; 969 my $desc = shift || qq{Content is unlike "$regex"}; 970 971 local $Test::Builder::Level = $Test::Builder::Level + 1; 972 return unlike_string( $self->content, $regex, $desc ); 973} 974 975=head2 $mech->text_contains( $str [, $desc ] ) 976 977Tells if the text form of the page's content contains I<$str>. 978 979When your page contains HTML which is difficult, unimportant, or 980unlikely to match over time as designers alter markup, use 981C<text_contains> instead of C<content_contains>. 982 983 # <b>Hi, <i><a href="some/path">User</a></i>!</b> 984 $mech->content_contains('Hi, User'); # Fails. 985 $mech->text_contains('Hi, User'); # Passes. 986 987Text is determined by calling C<< $mech->text() >>. 988See L<WWW::Mechanize/content>. 989 990=cut 991 992sub text_contains { 993 my $self = shift; 994 my $str = shift; 995 my $desc = shift || qq{Text contains "$str"}; 996 997 local $Test::Builder::Level = $Test::Builder::Level + 1; 998 if ( ref($str) ) { 999 return $TB->ok( 0, 'Test::WWW::Mechanize->text_contains called incorrectly. It requires a scalar, not a reference.' ); 1000 } 1001 1002 return contains_string( $self->text, $str, $desc ); 1003} 1004 1005=head2 $mech->text_lacks( $str [, $desc ] ) 1006 1007Tells if the text of the page lacks I<$str>. 1008 1009=cut 1010 1011sub text_lacks { 1012 my $self = shift; 1013 my $str = shift; 1014 my $desc = shift; 1015 1016 local $Test::Builder::Level = $Test::Builder::Level + 1; 1017 if ( ref($str) ) { 1018 return $TB->ok( 0, 'Test::WWW::Mechanize->text_lacks called incorrectly. It requires a scalar, not a reference.' ); 1019 } 1020 $desc = qq{Text lacks "$str"} if !defined($desc); 1021 1022 return lacks_string( $self->text, $str, $desc ); 1023} 1024 1025=head2 $mech->text_like( $regex [, $desc ] ) 1026 1027Tells if the text form of the page's content matches I<$regex>. 1028 1029=cut 1030 1031sub text_like { 1032 my $self = shift; 1033 my $regex = shift; 1034 my $desc = shift || qq{Text is like "$regex"}; 1035 1036 local $Test::Builder::Level = $Test::Builder::Level + 1; 1037 return like_string( $self->text, $regex, $desc ); 1038} 1039 1040=head2 $mech->text_unlike( $regex [, $desc ] ) 1041 1042Tells if the text format of the page's content does NOT match I<$regex>. 1043 1044=cut 1045 1046sub text_unlike { 1047 my $self = shift; 1048 my $regex = shift; 1049 my $desc = shift || qq{Text is unlike "$regex"}; 1050 1051 local $Test::Builder::Level = $Test::Builder::Level + 1; 1052 return unlike_string( $self->text, $regex, $desc ); 1053} 1054 1055=head2 $mech->has_tag( $tag, $text [, $desc ] ) 1056 1057Tells if the page has a C<$tag> tag with the given content in its text. 1058 1059=cut 1060 1061sub has_tag { 1062 my $self = shift; 1063 my $tag = shift; 1064 my $text = shift; 1065 my $desc = shift || qq{Page has $tag tag with "$text"}; 1066 1067 my $found = $self->_tag_walk( $tag, sub { $text eq $_[0] } ); 1068 1069 return $TB->ok( $found, $desc ); 1070} 1071 1072 1073=head2 $mech->has_tag_like( $tag, $regex [, $desc ] ) 1074 1075Tells if the page has a C<$tag> tag with the given content in its text. 1076 1077=cut 1078 1079sub has_tag_like { 1080 my $self = shift; 1081 my $tag = shift; 1082 my $regex = shift; 1083 my $desc = shift; 1084 $desc = qq{Page has $tag tag like "$regex"} if !defined($desc); 1085 1086 my $found = $self->_tag_walk( $tag, sub { $_[0] =~ $regex } ); 1087 1088 return $TB->ok( $found, $desc ); 1089} 1090 1091 1092sub _tag_walk { 1093 my $self = shift; 1094 my $tag = shift; 1095 my $match = shift; 1096 1097 my $p = HTML::TokeParser->new( \($self->content) ); 1098 1099 while ( my $token = $p->get_tag( $tag ) ) { 1100 my $tagtext = $p->get_trimmed_text(); 1101 return 1 if $match->( $tagtext ); 1102 } 1103 return; 1104} 1105 1106=head2 $mech->page_links_ok( [ $desc ] ) 1107 1108Follow all links on the current page and test for HTTP status 200 1109 1110 $mech->page_links_ok('Check all links'); 1111 1112=cut 1113 1114sub page_links_ok { 1115 my $self = shift; 1116 my $desc = shift; 1117 1118 $desc = 'All links ok' unless defined $desc; 1119 1120 my @links = $self->followable_links(); 1121 my @urls = _format_links(\@links); 1122 1123 my @failures = $self->_check_links_status( \@urls ); 1124 my $ok = (@failures==0); 1125 1126 $TB->ok( $ok, $desc ); 1127 $TB->diag( $_ ) for @failures; 1128 1129 return $ok; 1130} 1131 1132=head2 $mech->page_links_content_like( $regex [, $desc ] ) 1133 1134Follow all links on the current page and test their contents for I<$regex>. 1135 1136 $mech->page_links_content_like( qr/foo/, 1137 'Check all links contain "foo"' ); 1138 1139=cut 1140 1141sub page_links_content_like { 1142 my $self = shift; 1143 my $regex = shift; 1144 my $desc = shift; 1145 1146 $desc = qq{All links are like "$regex"} unless defined $desc; 1147 1148 my $usable_regex=$TB->maybe_regex( $regex ); 1149 1150 if ( !defined( $usable_regex ) ) { 1151 my $ok = $TB->ok( 0, 'page_links_content_like' ); 1152 $TB->diag(qq{ "$regex" doesn't look much like a regex to me.}); 1153 return $ok; 1154 } 1155 1156 my @links = $self->followable_links(); 1157 my @urls = _format_links(\@links); 1158 1159 my @failures = $self->_check_links_content( \@urls, $regex ); 1160 my $ok = (@failures==0); 1161 1162 $TB->ok( $ok, $desc ); 1163 $TB->diag( $_ ) for @failures; 1164 1165 return $ok; 1166} 1167 1168=head2 $mech->page_links_content_unlike( $regex [, $desc ] ) 1169 1170Follow all links on the current page and test their contents do not 1171contain the specified regex. 1172 1173 $mech->page_links_content_unlike(qr/Restricted/, 1174 'Check all links do not contain Restricted'); 1175 1176=cut 1177 1178sub page_links_content_unlike { 1179 my $self = shift; 1180 my $regex = shift; 1181 my $desc = shift; 1182 $desc = qq{All links are unlike "$regex"} unless defined($desc); 1183 1184 my $usable_regex=$TB->maybe_regex( $regex ); 1185 1186 if ( !defined( $usable_regex ) ) { 1187 my $ok = $TB->ok( 0, 'page_links_content_unlike' ); 1188 $TB->diag(qq{ "$regex" doesn't look much like a regex to me.}); 1189 return $ok; 1190 } 1191 1192 my @links = $self->followable_links(); 1193 my @urls = _format_links(\@links); 1194 1195 my @failures = $self->_check_links_content( \@urls, $regex, 'unlike' ); 1196 my $ok = (@failures==0); 1197 1198 $TB->ok( $ok, $desc ); 1199 $TB->diag( $_ ) for @failures; 1200 1201 return $ok; 1202} 1203 1204=head2 $mech->links_ok( $links [, $desc ] ) 1205 1206Follow specified links on the current page and test for HTTP status 1207200. The links may be specified as a reference to an array containing 1208L<WWW::Mechanize::Link> objects, an array of URLs, or a scalar URL 1209name. 1210 1211 my @links = $mech->find_all_links( url_regex => qr/cnn\.com$/ ); 1212 $mech->links_ok( \@links, 'Check all links for cnn.com' ); 1213 1214 my @links = qw( index.html search.html about.html ); 1215 $mech->links_ok( \@links, 'Check main links' ); 1216 1217 $mech->links_ok( 'index.html', 'Check link to index' ); 1218 1219=cut 1220 1221sub links_ok { 1222 my $self = shift; 1223 my $links = shift; 1224 my $desc = shift; 1225 1226 my @urls = _format_links( $links ); 1227 $desc = _default_links_desc(\@urls, 'are ok') unless defined $desc; 1228 my @failures = $self->_check_links_status( \@urls ); 1229 my $ok = (@failures == 0); 1230 1231 $TB->ok( $ok, $desc ); 1232 $TB->diag( $_ ) for @failures; 1233 1234 return $ok; 1235} 1236 1237=head2 $mech->link_status_is( $links, $status [, $desc ] ) 1238 1239Follow specified links on the current page and test for HTTP status 1240passed. The links may be specified as a reference to an array 1241containing L<WWW::Mechanize::Link> objects, an array of URLs, or a 1242scalar URL name. 1243 1244 my @links = $mech->followable_links(); 1245 $mech->link_status_is( \@links, 403, 1246 'Check all links are restricted' ); 1247 1248=cut 1249 1250sub link_status_is { 1251 my $self = shift; 1252 my $links = shift; 1253 my $status = shift; 1254 my $desc = shift; 1255 1256 my @urls = _format_links( $links ); 1257 $desc = _default_links_desc(\@urls, "have status $status") if !defined($desc); 1258 my @failures = $self->_check_links_status( \@urls, $status ); 1259 my $ok = (@failures == 0); 1260 1261 $TB->ok( $ok, $desc ); 1262 $TB->diag( $_ ) for @failures; 1263 1264 return $ok; 1265} 1266 1267=head2 $mech->link_status_isnt( $links, $status [, $desc ] ) 1268 1269Follow specified links on the current page and test for HTTP status 1270passed. The links may be specified as a reference to an array 1271containing L<WWW::Mechanize::Link> objects, an array of URLs, or a 1272scalar URL name. 1273 1274 my @links = $mech->followable_links(); 1275 $mech->link_status_isnt( \@links, 404, 1276 'Check all links are not 404' ); 1277 1278=cut 1279 1280sub link_status_isnt { 1281 my $self = shift; 1282 my $links = shift; 1283 my $status = shift; 1284 my $desc = shift; 1285 1286 my @urls = _format_links( $links ); 1287 $desc = _default_links_desc(\@urls, "do not have status $status") if !defined($desc); 1288 my @failures = $self->_check_links_status( \@urls, $status, 'isnt' ); 1289 my $ok = (@failures == 0); 1290 1291 $TB->ok( $ok, $desc ); 1292 $TB->diag( $_ ) for @failures; 1293 1294 return $ok; 1295} 1296 1297 1298=head2 $mech->link_content_like( $links, $regex [, $desc ] ) 1299 1300Follow specified links on the current page and test the resulting 1301content of each against I<$regex>. The links may be specified as a 1302reference to an array containing L<WWW::Mechanize::Link> objects, an 1303array of URLs, or a scalar URL name. 1304 1305 my @links = $mech->followable_links(); 1306 $mech->link_content_like( \@links, qr/Restricted/, 1307 'Check all links are restricted' ); 1308 1309=cut 1310 1311sub link_content_like { 1312 my $self = shift; 1313 my $links = shift; 1314 my $regex = shift; 1315 my $desc = shift; 1316 1317 my $usable_regex=$TB->maybe_regex( $regex ); 1318 1319 if ( !defined( $usable_regex ) ) { 1320 my $ok = $TB->ok( 0, 'link_content_like' ); 1321 $TB->diag(qq{ "$regex" doesn't look much like a regex to me.}); 1322 return $ok; 1323 } 1324 1325 my @urls = _format_links( $links ); 1326 $desc = _default_links_desc( \@urls, qq{are like "$regex"} ) if !defined($desc); 1327 my @failures = $self->_check_links_content( \@urls, $regex ); 1328 my $ok = (@failures == 0); 1329 1330 $TB->ok( $ok, $desc ); 1331 $TB->diag( $_ ) for @failures; 1332 1333 return $ok; 1334} 1335 1336=head2 $mech->link_content_unlike( $links, $regex [, $desc ] ) 1337 1338Follow specified links on the current page and test that the resulting 1339content of each does not match I<$regex>. The links may be specified as a 1340reference to an array containing L<WWW::Mechanize::Link> objects, an array 1341of URLs, or a scalar URL name. 1342 1343 my @links = $mech->followable_links(); 1344 $mech->link_content_unlike( \@links, qr/Restricted/, 1345 'No restricted links' ); 1346 1347=cut 1348 1349sub link_content_unlike { 1350 my $self = shift; 1351 my $links = shift; 1352 my $regex = shift; 1353 my $desc = shift; 1354 1355 my $usable_regex=$TB->maybe_regex( $regex ); 1356 1357 if ( !defined( $usable_regex ) ) { 1358 my $ok = $TB->ok( 0, 'link_content_unlike' ); 1359 $TB->diag(qq{ "$regex" doesn't look much like a regex to me.}); 1360 return $ok; 1361 } 1362 1363 my @urls = _format_links( $links ); 1364 $desc = _default_links_desc( \@urls, qq{are not like "$regex"} ) if !defined($desc); 1365 my @failures = $self->_check_links_content( \@urls, $regex, 'unlike' ); 1366 my $ok = (@failures == 0); 1367 1368 $TB->ok( $ok, $desc ); 1369 $TB->diag( $_ ) for @failures; 1370 1371 return $ok; 1372} 1373 1374# Create a default description for the link_* methods, including the link count. 1375sub _default_links_desc { 1376 my ($urls, $desc_suffix) = @_; 1377 my $url_count = scalar(@{$urls}); 1378 return sprintf( '%d link%s %s', $url_count, $url_count == 1 ? '' : 's', $desc_suffix ); 1379} 1380 1381# This actually performs the status check of each URL. 1382sub _check_links_status { 1383 my $self = shift; 1384 my $urls = shift; 1385 my $status = shift || 200; 1386 my $test = shift || 'is'; 1387 1388 # Create a clone of the $mech used during the test as to not disrupt 1389 # the original. 1390 my $mech = $self->clone(); 1391 1392 my @failures; 1393 1394 for my $url ( @{$urls} ) { 1395 if ( $mech->follow_link( url => $url ) ) { 1396 if ( $test eq 'is' ) { 1397 push( @failures, $url ) unless $mech->status() == $status; 1398 } 1399 else { 1400 push( @failures, $url ) if $mech->status() == $status; 1401 } 1402 $mech->back(); 1403 } 1404 else { 1405 push( @failures, $url ); 1406 } 1407 } # for 1408 1409 return @failures; 1410} 1411 1412# This actually performs the content check of each URL. 1413sub _check_links_content { 1414 my $self = shift; 1415 my $urls = shift; 1416 my $regex = shift || qr/<html>/; 1417 my $test = shift || 'like'; 1418 1419 # Create a clone of the $mech used during the test as to not disrupt 1420 # the original. 1421 my $mech = $self->clone(); 1422 1423 my @failures; 1424 for my $url ( @{$urls} ) { 1425 if ( $mech->follow_link( url => $url ) ) { 1426 my $content=$mech->content(); 1427 if ( $test eq 'like' ) { 1428 push( @failures, $url ) unless $content =~ /$regex/; 1429 } 1430 else { 1431 push( @failures, $url ) if $content =~ /$regex/; 1432 } 1433 $mech->back(); 1434 } 1435 else { 1436 push( @failures, $url ); 1437 } 1438 } # for 1439 1440 return @failures; 1441} 1442 1443# Create an array of urls to match for mech to follow. 1444sub _format_links { 1445 my $links = shift; 1446 1447 my @urls; 1448 if (ref($links) eq 'ARRAY') { 1449 my $link = $links->[0]; 1450 if ( defined($link) ) { 1451 if ( ref($link) eq 'WWW::Mechanize::Link' ) { 1452 @urls = map { $_->url() } @{$links}; 1453 } 1454 else { 1455 @urls = @{$links}; 1456 } 1457 } 1458 } 1459 else { 1460 push(@urls,$links); 1461 } 1462 return @urls; 1463} 1464 1465=head1 METHODS: SCRAPING 1466 1467=head2 $mech->scrape_text_by_attr( $attr, $attr_value [, $html ] ) 1468 1469=head2 $mech->scrape_text_by_attr( $attr, $attr_regex [, $html ] ) 1470 1471Returns an array of strings, each string the text surrounded by an 1472element with attribute I<$attr> of value I<$value>. You can also pass in 1473a regular expression. If nothing is found the return is an empty list. 1474In scalar context the return is the first string found. 1475 1476If passed, I<$html> is scraped instead of the current page's content. 1477 1478=cut 1479 1480sub scrape_text_by_attr { 1481 my $self = shift; 1482 my $attr = shift; 1483 my $value = shift; 1484 1485 my $html = $self->_get_optional_html( @_ ); 1486 1487 my @results; 1488 1489 if ( defined $html ) { 1490 my $parser = HTML::TokeParser->new(\$html); 1491 1492 while ( my $token = $parser->get_tag() ) { 1493 if ( ref $token->[1] eq 'HASH' ) { 1494 if ( exists $token->[1]->{$attr} ) { 1495 my $matched = 1496 (ref $value eq 'Regexp') 1497 ? $token->[1]->{$attr} =~ $value 1498 : $token->[1]->{$attr} eq $value; 1499 if ( $matched ) { 1500 my $tag = $token->[ 0 ]; 1501 push @results, $parser->get_trimmed_text( "/$tag" ); 1502 if ( !wantarray ) { 1503 last; 1504 } 1505 } 1506 } 1507 } 1508 } 1509 } 1510 1511 return $results[0] if !wantarray; 1512 return @results; 1513} 1514 1515 1516=head2 $mech->scrape_text_by_id( $id [, $html ] ) 1517 1518Finds all elements with the given ID attribute and pulls out the text that that element encloses. 1519 1520In list context, returns a list of all strings found. In scalar context, returns the first one found. 1521 1522If C<$html> is not provided then the current content is used. 1523 1524=cut 1525 1526sub scrape_text_by_id { 1527 my $self = shift; 1528 my $id = shift; 1529 1530 my $html = $self->_get_optional_html( @_ ); 1531 1532 my @results; 1533 1534 if ( defined $html ) { 1535 # If the ID doesn't appear anywhere in the text, then there's no point in parsing. 1536 my $found = index( $html, $id ); 1537 if ( $found >= 0 ) { 1538 my $parser = HTML::TokeParser->new( \$html ); 1539 1540 while ( my $token = $parser->get_tag() ) { 1541 if ( ref $token->[1] eq 'HASH' ) { 1542 my $actual_id = $token->[1]->{id}; 1543 $actual_id = '' unless defined $actual_id; 1544 if ( $actual_id eq $id ) { 1545 my $tag = $token->[ 0 ]; 1546 push @results, $parser->get_trimmed_text( "/$tag" ); 1547 if ( !wantarray ) { 1548 last; 1549 } 1550 } 1551 } 1552 } 1553 } 1554 } 1555 1556 return $results[0] if !wantarray; 1557 return @results; 1558} 1559 1560 1561sub _get_optional_html { 1562 my $self = shift; 1563 1564 my $html; 1565 if ( @_ ) { 1566 $html = shift; 1567 assert_nonblank( $html, '$html passed in is a populated scalar' ); 1568 } 1569 else { 1570 if ( $self->is_html ) { 1571 $html = $self->content(); 1572 } 1573 } 1574 1575 return $html; 1576} 1577 1578 1579=head2 $mech->scraped_id_is( $id, $expected [, $msg] ) 1580 1581Scrapes the current page for given ID and tests that it matches the expected value. 1582 1583=cut 1584 1585sub scraped_id_is { 1586 my $self = shift; 1587 my $id = shift; 1588 my $expected = shift; 1589 my $msg = shift; 1590 1591 my $ok; 1592 my $got = $self->scrape_text_by_id( $id ); 1593 if ( defined( $got ) ) { 1594 $ok = $TB->is_eq( $got, $expected, $msg ); 1595 } 1596 else { 1597 $ok = $TB->ok( 0, $msg ); 1598 $TB->diag( qq{Can't find ID "$id" to compare to "$expected"} ); 1599 } 1600 1601 return $ok; 1602} 1603 1604 1605=head2 $mech->scraped_id_like( $id, $expected_regex [, $msg] ) 1606 1607Scrapes the current page for given id and tests that it matches the expected regex. 1608 1609=cut 1610 1611sub scraped_id_like { 1612 my $self = shift; 1613 my $id = shift; 1614 my $expected = shift; 1615 my $msg = shift; 1616 1617 my $ok; 1618 my $got = $self->scrape_text_by_id( $id ); 1619 if ( defined($got) ) { 1620 $ok = $TB->like( $got, $expected, $msg ); 1621 } 1622 else { 1623 $ok = $TB->ok( 0, $msg ); 1624 $TB->diag( qq{Can't find ID "$id" to match against $expected} ); 1625 } 1626 1627 return $ok; 1628} 1629 1630 1631=head2 id_exists( $id ) 1632 1633Returns TRUE/FALSE if the given ID exists in the given HTML, or if none 1634is provided, then the current page. 1635 1636The Mech object caches the IDs so that it doesn't bother reparsing every 1637time it's asked about an ID. 1638 1639=cut 1640 1641sub id_exists { 1642 my $self = shift; 1643 my $id = shift; 1644 1645 assert_is( $self->ct, 'text/html', 'Can only call id_exists on HTML pages' ); 1646 1647 if ( !$self->{ids} ) { 1648 my $ids = $self->{ids} = {}; 1649 my $p = HTML::Parser->new( 1650 handlers => { 1651 start => [ 1652 sub { 1653 my $attr = shift; 1654 1655 if ( my $id = $attr->{id} ) { 1656 $ids->{$id} = 1; 1657 } 1658 }, 1659 'attr' 1660 ], 1661 }, 1662 ); 1663 $p->parse( $self->content ); 1664 $p->eof; 1665 } 1666 1667 return $self->{ids}->{$id}; 1668} 1669 1670 1671=head2 $agent->id_exists_ok( $id [, $msg] ) 1672 1673Verifies there is an HTML element with ID C<$id> in the page. 1674 1675=cut 1676 1677sub id_exists_ok { 1678 local $Test::Builder::Level = $Test::Builder::Level + 1; 1679 1680 my $self = shift; 1681 my $id = shift; 1682 my $msg = shift || ('ID "' . ($id || '') . '" should exist'); 1683 1684 my $exists = $self->id_exists( $id ); 1685 1686 return $TB->ok( $exists, $msg ); 1687} 1688 1689 1690=head2 $agent->ids_exist_ok( \@ids [, $msg] ) 1691 1692Verifies an HTML element exists with each ID in C<\@ids>. 1693 1694=cut 1695 1696sub ids_exist_ok { 1697 local $Test::Builder::Level = $Test::Builder::Level + 1; 1698 1699 my $self = shift; 1700 my $ids = shift; 1701 my $msg = shift; 1702 1703 assert_arrayref( $ids ); 1704 1705 my $subtest_name = 'ids_exist_ok( [' . join( ', ', @{$ids} ) . ']'; 1706 $subtest_name .= ", $msg" if defined $msg; 1707 $subtest_name .= ' )'; 1708 1709 return $TB->subtest( 1710 $subtest_name, 1711 sub { 1712 $TB->plan( tests => scalar @{$ids} ); 1713 1714 foreach my $id ( @$ids ) { 1715 $self->id_exists_ok( $id ); 1716 } 1717 } 1718 ); 1719} 1720 1721=head2 $agent->lacks_id_ok( $id [, $msg] ) 1722 1723Verifies there is NOT an HTML element with ID C<$id> in the page. 1724 1725=cut 1726 1727sub lacks_id_ok { 1728 local $Test::Builder::Level = $Test::Builder::Level + 1; 1729 1730 my $self = shift; 1731 my $id = shift; 1732 my $msg = shift || ('ID "' . ($id || '') . '" should not exist'); 1733 1734 assert_nonblank( $id ); 1735 1736 my $exists = $self->id_exists( $id ); 1737 1738 return $TB->ok( !$exists, $msg ); 1739} 1740 1741 1742=head2 $agent->lacks_ids_ok( \@ids [, $msg] ) 1743 1744Verifies there are no HTML elements with any of the ids given in C<\@ids>. 1745 1746=cut 1747 1748sub lacks_ids_ok { 1749 local $Test::Builder::Level = $Test::Builder::Level + 1; 1750 1751 my $self = shift; 1752 my $ids = shift; 1753 my $msg = shift; 1754 1755 assert_arrayref( $ids ); 1756 1757 my $subtest_name = 'lacks_ids_ok( [' . join( ', ', @{$ids} ) . ']'; 1758 $subtest_name .= ", $msg" if defined $msg; 1759 $subtest_name .= ' )'; 1760 1761 return $TB->subtest( 1762 $subtest_name, 1763 sub { 1764 $TB->plan( tests => scalar @{$ids} ); 1765 1766 foreach my $id ( @$ids ) { 1767 $self->lacks_id_ok( $id, "ID '" . ($id // '') . "' should not exist" ); 1768 } 1769 } 1770 ); 1771} 1772 1773 1774=head2 $mech->button_exists( $button ) 1775 1776Returns a boolean saying whether the submit C<$button> exists. Does not 1777do a test. For that you want C<button_exists_ok> or C<lacks_button_ok>. 1778 1779=cut 1780 1781sub button_exists { 1782 my $self = shift; 1783 my $button = shift; 1784 1785 my $input = $self->grep_inputs( { 1786 type => qr/^submit$/, 1787 name => qr/^$button$/ 1788 } ); 1789 1790 return !!$input; 1791} 1792 1793 1794=head2 $mech->button_exists_ok( $button [, $msg] ) 1795 1796Asserts that the button exists on the page. 1797 1798=cut 1799 1800sub button_exists_ok { 1801 local $Test::Builder::Level = $Test::Builder::Level + 1; 1802 1803 my $self = shift; 1804 my $button = shift; 1805 my $msg = shift; 1806 1807 return $TB->ok( $self->button_exists( $button ), $msg ); 1808} 1809 1810 1811=head2 $mech->lacks_button_ok( $button [, $msg] ) 1812 1813Asserts that the button exists on the page. 1814 1815=cut 1816 1817sub lacks_button_ok { 1818 local $Test::Builder::Level = $Test::Builder::Level + 1; 1819 1820 my $self = shift; 1821 my $button = shift; 1822 my $msg = shift; 1823 1824 return $TB->ok( !$self->button_exists( $button ), $msg ); 1825} 1826 1827 1828=head1 METHODS: MISCELLANEOUS 1829 1830=head2 $mech->autolint( [$status] ) 1831 1832Without an argument, this method returns a true or false value indicating 1833whether autolint is active. 1834 1835When passed an argument, autolint is turned on or off depending on whether 1836the argument is true or false, and the previous autolint status is returned. 1837As with the autolint option of C<< new >>, C<< $status >> can be an 1838L<< HTML::Lint >> object. 1839 1840If autolint is currently using an L<< HTML::Lint >> object you provided, 1841the return is that object, so you can change and exactly restore 1842autolint status: 1843 1844 my $old_status = $mech->autolint( 0 ); 1845 ... operations that should not be linted ... 1846 $mech->autolint( $old_status ); 1847 1848=cut 1849 1850sub autolint { 1851 my $self = shift; 1852 1853 my $ret = $self->{autolint}; 1854 if ( @_ ) { 1855 $self->{autolint} = shift; 1856 } 1857 1858 return $ret; 1859} 1860 1861 1862=head2 $mech->autotidy( [$status] ) 1863 1864Without an argument, this method returns a true or false value indicating 1865whether autotidy is active. 1866 1867When passed an argument, autotidy is turned on or off depending on whether 1868the argument is true or false, and the previous autotidy status is returned. 1869As with the autotidy option of C<< new >>, C<< $status >> can be an 1870L<< HTML::Tidy5 >> object. 1871 1872If autotidy is currently using an L<< HTML::Tidy5 >> object you provided, 1873the return is that object, so you can change and exactly restore 1874autotidy status: 1875 1876 my $old_status = $mech->autotidy( 0 ); 1877 ... operations that should not be tidied ... 1878 $mech->autotidy( $old_status ); 1879 1880=cut 1881 1882sub autotidy { 1883 my $self = shift; 1884 1885 my $ret = $self->{autotidy}; 1886 if ( @_ ) { 1887 $self->{autotidy} = shift; 1888 } 1889 1890 return $ret; 1891} 1892 1893 1894=head2 $mech->grep_inputs( \%properties ) 1895 1896grep_inputs() returns an array of all the input controls in the 1897current form whose properties match all of the regexes in $properties. 1898The controls returned are all descended from HTML::Form::Input. 1899 1900If $properties is undef or empty then all inputs will be 1901returned. 1902 1903If there is no current page, there is no form on the current 1904page, or there are no submit controls in the current form 1905then the return will be an empty array. 1906 1907 # get all text controls whose names begin with "customer" 1908 my @customer_text_inputs = 1909 $mech->grep_inputs( { 1910 type => qr/^(text|textarea)$/, 1911 name => qr/^customer/ 1912 } 1913 ); 1914 1915=cut 1916 1917sub grep_inputs { 1918 my $self = shift; 1919 my $properties = shift; 1920 1921 my @found; 1922 1923 my $form = $self->current_form(); 1924 if ( $form ) { 1925 my @inputs = $form->inputs(); 1926 @found = _grep_hashes( \@inputs, $properties ); 1927 } 1928 1929 return @found; 1930} 1931 1932 1933=head2 $mech->grep_submits( \%properties ) 1934 1935grep_submits() does the same thing as grep_inputs() except that 1936it only returns controls that are submit controls, ignoring 1937other types of input controls like text and checkboxes. 1938 1939=cut 1940 1941sub grep_submits { 1942 my $self = shift; 1943 my $properties = shift || {}; 1944 1945 $properties->{type} = qr/^(?:submit|image)$/; # submits only 1946 my @found = $self->grep_inputs( $properties ); 1947 1948 return @found; 1949} 1950 1951# search an array of hashrefs, returning an array of the incoming 1952# hashrefs that match *all* the pattern in $patterns. 1953sub _grep_hashes { 1954 my $hashes = shift; 1955 my $patterns = shift || {}; 1956 1957 my @found; 1958 1959 if ( ! %{$patterns} ) { 1960 # nothing to match on, so return them all 1961 @found = @{$hashes}; 1962 } 1963 else { 1964 foreach my $hash ( @{$hashes} ) { 1965 1966 # check every pattern for a match on the current hash 1967 my $matches_everything = 1; 1968 foreach my $pattern_key ( keys %{$patterns} ) { 1969 $matches_everything = 0 unless exists $hash->{$pattern_key} && $hash->{$pattern_key} =~ $patterns->{$pattern_key}; 1970 last if !$matches_everything; 1971 } 1972 1973 push @found, $hash if $matches_everything; 1974 } 1975 } 1976 1977 return @found; 1978} 1979 1980 1981=head2 $mech->stuff_inputs( [\%options] ) 1982 1983Finds all free-text input fields (text, textarea, and password) in the 1984current form and fills them to their maximum length in hopes of finding 1985application code that can't handle it. Fields with no maximum length 1986and all textarea fields are set to 66000 bytes, which will often be 1987enough to overflow the data's eventual receptacle. 1988 1989There is no return value. 1990 1991If there is no current form then nothing is done. 1992 1993The hashref $options can contain the following keys: 1994 1995=over 1996 1997=item * ignore 1998 1999hash value is arrayref of field names to not touch, e.g.: 2000 2001 $mech->stuff_inputs( { 2002 ignore => [qw( specialfield1 specialfield2 )], 2003 } ); 2004 2005=item * fill 2006 2007hash value is default string to use when stuffing fields. Copies 2008of the string are repeated up to the max length of each field. E.g.: 2009 2010 $mech->stuff_inputs( { 2011 fill => '@' # stuff all fields with something easy to recognize 2012 } ); 2013 2014=item * specs 2015 2016hash value is arrayref of hashrefs with which you can pass detailed 2017instructions about how to stuff a given field. E.g.: 2018 2019 $mech->stuff_inputs( { 2020 specs=>{ 2021 # Some fields are datatype-constrained. It's most common to 2022 # want the field stuffed with valid data. 2023 widget_quantity => { fill=>'9' }, 2024 notes => { maxlength=>2000 }, 2025 } 2026 } ); 2027 2028The specs allowed are I<fill> (use this fill for the field rather than 2029the default) and I<maxlength> (use this as the field's maxlength instead 2030of any maxlength specified in the HTML). 2031 2032=back 2033 2034=cut 2035 2036sub stuff_inputs { 2037 my $self = shift; 2038 2039 my $options = shift || {}; 2040 assert_isa( $options, 'HASH' ); 2041 assert_in( $_, ['ignore', 'fill', 'specs'] ) foreach ( keys %{$options} ); 2042 2043 # set up the fill we'll use unless a field overrides it 2044 my $default_fill = '@'; 2045 if ( exists $options->{fill} && defined $options->{fill} && length($options->{fill}) > 0 ) { 2046 $default_fill = $options->{fill}; 2047 } 2048 2049 # fields in the form to not stuff 2050 my $ignore = {}; 2051 if ( exists $options->{ignore} ) { 2052 assert_isa( $options->{ignore}, 'ARRAY' ); 2053 $ignore = { map {($_, 1)} @{$options->{ignore}} }; 2054 } 2055 2056 my $specs = {}; 2057 if ( exists $options->{specs} ) { 2058 assert_isa( $options->{specs}, 'HASH' ); 2059 $specs = $options->{specs}; 2060 foreach my $field_name ( keys %{$specs} ) { 2061 assert_isa( $specs->{$field_name}, 'HASH' ); 2062 assert_in( $_, ['fill', 'maxlength'] ) foreach ( keys %{$specs->{$field_name}} ); 2063 } 2064 } 2065 2066 my @inputs = $self->find_all_inputs( type_regex => qr/^(text|textarea|password)$/ ); 2067 2068 foreach my $field ( @inputs ) { 2069 next if $field->readonly(); 2070 next if $field->disabled(); # TODO: HTML::Form::TextInput allows setting disabled--allow it here? 2071 2072 my $name = $field->name(); 2073 2074 # skip if it's one of the fields to ignore 2075 next if exists $ignore->{ $name }; 2076 2077 # fields with no maxlength will get this many characters 2078 my $maxlength = 66000; 2079 2080 # maxlength from the HTML 2081 if ( $field->type ne 'textarea' ) { 2082 if ( exists $field->{maxlength} ) { 2083 $maxlength = $field->{maxlength}; 2084 # TODO: what to do about maxlength==0 ? non-numeric? less than 0 ? 2085 } 2086 } 2087 2088 my $fill = $default_fill; 2089 2090 if ( exists $specs->{$name} ) { 2091 # process the per-field info 2092 2093 if ( exists $specs->{$name}->{fill} && defined $specs->{$name}->{fill} && length($specs->{$name}->{fill}) > 0 ) { 2094 $fill = $specs->{$name}->{fill}; 2095 } 2096 2097 # maxlength override from specs 2098 if ( exists $specs->{$name}->{maxlength} && defined $specs->{$name}->{maxlength} ) { 2099 $maxlength = $specs->{$name}->{maxlength}; 2100 # TODO: what to do about maxlength==0 ? non-numeric? less than 0? 2101 } 2102 } 2103 2104 # stuff it 2105 if ( ($maxlength % length($fill)) == 0 ) { 2106 # the simple case 2107 $field->value( $fill x ($maxlength/length($fill)) ); 2108 } 2109 else { 2110 # can be improved later 2111 $field->value( substr( $fill x int(($maxlength + length($fill) - 1)/length($fill)), 0, $maxlength ) ); 2112 } 2113 } # for @inputs 2114 2115 return; 2116} 2117 2118 2119=head2 $mech->followable_links() 2120 2121Returns a list of links that Mech can follow. This is only http and 2122https links. 2123 2124=cut 2125 2126sub followable_links { 2127 my $self = shift; 2128 2129 return $self->find_all_links( url_abs_regex => qr{^(?:https?|file)://} ); 2130} 2131 2132 2133=head2 $mech->lacks_uncapped_inputs( [$comment] ) 2134 2135Executes a test to make sure that the current form content has no 2136text input fields that lack the C<maxlength> attribute, and that each 2137C<maxlength> value is a positive integer. The test fails if the current 2138form has such a field, and succeeds otherwise. 2139 2140Checks that all text input fields in the current form specify a maximum 2141input length. Fields for which the concept of input length is irrelevant, 2142and controls that HTML does not allow to be capped (e.g. textarea) 2143are ignored. 2144 2145The inputs in the returned array are descended from HTML::Form::Input. 2146 2147The return is true if the test succeeded, false otherwise. 2148 2149=cut 2150 2151sub lacks_uncapped_inputs { 2152 my $self = shift; 2153 my $comment = shift; 2154 2155 $comment = 'All text inputs should have maxlength attributes' unless defined($comment); 2156 2157 local $Test::Builder::Level = $Test::Builder::Level + 1; 2158 2159 my @uncapped; 2160 2161 my @inputs = $self->grep_inputs( { type => qr/^(?:text|password)$/ } ); 2162 foreach my $field ( @inputs ) { 2163 next if $field->readonly(); 2164 next if $field->disabled(); 2165 2166 if ( not defined($field->{maxlength}) ) { 2167 push( @uncapped, $field->name . ' has no maxlength attribute' ); 2168 next; 2169 } 2170 2171 my $val = $field->{maxlength}; 2172 if ( ($val !~ /^\s*\d+\s*$/) || ($val+0 <= 0) ) { 2173 push( @uncapped, $field->name . qq{ has an invalid maxlength attribute of "$val"} ); 2174 } 2175 } 2176 2177 my $ok = $TB->ok( @uncapped == 0, $comment ); 2178 $TB->diag( $_ ) for @uncapped; 2179 2180 return $ok; 2181} 2182 2183=head1 TODO 2184 2185Add HTML::Tidy capabilities. 2186 2187Other ideas for features are at https://github.com/petdance/test-www-mechanize 2188 2189=head1 AUTHOR 2190 2191Andy Lester, C<< <andy at petdance.com> >> 2192 2193=head1 BUGS 2194 2195Please report any bugs or feature requests to 2196<https://github.com/petdance/test-www-mechanize>. 2197 2198=head1 SUPPORT 2199 2200You can find documentation for this module with the perldoc command. 2201 2202 perldoc Test::WWW::Mechanize 2203 2204You can also look for information at: 2205 2206=over 4 2207 2208=item * Bug tracker 2209 2210L<https://github.com/petdance/test-www-mechanize> 2211 2212=item * CPAN Ratings 2213 2214L<http://cpanratings.perl.org/d/Test-WWW-Mechanize> 2215 2216=item * Search CPAN 2217 2218L<http://search.cpan.org/dist/Test-WWW-Mechanize> 2219 2220=back 2221 2222=head1 ACKNOWLEDGEMENTS 2223 2224Thanks to 2225@marderh, 2226Eric A. Zarko, 2227@moznion, 2228Robert Stone, 2229@tynovsky, 2230Jerry Gay, 2231Jonathan "Duke" Leto, 2232Philip G. Potter, 2233Niko Tyni, 2234Greg Sheard, 2235Michael Schwern, 2236Mark Blackman, 2237Mike O'Regan, 2238Shawn Sorichetti, 2239Chris Dolan, 2240Matt Trout, 2241MATSUNO Tokuhiro, 2242and Pete Krawczyk for patches. 2243 2244=head1 COPYRIGHT & LICENSE 2245 2246Copyright 2004-2020 Andy Lester. 2247 2248This library is free software; you can redistribute it and/or modify it 2249under the terms of the Artistic License version 2.0. 2250 2251=cut 2252 22531; # End of Test::WWW::Mechanize 2254