git.maemo.org Git - pkg-perl/blob - deb-src/libwww-mechanize-perl/libwww-mechanize-perl-1.34/t/local/back.t

   1 #!perl
   2
   3 use warnings;
   4 use strict;
   5 use Test::More tests => 38;
   6 use lib 't/local';
   7 use LocalServer;
   8 use HTTP::Daemon;
   9 use HTTP::Response;
  10
  11
  12 =head1 NAME
  13
  14 =head1 SYNOPSIS
  15
  16 This tests Mech's Back "button". Tests were converted from t/live/back.t,
  17 and subsequently enriched to deal with RT ticket #8109.
  18
  19 =cut
  20
  21 BEGIN {
  22     delete @ENV{ grep { lc eq 'http_proxy' } keys %ENV };
  23     delete @ENV{ qw( IFS CDPATH ENV BASH_ENV ) };
  24     use_ok( 'WWW::Mechanize' );
  25 }
  26
  27 my $mech = WWW::Mechanize->new(cookie_jar => {});
  28 isa_ok( $mech, 'WWW::Mechanize' );
  29 ok(defined($mech->cookie_jar()),
  30    'this $mech starts with a cookie jar');
  31
  32 my $html = <<'HTML';
  33 <html>
  34 <head><title>%s</title></head>
  35 <body>Whatever.
  36 <a href="images/">Images</a>
  37 <a href="/scripts">Scripts</a>
  38 <a href="/ports/">Ports</a>
  39 <a href="modules/">Modules</a>
  40 <form action="/search.cgi">
  41 <input type="text" name="q">
  42 <input type="submit">
  43 </form>
  44 </body>
  45 </html>
  46 HTML
  47
  48 my $server = LocalServer->spawn( html => $html );
  49 isa_ok( $server, 'LocalServer' );
  50
  51 $mech->get($server->url);
  52 ok( $mech->success, 'Fetched OK' );
  53
  54 my $first_base = $mech->base;
  55 my $title = $mech->title;
  56
  57 $mech->follow_link( n=>2 );
  58 ok( $mech->success, 'Followed OK' );
  59
  60 $mech->back();
  61 is( $mech->base, $first_base, 'Did the base get set back?' );
  62 is( $mech->title, $title, 'Title set back?' );
  63
  64 $mech->follow_link( text => 'Images' );
  65 ok( $mech->success, 'Followed OK' );
  66
  67 $mech->back();
  68 is( $mech->base, $first_base, 'Did the base get set back?' );
  69 is( $mech->title, $title, 'Title set back?' );
  70
  71 is( scalar @{$mech->{page_stack}}, 0, 'Pre-search check' );
  72 $mech->submit_form(
  73     fields => { 'q' => 'perl' },
  74 );
  75 ok( $mech->success, 'Searched for Perl' );
  76 like( $mech->title, qr/search.cgi/, 'Right page title' );
  77 is( scalar @{$mech->{page_stack}}, 1, 'POST is in the stack' );
  78
  79 $mech->head( $server->url );
  80 ok( $mech->success, 'HEAD succeeded' );
  81 is( scalar @{$mech->{page_stack}}, 1, 'HEAD is not in the stack' );
  82
  83 $mech->back();
  84 ok( $mech->success, 'Back' );
  85 is( $mech->base, $first_base, 'Did the base get set back?' );
  86 is( $mech->title, $title, 'Title set back?' );
  87 is( scalar @{$mech->{page_stack}}, 0, 'Post-search check' );
  88
  89 =head2 Back and misc. internal fields
  90
  91 RT ticket #8109 reported that back() is broken after reload(), and
  92 that the cookie_jar was also damaged by back(). We test for that:
  93 reload() should not alter the back() stack, and the cookie jar should
  94 not be versioned (once a cookie is set, hitting the back button in a
  95 browser does not cause it to go away).
  96
  97 =cut
  98
  99 $mech->follow_link( text => 'Images' );
 100 $mech->reload();
 101 $mech->back();
 102 is($mech->title, $title, 'reload() does not push page to stack' );
 103
 104 ok(defined($mech->cookie_jar()),
 105    '$mech still has a cookie jar after a number of back()');
 106
 107 # Now some other weird stuff. Start with a fresh history by recreating
 108 # $mech.
 109 SKIP: {
 110     eval 'use Test::Memory::Cycle';
 111     skip 'Test::Memory::Cycle not installed', 1 if $@;
 112
 113     memory_cycle_ok( $mech, 'No memory cycles found' );
 114 }
 115
 116 $mech = WWW::Mechanize->new();
 117 isa_ok( $mech, 'WWW::Mechanize' );
 118 $mech->get( $server->url );
 119 ok( $mech->success, 'Got root URL' );
 120
 121 my @links = qw(
 122     /scripts
 123     /ports/
 124     modules/
 125 );
 126
 127 is( scalar @{$mech->{page_stack}}, 0, 'Pre-404 check' );
 128
 129 my $server404 = HTTP::Daemon->new(LocalAddr => 'localhost') or die;
 130 my $server404url = $server404->url;
 131
 132 die 'Cannot fork' if (! defined (my $pid404 = fork()));
 133 END {
 134     local $?;
 135     kill KILL => $pid404; # Extreme prejudice intended, because we do not
 136     # want the global cleanup to be done twice.
 137 }
 138
 139 if (! $pid404) { # Fake HTTP server code: a true 404-compliant server!
 140     while ( my $c = $server404->accept() ) {
 141         while ( $c->get_request() ) {
 142             $c->send_response( new HTTP::Response(404) );
 143             $c->close();
 144         }
 145     }
 146 }
 147
 148 $mech->get($server404url);
 149 is( $mech->status, 404 , '404 check') or
 150     diag( qq{\$server404url=$server404url\n\$mech->content="}, $mech->content, qq{"\n} );
 151
 152 is( scalar @{$mech->{page_stack}}, 1, 'Even 404s get on the stack' );
 153
 154 $mech->back();
 155 is( $mech->uri, $server->url, 'Back from the 404' );
 156 is( scalar @{$mech->{page_stack}}, 0, 'Post-404 check' );
 157
 158 for my $link ( @links ) {
 159     $mech->get( $link );
 160     warn $mech->status() if (! $mech->success());
 161     is( $mech->status, 200, "Get $link" );
 162
 163     $mech->back();
 164     is( $mech->uri, $server->url, "Back from $link" );
 165 }
 166
 167 SKIP: {
 168     eval 'use Test::Memory::Cycle';
 169     skip 'Test::Memory::Cycle not installed', 1 if $@;
 170
 171     memory_cycle_ok( $mech, 'No memory cycles found' );
 172 }
 173
 174