local-lib5/lib/perl5/Test/WWW/Mechanize.pm

   1 package Test::WWW::Mechanize;
   2
   3 use strict;
   4 use warnings;
   5
   6 =head1 NAME
   7
   8 Test::WWW::Mechanize - Testing-specific WWW::Mechanize subclass
   9
  10 =head1 VERSION
  11
  12 Version 1.24
  13
  14 =cut
  15
  16 our $VERSION = '1.24';
  17
  18 =head1 SYNOPSIS
  19
  20 Test::WWW::Mechanize is a subclass of L<WWW::Mechanize> that incorporates
  21 features 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->content_contains( "Andy Lester", "My name somewhere" );
  31     $mech->content_like( qr/(cpan|perl)\.org/, "Link to perl.org or CPAN" );
  32
  33 This 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, "Andy Lester" ) >= 0, "My name somewhere" );
  44     like( $mech->content, qr/(cpan|perl)\.org/, "Link to perl.org or CPAN" );
  45
  46 but has nicer diagnostics if they fail.
  47
  48 Default 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
  57 results in
  58
  59     ok - Got 'http://petdance.com/' ok
  60     ok - Base is 'http://petdance.com/'
  61     ok - Title is 'Invoice Status'
  62     ok - Content contains 'Andy Lester'
  63     ok - Content is like '(?-xism:(cpan|perl)\.org)'
  64
  65 =cut
  66
  67 use WWW::Mechanize ();
  68 use Test::LongString;
  69 use Test::Builder ();
  70 use Carp ();
  71 use Carp::Assert::More;
  72
  73 use base 'WWW::Mechanize';
  74
  75 my $Test = Test::Builder->new();
  76
  77
  78 =head1 CONSTRUCTOR
  79
  80 =head2 new( %args )
  81
  82 Behaves like, and calls, L<WWW::Mechanize>'s C<new> method.  Any parms
  83 passed in get passed to WWW::Mechanize's constructor.
  84
  85 You can pass in C<< autolint => 1 >> to make Test::WWW::Mechanize
  86 automatically run HTML::Lint after any of the following methods are
  87 called.
  88
  89 =over
  90
  91 =item * get_ok()
  92
  93 =back
  94
  95 and will eventually do the same after any of the following:
  96
  97 =over
  98
  99 =item * post_ok()
 100
 101 =item * back_ok()
 102
 103 =item * submit_form_ok()
 104
 105 =item * follow_link_ok()
 106
 107 =item * click_ok()
 108
 109 =back
 110
 111 This means you no longerhave to do the following:
 112
 113     my $mech = Test::WWW::Mechanize->new();
 114     $mech->get_ok( $url, 'Fetch the intro page' );
 115     $mech->html_lint_ok( 'Intro page looks OK' );
 116
 117 and can simply do
 118
 119     my $mech = Test::WWW::Mechanize->new( autolint => 1 );
 120     $mech->get_ok( $url, 'Fetch the intro page' );
 121
 122 The C<< $mech->get_ok() >> only counts as one test in the test count.  Both the
 123 main IO operation and the linting must pass for the entire test to pass.
 124
 125 =cut
 126
 127 sub new {
 128     my $class = shift;
 129
 130     my %args = (
 131         agent => "Test-WWW-Mechanize/$VERSION",
 132         @_
 133     );
 134
 135     my $autolint = delete $args{autolint};
 136
 137     my $self = $class->SUPER::new( %args );
 138
 139     $self->{autolint} = $autolint;
 140
 141     return $self;
 142 }
 143
 144 =head1 METHODS: HTTP VERBS
 145
 146 =head2 $mech->get_ok($url, [ \%LWP_options ,] $desc)
 147
 148 A wrapper around WWW::Mechanize's get(), with similar options, except
 149 the second argument needs to be a hash reference, not a hash. Like
 150 well-behaved C<*_ok()> functions, it returns true if the test passed,
 151 or false if not.
 152
 153 A default description of "GET $url" is used if none if provided.
 154
 155 =cut
 156
 157 sub get_ok {
 158     my $self = shift;
 159     my $url = shift;
 160
 161     my $desc;
 162     my %opts;
 163
 164     if ( @_ ) {
 165         my $flex = shift; # The flexible argument
 166
 167         if ( !defined( $flex ) ) {
 168             $desc = shift;
 169         }
 170         elsif ( ref $flex eq 'HASH' ) {
 171             %opts = %{$flex};
 172             $desc = shift;
 173         }
 174         elsif ( ref $flex eq 'ARRAY' ) {
 175             %opts = @{$flex};
 176             $desc = shift;
 177         }
 178         else {
 179             $desc = $flex;
 180         }
 181     } # parms left
 182
 183     $self->get( $url, %opts );
 184     my $ok = $self->success;
 185
 186     if ( not defined $desc ) {
 187         $url = $url->url if ref($url) eq 'WWW::Mechanize::Link';
 188         $desc = "GET $url";
 189     }
 190
 191     $ok = $self->_maybe_lint( $ok, $desc );
 192
 193     return $ok;
 194 }
 195
 196 sub _maybe_lint {
 197     my $self = shift;
 198     my $ok   = shift;
 199     my $desc = shift;
 200
 201     local $Test::Builder::Level = $Test::Builder::Level + 1;
 202
 203     if ( $ok ) {
 204         if ( $self->is_html && $self->{autolint} ) {
 205             $ok = $self->_lint_content_ok( $desc );
 206         }
 207         else {
 208             $Test->ok( $ok, $desc );
 209         }
 210     }
 211     else {
 212         $Test->ok( $ok, $desc );
 213         $Test->diag( $self->status );
 214         $Test->diag( $self->response->message ) if $self->response;
 215     }
 216
 217     return $ok;
 218 }
 219
 220 =head2 $mech->head_ok($url, [ \%LWP_options ,] $desc)
 221
 222 A wrapper around WWW::Mechanize's head(), with similar options, except
 223 the second argument needs to be a hash reference, not a hash. Like
 224 well-behaved C<*_ok()> functions, it returns true if the test passed,
 225 or false if not.
 226
 227 A default description of "HEAD $url" is used if none if provided.
 228
 229 =cut
 230
 231 sub head_ok {
 232     my $self = shift;
 233     my $url = shift;
 234
 235     my $desc;
 236     my %opts;
 237
 238     if ( @_ ) {
 239         my $flex = shift; # The flexible argument
 240
 241         if ( !defined( $flex ) ) {
 242             $desc = shift;
 243         }
 244         elsif ( ref $flex eq 'HASH' ) {
 245             %opts = %{$flex};
 246             $desc = shift;
 247         }
 248        elsif ( ref $flex eq 'ARRAY' ) {
 249             %opts = @{$flex};
 250             $desc = shift;
 251         }
 252         else {
 253             $desc = $flex;
 254         }
 255     } # parms left
 256
 257     $self->head( $url, %opts );
 258     my $ok = $self->success;
 259
 260     if ( not defined $desc ) {
 261         $url = $url->url if ref($url) eq 'WWW::Mechanize::Link';
 262         $desc = "HEAD $url";
 263     }
 264     $Test->ok( $ok, $desc );
 265     if ( !$ok ) {
 266         $Test->diag( $self->status );
 267         $Test->diag( $self->response->message ) if $self->response;
 268     }
 269
 270     return $ok;
 271 }
 272
 273 =head2 $mech->post_ok( $url, [ \%LWP_options ,] $desc )
 274
 275 A wrapper around WWW::Mechanize's post(), with similar options, except
 276 the second argument needs to be a hash reference, not a hash. Like
 277 well-behaved C<*_ok()> functions, it returns true if the test passed,
 278 or false if not.
 279
 280 A default description of "POST to $url" is used if none if provided.
 281
 282 =cut
 283
 284 sub post_ok {
 285     my $self = shift;
 286     my $url = shift;
 287
 288     my $desc;
 289     my %opts;
 290
 291     if ( @_ ) {
 292         my $flex = shift; # The flexible argument
 293
 294         if ( !defined( $flex ) ) {
 295             $desc = shift;
 296         }
 297         elsif ( ref $flex eq 'HASH' ) {
 298             %opts = %{$flex};
 299             $desc = shift;
 300         }
 301         elsif ( ref $flex eq 'ARRAY' ) {
 302             %opts = @{$flex};
 303             $desc = shift;
 304         }
 305         else {
 306             $desc = $flex;
 307         }
 308     } # parms left
 309
 310     if ( not defined $desc ) {
 311         $url = $url->url if ref($url) eq 'WWW::Mechanize::Link';
 312         $desc = "POST $url";
 313     }
 314     $self->post( $url, \%opts );
 315     my $ok = $self->success;
 316     $Test->ok( $ok, $desc );
 317     if ( !$ok ) {
 318         $Test->diag( $self->status );
 319         $Test->diag( $self->response->message ) if $self->response;
 320     }
 321
 322     return $ok;
 323 }
 324
 325 =head2 $mech->put_ok( $url, [ \%LWP_options ,] $desc )
 326
 327 A wrapper around WWW::Mechanize's put(), with similar options, except
 328 the second argument needs to be a hash reference, not a hash. Like
 329 well-behaved C<*_ok()> functions, it returns true if the test passed,
 330 or false if not.
 331
 332 A default description of "PUT to $url" is used if none if provided.
 333
 334 =cut
 335
 336 sub put_ok {
 337     my $self = shift;
 338     my $url = shift;
 339
 340     my $desc;
 341     my %opts;
 342
 343     if ( @_ ) {
 344         my $flex = shift; # The flexible argument
 345
 346         if ( !defined( $flex ) ) {
 347             $desc = shift;
 348         }
 349         elsif ( ref $flex eq 'HASH' ) {
 350             %opts = %{$flex};
 351             $desc = shift;
 352         }
 353         elsif ( ref $flex eq 'ARRAY' ) {
 354             %opts = @{$flex};
 355             $desc = shift;
 356         }
 357         else {
 358             $desc = $flex;
 359         }
 360     } # parms left
 361
 362     if ( not defined $desc ) {
 363         $url = $url->url if ref($url) eq 'WWW::Mechanize::Link';
 364         $desc = "PUT $url";
 365     }
 366     $self->put( $url, \%opts );
 367     my $ok = $self->success;
 368     $Test->ok( $ok, $desc );
 369     if ( !$ok ) {
 370         $Test->diag( $self->status );
 371         $Test->diag( $self->response->message ) if $self->response;
 372     }
 373
 374     return $ok;
 375 }
 376
 377 =head2 $mech->submit_form_ok( \%parms [, $desc] )
 378
 379 Makes a C<submit_form()> call and executes tests on the results.
 380 The form must be found, and then submitted successfully.  Otherwise,
 381 this test fails.
 382
 383 I<%parms> is a hashref containing the parms to pass to C<submit_form()>.
 384 Note that the parms to C<submit_form()> are a hash whereas the parms to
 385 this function are a hashref.  You have to call this function like:
 386
 387     $agent->submit_form_ok( {n=>3}, "looking for 3rd link" );
 388
 389 As with other test functions, C<$desc> is optional.  If it is supplied
 390 then it will display when running the test harness in verbose mode.
 391
 392 Returns true value if the specified link was found and followed
 393 successfully.  The L<HTTP::Response> object returned by submit_form()
 394 is not available.
 395
 396 =cut
 397
 398 sub submit_form_ok {
 399     my $self = shift;
 400     my $parms = shift || {};
 401     my $desc = shift;
 402
 403     if ( ref $parms ne 'HASH' ) {
 404        Carp::croak 'FATAL: parameters must be given as a hashref';
 405     }
 406
 407     # return from submit_form() is an HTTP::Response or undef
 408     my $response = $self->submit_form( %{$parms} );
 409
 410     my $ok;
 411     my $error;
 412     if ( !$response ) {
 413         $error = 'No matching form found';
 414     }
 415     else {
 416         if ( $response->is_success ) {
 417             $ok = 1;
 418         }
 419         else {
 420             $error = $response->as_string;
 421         }
 422     }
 423
 424     $Test->ok( $ok, $desc );
 425     $Test->diag( $error ) if $error;
 426
 427     return $ok;
 428 }
 429
 430
 431 =head2 $mech->follow_link_ok( \%parms [, $desc] )
 432
 433 Makes a C<follow_link()> call and executes tests on the results.
 434 The link must be found, and then followed successfully.  Otherwise,
 435 this test fails.
 436
 437 I<%parms> is a hashref containing the parms to pass to C<follow_link()>.
 438 Note that the parms to C<follow_link()> are a hash whereas the parms to
 439 this function are a hashref.  You have to call this function like:
 440
 441     $mech->follow_link_ok( {n=>3}, "looking for 3rd link" );
 442
 443 As with other test functions, C<$desc> is optional.  If it is supplied
 444 then it will display when running the test harness in verbose mode.
 445
 446 Returns a true value if the specified link was found and followed
 447 successfully.  The L<HTTP::Response> object returned by follow_link()
 448 is not available.
 449
 450 =cut
 451
 452 sub follow_link_ok {
 453     my $self = shift;
 454     my $parms = shift || {};
 455     my $desc = shift;
 456
 457     if (!defined($desc)) {
 458         my $parms_str = join(', ', map { join('=', $_, $parms->{$_}) } keys(%{$parms}));
 459         $desc = qq{Followed link with "$parms_str"} if !defined($desc);
 460     }
 461
 462     if ( ref $parms ne 'HASH' ) {
 463        Carp::croak 'FATAL: parameters must be given as a hashref';
 464     }
 465
 466     # return from follow_link() is an HTTP::Response or undef
 467     my $response = $self->follow_link( %{$parms} );
 468
 469     my $ok;
 470     my $error;
 471     if ( !$response ) {
 472         $error = 'No matching link found';
 473     }
 474     else {
 475         if ( $response->is_success ) {
 476             $ok = 1;
 477         }
 478         else {
 479             $error = $response->as_string;
 480         }
 481     }
 482
 483     $Test->ok( $ok, $desc );
 484     $Test->diag( $error ) if $error;
 485
 486     return $ok;
 487 }
 488
 489
 490 =head2 click_ok( $button[, $desc] )
 491
 492 Clicks the button named by C<$button>.  An optional C<$desc> can
 493 be given for the test.
 494
 495 =cut
 496
 497 sub click_ok {
 498     my $self   = shift;
 499     my $button = shift;
 500     my $desc   = shift;
 501
 502     my $response = $self->click( $button );
 503     if ( !$response ) {
 504         return $Test->ok( 0, $desc );
 505     }
 506
 507     if ( !$response->is_success ) {
 508         $Test->diag( "Failed test $desc:" );
 509         $Test->diag( $response->as_string );
 510         return $Test->ok( 0, $desc );
 511     }
 512     return $Test->ok( 1, $desc );
 513 }
 514
 515 =head1 METHODS: CONTENT CHECKING
 516
 517 =head2 $mech->html_lint_ok( [$desc] )
 518
 519 Checks the validity of the HTML on the current page.  If the page is not
 520 HTML, then it fails.  The URI is automatically appended to the I<$desc>.
 521
 522 Note that HTML::Lint must be installed for this to work.  Otherwise,
 523 it will blow up.
 524
 525 =cut
 526
 527 sub html_lint_ok {
 528     my $self = shift;
 529     my $desc = shift;
 530
 531     my $uri = $self->uri;
 532     $desc = $desc ? "$desc ($uri)" : $uri;
 533
 534     my $ok;
 535
 536     if ( $self->is_html ) {
 537         $ok = $self->_lint_content_ok( $desc );
 538     }
 539     else {
 540         $ok = $Test->ok( 0, $desc );
 541         $Test->diag( q{This page doesn't appear to be HTML, or didn't get the proper text/html content type returned.} );
 542     }
 543
 544     return $ok;
 545 }
 546
 547 sub _lint_content_ok {
 548     my $self = shift;
 549     my $desc = shift;
 550
 551     local $Test::Builder::Level = $Test::Builder::Level + 1;
 552
 553     if ( not ( eval 'require HTML::Lint' ) ) {
 554         die "Test::WWW::Mechanize can't do linting without HTML::Lint: $@";
 555     }
 556
 557     # XXX Combine with the cut'n'paste version in get_ok()
 558     my $lint = HTML::Lint->new;
 559     $lint->parse( $self->content );
 560
 561     my @errors = $lint->errors;
 562     my $nerrors = @errors;
 563     my $ok;
 564     if ( $nerrors ) {
 565         $ok = $Test->ok( 0, $desc );
 566         $Test->diag( 'HTML::Lint errors for ' . $self->uri );
 567         $Test->diag( $_->as_string ) for @errors;
 568         my $s = $nerrors == 1 ? '' : 's';
 569         $Test->diag( "$nerrors error$s on the page" );
 570     }
 571     else {
 572         $ok = $Test->ok( 1, $desc );
 573     }
 574
 575     return $ok;
 576 }
 577
 578 =head2 $mech->title_is( $str [, $desc ] )
 579
 580 Tells if the title of the page is the given string.
 581
 582     $mech->title_is( "Invoice Summary" );
 583
 584 =cut
 585
 586 sub title_is {
 587     my $self = shift;
 588     my $str = shift;
 589     my $desc = shift;
 590     $desc = qq{Title is "$str"} if !defined($desc);
 591
 592     local $Test::Builder::Level = $Test::Builder::Level + 1;
 593     return is_string( $self->title, $str, $desc );
 594 }
 595
 596 =head2 $mech->title_like( $regex [, $desc ] )
 597
 598 Tells if the title of the page matches the given regex.
 599
 600     $mech->title_like( qr/Invoices for (.+)/
 601
 602 =cut
 603
 604 sub title_like {
 605     my $self = shift;
 606     my $regex = shift;
 607     my $desc = shift;
 608     $desc = qq{Title is like "$regex"} if !defined($desc);
 609
 610     local $Test::Builder::Level = $Test::Builder::Level + 1;
 611     return like_string( $self->title, $regex, $desc );
 612 }
 613
 614 =head2 $mech->title_unlike( $regex [, $desc ] )
 615
 616 Tells if the title of the page matches the given regex.
 617
 618     $mech->title_unlike( qr/Invoices for (.+)/
 619
 620 =cut
 621
 622 sub title_unlike {
 623     my $self = shift;
 624     my $regex = shift;
 625     my $desc = shift;
 626     $desc = qq{Title is unlike "$regex"} if !defined($desc);
 627
 628     local $Test::Builder::Level = $Test::Builder::Level + 1;
 629     return unlike_string( $self->title, $regex, $desc );
 630 }
 631
 632 =head2 $mech->base_is( $str [, $desc ] )
 633
 634 Tells if the base of the page is the given string.
 635
 636     $mech->base_is( "http://example.com/" );
 637
 638 =cut
 639
 640 sub base_is {
 641     my $self = shift;
 642     my $str = shift;
 643     my $desc = shift;
 644     $desc = qq{Base is "$str"} if !defined($desc);
 645
 646     local $Test::Builder::Level = $Test::Builder::Level + 1;
 647     return is_string( $self->base, $str, $desc );
 648 }
 649
 650 =head2 $mech->base_like( $regex [, $desc ] )
 651
 652 Tells if the base of the page matches the given regex.
 653
 654     $mech->base_like( qr{http://example.com/index.php?PHPSESSID=(.+)});
 655
 656 =cut
 657
 658 sub base_like {
 659     my $self = shift;
 660     my $regex = shift;
 661     my $desc = shift;
 662     $desc = qq{Base is like "$regex"} if !defined($desc);
 663
 664     local $Test::Builder::Level = $Test::Builder::Level + 1;
 665     return like_string( $self->base, $regex, $desc );
 666 }
 667
 668 =head2 $mech->base_unlike( $regex [, $desc ] )
 669
 670 Tells if the base of the page matches the given regex.
 671
 672     $mech->base_unlike( qr{http://example.com/index.php?PHPSESSID=(.+)});
 673
 674 =cut
 675
 676 sub base_unlike {
 677     my $self = shift;
 678     my $regex = shift;
 679     my $desc = shift;
 680     $desc = qq{Base is unlike "$regex"} if !defined($desc);
 681
 682     local $Test::Builder::Level = $Test::Builder::Level + 1;
 683     return unlike_string( $self->base, $regex, $desc );
 684 }
 685
 686 =head2 $mech->content_is( $str [, $desc ] )
 687
 688 Tells if the content of the page matches the given string
 689
 690 =cut
 691
 692 sub content_is {
 693     my $self = shift;
 694     my $str = shift;
 695     my $desc = shift;
 696
 697     local $Test::Builder::Level = $Test::Builder::Level + 1;
 698     $desc = qq{Content is "$str"} if !defined($desc);
 699
 700     return is_string( $self->content, $str, $desc );
 701 }
 702
 703 =head2 $mech->content_contains( $str [, $desc ] )
 704
 705 Tells if the content of the page contains I<$str>.
 706
 707 =cut
 708
 709 sub content_contains {
 710     my $self = shift;
 711     my $str = shift;
 712     my $desc = shift;
 713
 714     local $Test::Builder::Level = $Test::Builder::Level + 1;
 715     if ( ref($str) eq 'REGEX' ) {
 716         diag( 'content_contains takes a string, not a regex' );
 717     }
 718     $desc = qq{Content contains "$str"} if !defined($desc);
 719
 720     return contains_string( $self->content, $str, $desc );
 721 }
 722
 723 =head2 $mech->content_lacks( $str [, $desc ] )
 724
 725 Tells if the content of the page lacks I<$str>.
 726
 727 =cut
 728
 729 sub content_lacks {
 730     my $self = shift;
 731     my $str = shift;
 732     my $desc = shift;
 733
 734     local $Test::Builder::Level = $Test::Builder::Level + 1;
 735     if ( ref($str) eq 'REGEX' ) {
 736         diag( 'content_lacks takes a string, not a regex' );
 737     }
 738     $desc = qq{Content lacks "$str"} if !defined($desc);
 739
 740     return lacks_string( $self->content, $str, $desc );
 741 }
 742
 743 =head2 $mech->content_like( $regex [, $desc ] )
 744
 745 Tells if the content of the page matches I<$regex>.
 746
 747 =cut
 748
 749 sub content_like {
 750     my $self = shift;
 751     my $regex = shift;
 752     my $desc = shift;
 753     $desc = qq{Content is like "$regex"} if !defined($desc);
 754
 755     local $Test::Builder::Level = $Test::Builder::Level + 1;
 756     return like_string( $self->content, $regex, $desc );
 757 }
 758
 759 =head2 $mech->content_unlike( $regex [, $desc ] )
 760
 761 Tells if the content of the page does NOT match I<$regex>.
 762
 763 =cut
 764
 765 sub content_unlike {
 766     my $self = shift;
 767     my $regex = shift;
 768     my $desc = shift;
 769     $desc = qq{Content is like "$regex"} if !defined($desc);
 770
 771     local $Test::Builder::Level = $Test::Builder::Level + 1;
 772     return unlike_string( $self->content, $regex, $desc );
 773 }
 774
 775 =head2 $mech->has_tag( $tag, $text [, $desc ] )
 776
 777 Tells if the page has a C<$tag> tag with the given content in its text.
 778
 779 =cut
 780
 781 sub has_tag {
 782     my $self = shift;
 783     my $tag  = shift;
 784     my $text = shift;
 785     my $desc = shift;
 786     $desc = qq{Page has $tag tag with "$text"} if !defined($desc);
 787
 788     my $found = $self->_tag_walk( $tag, sub { $text eq $_[0] } );
 789
 790     return $Test->ok( $found, $desc );
 791 }
 792
 793
 794 =head2 $mech->has_tag_like( $tag, $regex [, $desc ] )
 795
 796 Tells if the page has a C<$tag> tag with the given content in its text.
 797
 798 =cut
 799
 800 sub has_tag_like {
 801     my $self = shift;
 802     my $tag  = shift;
 803     my $regex = shift;
 804     my $desc = shift;
 805     $desc = qq{Page has $tag tag like "$regex"} if !defined($desc);
 806
 807     my $found = $self->_tag_walk( $tag, sub { $_[0] =~ $regex } );
 808
 809     return $Test->ok( $found, $desc );
 810 }
 811
 812
 813 sub _tag_walk {
 814     my $self = shift;
 815     my $tag  = shift;
 816     my $match = shift;
 817
 818     my $p = HTML::TokeParser->new( \($self->content) );
 819
 820     while ( my $token = $p->get_tag( $tag ) ) {
 821         my $tagtext = $p->get_trimmed_text( "/$tag" );
 822         return 1 if $match->( $tagtext );
 823     }
 824     return;
 825 }
 826
 827 =head2 $mech->followable_links()
 828
 829 Returns a list of links that Mech can follow.  This is only http and
 830 https links.
 831
 832 =cut
 833
 834 sub followable_links {
 835     my $self = shift;
 836
 837     return $self->find_all_links( url_abs_regex => qr{^https?://} );
 838 }
 839
 840 =head2 $mech->page_links_ok( [ $desc ] )
 841
 842 Follow all links on the current page and test for HTTP status 200
 843
 844     $mech->page_links_ok('Check all links');
 845
 846 =cut
 847
 848 sub page_links_ok {
 849     my $self = shift;
 850     my $desc = shift;
 851
 852     $desc = 'All links ok' unless defined $desc;
 853
 854     my @links = $self->followable_links();
 855     my @urls = _format_links(\@links);
 856
 857     my @failures = $self->_check_links_status( \@urls );
 858     my $ok = (@failures==0);
 859
 860     $Test->ok( $ok, $desc );
 861     $Test->diag( $_ ) for @failures;
 862
 863     return $ok;
 864 }
 865
 866 =head2 $mech->page_links_content_like( $regex [, $desc ] )
 867
 868 Follow all links on the current page and test their contents for I<$regex>.
 869
 870     $mech->page_links_content_like( qr/foo/,
 871       'Check all links contain "foo"' );
 872
 873 =cut
 874
 875 sub page_links_content_like {
 876     my $self = shift;
 877     my $regex = shift;
 878     my $desc = shift;
 879
 880     $desc = qq{All links are like "$regex"} unless defined $desc;
 881
 882     my $usable_regex=$Test->maybe_regex( $regex );
 883     unless(defined( $usable_regex )) {
 884         my $ok = $Test->ok( 0, 'page_links_content_like' );
 885         $Test->diag(qq{     "$regex" doesn't look much like a regex to me.});
 886         return $ok;
 887     }
 888
 889     my @links = $self->followable_links();
 890     my @urls = _format_links(\@links);
 891
 892     my @failures = $self->_check_links_content( \@urls, $regex );
 893     my $ok = (@failures==0);
 894
 895     $Test->ok( $ok, $desc );
 896     $Test->diag( $_ ) for @failures;
 897
 898     return $ok;
 899 }
 900
 901 =head2 $mech->page_links_content_unlike( $regex [, $desc ] )
 902
 903 Follow all links on the current page and test their contents do not
 904 contain the specified regex.
 905
 906     $mech->page_links_content_unlike(qr/Restricted/,
 907       'Check all links do not contain Restricted');
 908
 909 =cut
 910
 911 sub page_links_content_unlike {
 912     my $self = shift;
 913     my $regex = shift;
 914     my $desc = shift;
 915     $desc = "All links are unlike '$regex'" if !defined($desc);
 916
 917     my $usable_regex=$Test->maybe_regex( $regex );
 918     unless(defined( $usable_regex )) {
 919         my $ok = $Test->ok( 0, 'page_links_content_unlike' );
 920         $Test->diag(qq{     "$regex" doesn't look much like a regex to me.});
 921         return $ok;
 922     }
 923
 924     my @links = $self->followable_links();
 925     my @urls = _format_links(\@links);
 926
 927     my @failures = $self->_check_links_content( \@urls, $regex, 'unlike' );
 928     my $ok = (@failures==0);
 929
 930     $Test->ok( $ok, $desc );
 931     $Test->diag( $_ ) for @failures;
 932
 933     return $ok;
 934 }
 935
 936 =head2 $mech->links_ok( $links [, $desc ] )
 937
 938 Follow specified links on the current page and test for HTTP status
 939 200.  The links may be specified as a reference to an array containing
 940 L<WWW::Mechanize::Link> objects, an array of URLs, or a scalar URL
 941 name.
 942
 943     my @links = $mech->find_all_links( url_regex => qr/cnn\.com$/ );
 944     $mech->links_ok( \@links, 'Check all links for cnn.com' );
 945
 946     my @links = qw( index.html search.html about.html );
 947     $mech->links_ok( \@links, 'Check main links' );
 948
 949     $mech->links_ok( 'index.html', 'Check link to index' );
 950
 951 =cut
 952
 953 sub links_ok {
 954     my $self = shift;
 955     my $links = shift;
 956     my $desc = shift;
 957
 958     my @urls = _format_links( $links );
 959     $desc = _default_links_desc(\@urls, 'are ok') unless defined $desc;
 960     my @failures = $self->_check_links_status( \@urls );
 961     my $ok = (@failures == 0);
 962
 963     $Test->ok( $ok, $desc );
 964     $Test->diag( $_ ) for @failures;
 965
 966     return $ok;
 967 }
 968
 969 =head2 $mech->link_status_is( $links, $status [, $desc ] )
 970
 971 Follow specified links on the current page and test for HTTP status
 972 passed.  The links may be specified as a reference to an array
 973 containing L<WWW::Mechanize::Link> objects, an array of URLs, or a
 974 scalar URL name.
 975
 976     my @links = $mech->followable_links();
 977     $mech->link_status_is( \@links, 403,
 978       'Check all links are restricted' );
 979
 980 =cut
 981
 982 sub link_status_is {
 983     my $self = shift;
 984     my $links = shift;
 985     my $status = shift;
 986     my $desc = shift;
 987
 988     my @urls = _format_links( $links );
 989     $desc = _default_links_desc(\@urls, "have status $status") if !defined($desc);
 990     my @failures = $self->_check_links_status( \@urls, $status );
 991     my $ok = (@failures == 0);
 992
 993     $Test->ok( $ok, $desc );
 994     $Test->diag( $_ ) for @failures;
 995
 996     return $ok;
 997 }
 998
 999 =head2 $mech->link_status_isnt( $links, $status [, $desc ] )
1000
1001 Follow specified links on the current page and test for HTTP status
1002 passed.  The links may be specified as a reference to an array
1003 containing L<WWW::Mechanize::Link> objects, an array of URLs, or a
1004 scalar URL name.
1005
1006     my @links = $mech->followable_links();
1007     $mech->link_status_isnt( \@links, 404,
1008       'Check all links are not 404' );
1009
1010 =cut
1011
1012 sub link_status_isnt {
1013     my $self = shift;
1014     my $links = shift;
1015     my $status = shift;
1016     my $desc = shift;
1017
1018     my @urls = _format_links( $links );
1019     $desc = _default_links_desc(\@urls, "do not have status $status") if !defined($desc);
1020     my @failures = $self->_check_links_status( \@urls, $status, 'isnt' );
1021     my $ok = (@failures == 0);
1022
1023     $Test->ok( $ok, $desc );
1024     $Test->diag( $_ ) for @failures;
1025
1026     return $ok;
1027 }
1028
1029
1030 =head2 $mech->link_content_like( $links, $regex [, $desc ] )
1031
1032 Follow specified links on the current page and test the resulting
1033 content of each against I<$regex>.  The links may be specified as a
1034 reference to an array containing L<WWW::Mechanize::Link> objects, an
1035 array of URLs, or a scalar URL name.
1036
1037     my @links = $mech->followable_links();
1038     $mech->link_content_like( \@links, qr/Restricted/,
1039         'Check all links are restricted' );
1040
1041 =cut
1042
1043 sub link_content_like {
1044     my $self = shift;
1045     my $links = shift;
1046     my $regex = shift;
1047     my $desc = shift;
1048
1049     my $usable_regex=$Test->maybe_regex( $regex );
1050     unless(defined( $usable_regex )) {
1051         my $ok = $Test->ok( 0, 'link_content_like' );
1052         $Test->diag(qq{     "$regex" doesn't look much like a regex to me.});
1053         return $ok;
1054     }
1055
1056     my @urls = _format_links( $links );
1057     $desc = _default_links_desc(\@urls, "are like '$regex'") if !defined($desc);
1058     my @failures = $self->_check_links_content( \@urls, $regex );
1059     my $ok = (@failures == 0);
1060
1061     $Test->ok( $ok, $desc );
1062     $Test->diag( $_ ) for @failures;
1063
1064     return $ok;
1065 }
1066
1067 =head2 $mech->link_content_unlike( $links, $regex [, $desc ] )
1068
1069 Follow specified links on the current page and test that the resulting
1070 content of each does not match I<$regex>.  The links may be specified as a
1071 reference to an array containing L<WWW::Mechanize::Link> objects, an array
1072 of URLs, or a scalar URL name.
1073
1074     my @links = $mech->followable_links();
1075     $mech->link_content_unlike( \@links, qr/Restricted/,
1076       'No restricted links' );
1077
1078 =cut
1079
1080 sub link_content_unlike {
1081     my $self = shift;
1082     my $links = shift;
1083     my $regex = shift;
1084     my $desc = shift;
1085
1086     my $usable_regex=$Test->maybe_regex( $regex );
1087     unless(defined( $usable_regex )) {
1088         my $ok = $Test->ok( 0, 'link_content_unlike' );
1089         $Test->diag(qq{     "$regex" doesn't look much like a regex to me.});
1090         return $ok;
1091     }
1092
1093     my @urls = _format_links( $links );
1094     $desc = _default_links_desc(\@urls, qq{are not like "$regex"}) if !defined($desc);
1095     my @failures = $self->_check_links_content( \@urls, $regex, 'unlike' );
1096     my $ok = (@failures == 0);
1097
1098     $Test->ok( $ok, $desc );
1099     $Test->diag( $_ ) for @failures;
1100
1101     return $ok;
1102 }
1103
1104 # Create a default description for the link_* methods, including the link count.
1105 sub _default_links_desc {
1106     my ($urls, $desc_suffix) = @_;
1107     my $url_count = scalar(@{$urls});
1108     return sprintf( '%d link%s %s', $url_count, $url_count == 1 ? '' : 's', $desc_suffix );
1109 }
1110
1111 # This actually performs the status check of each url.
1112 sub _check_links_status {
1113     my $self = shift;
1114     my $urls = shift;
1115     my $status = shift || 200;
1116     my $test = shift || 'is';
1117
1118     # Create a clone of the $mech used during the test as to not disrupt
1119     # the original.
1120     my $mech = $self->clone();
1121
1122     my @failures;
1123
1124     for my $url ( @{$urls} ) {
1125         if ( $mech->follow_link( url => $url ) ) {
1126             if ( $test eq 'is' ) {
1127                 push( @failures, $url ) unless $mech->status() == $status;
1128             }
1129             else {
1130                 push( @failures, $url ) unless $mech->status() != $status;
1131             }
1132             $mech->back();
1133         }
1134         else {
1135             push( @failures, $url );
1136         }
1137     } # for
1138
1139     return @failures;
1140 }
1141
1142 # This actually performs the content check of each url.
1143 sub _check_links_content {
1144     my $self = shift;
1145     my $urls = shift;
1146     my $regex = shift || qr/<html>/;
1147     my $test = shift || 'like';
1148
1149     # Create a clone of the $mech used during the test as to not disrupt
1150     # the original.
1151     my $mech = $self->clone();
1152
1153     my @failures;
1154     for my $url ( @{$urls} ) {
1155         if ( $mech->follow_link( url => $url ) ) {
1156             my $content=$mech->content();
1157             if ( $test eq 'like' ) {
1158                 push( @failures, $url ) unless $content=~/$regex/;
1159             }
1160             else {
1161                 push( @failures, $url ) unless $content!~/$regex/;
1162             }
1163             $mech->back();
1164         }
1165         else {
1166             push( @failures, $url );
1167         }
1168     } # for
1169
1170     return @failures;
1171 }
1172
1173 # Create an array of urls to match for mech to follow.
1174 sub _format_links {
1175     my $links = shift;
1176
1177     my @urls;
1178     if (ref($links) eq 'ARRAY') {
1179         if (defined($$links[0])) {
1180             if (ref($$links[0]) eq 'WWW::Mechanize::Link') {
1181                 @urls = map { $_->url() } @{$links};
1182             }
1183             else {
1184                 @urls = @{$links};
1185             }
1186         }
1187     }
1188     else {
1189         push(@urls,$links);
1190     }
1191     return @urls;
1192 }
1193
1194 =head2 $mech->stuff_inputs( [\%options] )
1195
1196 Finds all free-text input fields (text, textarea, and password) in the
1197 current form and fills them to their maximum length in hopes of finding
1198 application code that can't handle it.  Fields with no maximum length
1199 and all textarea fields are set to 66000 bytes, which will often be
1200 enough to overflow the data's eventual recepticle.
1201
1202 There is no return value.
1203
1204 If there is no current form then nothing is done.
1205
1206 The hashref $options can contain the following keys:
1207
1208 =over
1209
1210 =item * ignore
1211
1212 hash value is arrayref of field names to not touch, e.g.:
1213
1214     $mech->stuff_inputs( {
1215         ignore => [qw( specialfield1 specialfield2 )],
1216     } );
1217
1218 =item * fill
1219
1220 hash value is default string to use when stuffing fields.  Copies
1221 of the string are repeated up to the max length of each field.  E.g.:
1222
1223     $mech->stuff_inputs( {
1224         fill => '@'  # stuff all fields with something easy to recognize
1225     } );
1226
1227 =item * specs
1228
1229 hash value is arrayref of hashrefs with which you can pass detailed
1230 instructions about how to stuff a given field.  E.g.:
1231
1232     $mech->stuff_inputs( {
1233         specs=>{
1234             # Some fields are datatype-constrained.  It's most common to
1235             # want the field stuffed with valid data.
1236             widget_quantity => { fill=>'9' },
1237             notes => { maxlength=>2000 },
1238         }
1239     } );
1240
1241 The specs allowed are I<fill> (use this fill for the field rather than
1242 the default) and I<maxlength> (use this as the field's maxlength instead
1243 of any maxlength specified in the HTML).
1244
1245 =back
1246
1247 =cut
1248
1249 sub stuff_inputs {
1250     my $self = shift;
1251
1252     my $options = shift || {};
1253     assert_isa( $options, 'HASH' );
1254     assert_in( $_, ['ignore', 'fill', 'specs'] ) foreach ( keys %{$options} );
1255
1256     # set up the fill we'll use unless a field overrides it
1257     my $default_fill = '@';
1258     if ( exists $options->{fill} && defined $options->{fill} && length($options->{fill}) > 0 ) {
1259         $default_fill = $options->{fill};
1260     }
1261
1262     # fields in the form to not stuff
1263     my $ignore = {};
1264     if ( exists $options->{ignore} ) {
1265         assert_isa( $options->{ignore}, 'ARRAY' );
1266         $ignore = { map {($_, 1)} @{$options->{ignore}} };
1267     }
1268
1269     my $specs = {};
1270     if ( exists $options->{specs} ) {
1271         assert_isa( $options->{specs}, 'HASH' );
1272         $specs = $options->{specs};
1273         foreach my $field_name ( keys %{$specs} ) {
1274             assert_isa( $specs->{$field_name}, 'HASH' );
1275             assert_in( $_, ['fill', 'maxlength'] ) foreach ( keys %{$specs->{$field_name}} );
1276         }
1277     }
1278
1279     my @inputs = $self->find_all_inputs( type_regex => qr/^(text|textarea|password)$/ );
1280
1281     foreach my $field ( @inputs ) {
1282         next if $field->readonly();
1283         next if $field->disabled();  # TODO: HTML::Form::TextInput allows setting disabled--allow it here?
1284
1285         my $name = $field->name();
1286
1287         # skip if it's one of the fields to ignore
1288         next if exists $ignore->{ $name };
1289
1290         # fields with no maxlength will get this many characters
1291         my $maxlength = 66000;
1292
1293         # maxlength from the HTML
1294         if ( $field->type ne 'textarea' ) {
1295             if ( exists $field->{maxlength} ) {
1296                 $maxlength = $field->{maxlength};
1297                 # TODO: what to do about maxlength==0 ?  non-numeric? less than 0 ?
1298             }
1299         }
1300
1301         my $fill = $default_fill;
1302
1303         if ( exists $specs->{$name} ) {
1304             # process the per-field info
1305
1306             if ( exists $specs->{$name}->{fill} && defined $specs->{$name}->{fill} && length($specs->{$name}->{fill}) > 0 ) {
1307                 $fill = $specs->{$name}->{fill};
1308             }
1309
1310             # maxlength override from specs
1311             if ( exists $specs->{$name}->{maxlength} && defined $specs->{$name}->{maxlength} ) {
1312                 $maxlength = $specs->{$name}->{maxlength};
1313                 # TODO: what to do about maxlength==0 ?  non-numeric? less than 0?
1314             }
1315         }
1316
1317         # stuff it
1318         if ( ($maxlength % length($fill)) == 0 ) {
1319             # the simple case
1320             $field->value( $fill x ($maxlength/length($fill)) );
1321         }
1322         else {
1323             # can be improved later
1324             $field->value( substr( $fill x int(($maxlength + length($fill) - 1)/length($fill)), 0, $maxlength ) );
1325         }
1326     } # for @inputs
1327
1328     return;
1329 }
1330
1331 =head1 TODO
1332
1333 Add HTML::Tidy capabilities.
1334
1335 Add a broken image check.
1336
1337 =head1 AUTHOR
1338
1339 Andy Lester, C<< <andy at petdance.com> >>
1340
1341 =head1 BUGS
1342
1343 Please report any bugs or feature requests to
1344 <http://code.google.com/p/www-mechanize/issues/list>.  I will be
1345 notified, and then you'll automatically be notified of progress on
1346 your bug as I make changes.
1347
1348 =head1 SUPPORT
1349
1350 You can find documentation for this module with the perldoc command.
1351
1352     perldoc Test::WWW::Mechanize
1353
1354 You can also look for information at:
1355
1356 =over 4
1357
1358 =item * Google Code bug tracker
1359
1360 L<http://code.google.com/p/www-mechanize/issues/list>
1361
1362 Please B<do not use> the old queues for WWW::Mechanize and
1363 Test::WWW::Mechanize at
1364 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-WWW-Mechanize>
1365
1366 =item * AnnoCPAN: Annotated CPAN documentation
1367
1368 L<http://annocpan.org/dist/Test-WWW-Mechanize>
1369
1370 =item * CPAN Ratings
1371
1372 L<http://cpanratings.perl.org/d/Test-WWW-Mechanize>
1373
1374 =item * Search CPAN
1375
1376 L<http://search.cpan.org/dist/Test-WWW-Mechanize>
1377
1378 =back
1379
1380 =head1 ACKNOWLEDGEMENTS
1381
1382 Thanks to
1383 Greg Sheard,
1384 Michael Schwern,
1385 Mark Blackman,
1386 Mike O'Regan,
1387 Shawn Sorichetti,
1388 Chris Dolan,
1389 Matt Trout,
1390 MATSUNO Tokuhiro,
1391 and Pete Krawczyk for patches.
1392
1393 =head1 COPYRIGHT & LICENSE
1394
1395 Copyright 2004-2008 Andy Lester, all rights reserved.
1396
1397 This program is free software; you can redistribute it and/or modify it
1398 under the same terms as Perl itself.
1399
1400 =cut
1401
1402 1; # End of Test::WWW::Mechanize