1 2package Test::WWW::Mechanize::CGIApp; 3 4use strict; 5use warnings; 6 7# TODO use Test::WWW::Mechanize; 8use base 'Test::WWW::Mechanize'; 9 10use HTTP::Request::AsCGI; 11 12our $VERSION = "0.05"; 13 14sub new { 15 my ($class, %cnf) = @_; 16 my $self; 17 my $app; 18 19 if (exists($cnf{app})) { 20 $app = delete $cnf{app}; 21 } 22 23 $self = $class->SUPER::new(%cnf); 24 25 $self->app( $app ) if ($app); 26 return $self; 27} 28 29sub app { 30 my $self = shift; 31 32 if (@_) { 33 $self->{_app} = shift; 34 } 35 return $self->{_app}; 36} 37 38# copied from Test::WWW:Mechanize::Catalyst and slightly localized. 39sub _make_request { 40 my ( $self, $request ) = @_; 41 $request = _cleanup_request($request); 42 $self->cookie_jar->add_cookie_header($request) if $self->cookie_jar; 43 44 my $response = $self->_do_request( $request ); 45 46 $response->header( 'Content-Base', $request->uri ); 47 $response->request($request); 48 $self->cookie_jar->extract_cookies($response) if $self->cookie_jar; 49 50 # check if that was a redirect 51 if ( $response->header('Location') 52 && $self->redirect_ok( $request, $response ) ) 53 { 54 55 # remember the old response 56 my $old_response = $response; 57 58 # *where* do they want us to redirect to? 59 my $location = $old_response->header('Location'); 60 61 # no-one *should* be returning non-absolute URLs, but if they 62 # are then we'd better cope with it. Let's create a new URI, using 63 # our request as the base. 64 my $uri = URI->new_abs( $location, $request->uri )->as_string; 65 66 # make a new response, and save the old response in it 67 $response = $self->_make_request( HTTP::Request->new( GET => $uri ) ); 68 my $end_of_chain = $response; 69 while ( $end_of_chain->previous ) # keep going till the end 70 { 71 $end_of_chain = $end_of_chain->previous; 72 } # of the chain... 73 $end_of_chain->previous($old_response); # ...and add us to it 74 } 75 76 return $response; 77 } 78 79sub _cleanup_request { 80 my $request = shift; 81 82 $request->uri('http://localhost' . $request->uri()) 83 unless ( $request->uri() =~ m|^http| ); 84 85 return($request); 86} 87 88sub _do_request { 89 my $self = shift; 90 my $request = shift; 91 92 my $cgi = HTTP::Request::AsCGI->new($request, %ENV)->setup; 93 my $app = $self->app(); 94 95 if (defined ($app)) { 96 if (ref $app) { 97 if (ref $app eq 'CODE') { 98 &{$app}; 99 } 100 else { 101 die "The app value is a ref to something that isn't implemented."; 102 } 103 } 104 else { 105 # use eval since the module name isn't a BAREWORD 106 eval "require " . $app; 107 108 if ($app->isa("CGI::Application::Dispatch")) { 109 $app->dispatch(); 110 } 111 elsif ($app->isa("CGI::Application")) { 112 my $app = $app->new(); 113 $app->run(); 114 } 115 else { 116 die "Unable to use the value of app."; 117 } 118 } 119 } 120 else { 121 die "App was not defined."; 122 } 123 124 return $cgi->restore->response; 125} 126 127 1281; 129 130__END__ 131 132=pod 133 134=head1 NAME 135 136Test::WWW::Mechanize::CGIApp - Test::WWW::Mechanize for CGI::Application 137 138=head1 SYNOPSIS 139 140 # We're in a t/*.t test script... 141 use Test::WWW::Mechanize::CGIApp; 142 143 my $mech = Test::WWW::Mechanize::CGIApp->new; 144 145 # test a class that uses CGI::Application calling semantics. 146 # (in this case we'll new up an instance of the app and call 147 # its ->run() method) 148 # 149 $mech->app("My::WebApp"); 150 $mech->get_ok("?rm=my_run_mode&arg1=1&arg2=42"); 151 152 # test a class that uses CGI::Application::Dispatch 153 # to locate the run_mode 154 # (in this case we'll just call the ->dispatch() class method). 155 # 156 my $dispatched_mech = Test::WWW::Mechanize::CGIApp->new; 157 $dispatched_mech->app("My::DispatchApp"); 158 $mech->get_ok("/WebApp/my_run_mode?arg1=1&arg2=42"); 159 160 # create an anonymous sub that this class will use to 161 # handle the request. 162 # 163 # this could be useful if you need to do something novel 164 # after creating an instance of your class (e.g. the 165 # fiddle_with_stuff() below) or maybe you have a unique 166 # way to get the app to run. 167 # 168 my $custom_mech = Test::WWW::Mechanize::CGIApp->new; 169 $custom_mech->app( 170 sub { 171 require "My::WebApp"; 172 my $app = My::WebApp->new(); 173 $app->fiddle_with_stuff(); 174 $app->run(); 175 }); 176 $mech->get_ok("?rm=my_run_mode&arg1=1&arg2=42"); 177 178 # at this point you can play with all kinds of cool 179 # Test::WWW::Mechanize testing methods. 180 is($mech->ct, "text/html"); 181 $mech->title_is("Root", "On the root page"); 182 $mech->content_contains("This is the root page", "Correct content"); 183 $mech->follow_link_ok({text => 'Hello'}, "Click on Hello"); 184 # ... and all other Test::WWW::Mechanize methods 185 186=head1 DESCRIPTION 187 188This package makes testing CGIApp based modules fast and easy. It takes 189advantage of L<Test::WWW::Mechanize> to provide functions for common 190web testing scenarios. For example: 191 192 $mech->get_ok( $page ); 193 $mech->title_is( "Invoice Status", 194 "Make sure we're on the invoice page" ); 195 $mech->content_contains( "Andy Lester", "My name somewhere" ); 196 $mech->content_like( qr/(cpan|perl)\.org/, 197 "Link to perl.org or CPAN" ); 198 199For applications that inherit from CGI::Application it will handle 200requests by creating a new instance of the class and calling its 201C<run> method. For applications that use CGI::Application::Dispatch 202it will call the C<dispatch> class method. If neither of these 203options are the right thing, you can set a reference to a sub that 204will be used to handle the request. 205 206This module supports cookies automatically. 207 208Check out L<Test::WWW::Mechanize> for more information about all of 209the cool things you can test! 210 211=head1 CONSTRUCTOR 212 213=head2 new 214 215Behaves like, and calls, L<Test::WWW::Mechanize>'s C<new> method. It 216optionally uses an "app" parameter (see below), any other 217parameters get passed to Test::WWW::Mechanize's constructor. Note 218that you can either pass the name of the CGI::Application into the 219constructor using the "app" parameter or set it later using the C<app> 220method. 221 222 use Test::WWW::Mechanize::CGIApp; 223 my $mech = Test::WWW::Mechanize::CGIApp->new; 224 225 # or 226 227 my $mech = Test::WWW::Mechanize::CGIApp->new(app => 'TestApp'); 228 229=head1 METHODS 230 231=head2 $mech->app($app_handler) 232 233This method provides a mechanism for informing 234Test::WWW::Mechanize::CGIApp how it should go about executing your 235run_mode. If you set it to the name of a class, then it will load the 236class and either create an instance and ->run() it (if it's 237CGI::Application based), invoke the ->dispatch() method if it's 238CGI::Application::Dispatch based, or call the supplied anonymous 239subroutine and let it do all of the heavy lifting. 240 241=head1 SEE ALSO 242 243Related modules which may be of interest: L<Test::WWW::Mechanize>, 244L<WWW::Mechanize>. 245 246Various implementation tricks came from 247L<Test::WWW::Mechanize::Catalyst>. 248 249=head1 AUTHOR 250 251George Hartzell, C<< <hartzell@alerce.com> >> 252 253based on L<Test::WWW::Mechanize::Catalyst> by Leon Brocard, C<< <acme@astray.com> >>. 254 255=head1 COPYRIGHT 256 257Copyright (C) 2007, George Hartzell 258 259This module is free software; you can redistribute it or modify it 260under the same terms as Perl itself. 261