1package Test::WWW::Mechanize::Catalyst; 2 3use Moose; 4 5use Carp qw/croak/; 6require Catalyst::Test; # Do not call import 7use Class::Load qw(load_class is_class_loaded); 8use Encode qw(); 9use HTML::Entities; 10use Test::WWW::Mechanize; 11 12extends 'Test::WWW::Mechanize', 'Moose::Object'; 13 14#use namespace::clean -except => 'meta'; 15 16our $VERSION = '0.62'; 17our $APP_CLASS; 18my $Test = Test::Builder->new(); 19 20has catalyst_app => ( 21 is => 'ro', 22 predicate => 'has_catalyst_app', 23); 24 25has allow_external => ( 26 is => 'rw', 27 isa => 'Bool', 28 default => 0 29); 30 31has host => ( 32 is => 'rw', 33 isa => 'Str', 34 clearer => 'clear_host', 35 predicate => 'has_host', 36); 37 38sub new { 39 my $class = shift; 40 41 my $args = ref $_[0] ? $_[0] : { @_ }; 42 43 # Dont let LWP complain about options for our attributes 44 my %attr_options = map { 45 my $n = $_->init_arg; 46 defined $n && exists $args->{$n} 47 ? ( $n => delete $args->{$n} ) 48 : ( ); 49 } $class->meta->get_all_attributes; 50 51 my $obj = $class->SUPER::new(%$args); 52 my $self = $class->meta->new_object( 53 __INSTANCE__ => $obj, 54 ($APP_CLASS ? (catalyst_app => $APP_CLASS) : () ), 55 %attr_options 56 ); 57 58 $self->BUILDALL; 59 60 61 return $self; 62} 63 64sub BUILD { 65 my ($self) = @_; 66 67 unless ($ENV{CATALYST_SERVER}) { 68 croak "catalyst_app attribute is required unless CATALYST_SERVER env variable is set" 69 unless $self->has_catalyst_app; 70 load_class($self->catalyst_app) 71 unless (is_class_loaded($self->catalyst_app)); 72 } 73} 74 75sub _make_request { 76 my ( $self, $request, $arg, $size, $previous) = @_; 77 78 my $response = $self->_do_catalyst_request($request); 79 $response->header( 'Content-Base', $response->request->uri ) 80 unless $response->header('Content-Base'); 81 82 $self->cookie_jar->extract_cookies($response) if $self->cookie_jar; 83 84 # fail tests under the Catalyst debug screen 85 if ( !$self->{catalyst_debug} 86 && $response->code == 500 87 && $response->content =~ /on Catalyst \d+\.\d+/ ) 88 { 89 my ($error) 90 = ( $response->content =~ /<code class="error">(.*?)<\/code>/s ); 91 $error ||= "unknown error"; 92 decode_entities($error); 93 $Test->diag("Catalyst error screen: $error"); 94 $response->content(''); 95 $response->content_type(''); 96 } 97 98 # NOTE: cargo-culted redirect checking from LWP::UserAgent: 99 $response->previous($previous) if $previous; 100 my $redirects = defined $response->redirects ? $response->redirects : 0; 101 if ($redirects > 0 and $redirects >= $self->max_redirect) { 102 return $self->_redirect_loop_detected($response); 103 } 104 105 # check if that was a redirect 106 if ( $response->header('Location') 107 && $response->is_redirect 108 && $self->redirect_ok( $request, $response ) ) 109 { 110 return $self->_redirect_loop_detected($response) if $self->max_redirect <= 0; 111 112 # TODO: this should probably create the request by cloning the original 113 # request and modifying it as LWP::UserAgent::request does. But for now... 114 115 # *where* do they want us to redirect to? 116 my $location = $response->header('Location'); 117 118 # no-one *should* be returning non-absolute URLs, but if they 119 # are then we'd better cope with it. Let's create a new URI, using 120 # our request as the base. 121 my $uri = URI->new_abs( $location, $request->uri )->as_string; 122 my $referral = HTTP::Request->new( GET => $uri ); 123 return $self->request( $referral, $arg, $size, $response ); 124 } else { 125 $response->{_raw_content} = $response->content; 126 } 127 128 return $response; 129} 130 131sub _redirect_loop_detected { 132 my ( $self, $response ) = @_; 133 $response->header("Client-Warning" => 134 "Redirect loop detected (max_redirect = " . $self->max_redirect . ")"); 135 $response->{_raw_content} = $response->content; 136 return $response; 137} 138 139sub _set_host_header { 140 my ( $self, $request ) = @_; 141 # If there's no Host header, set one. 142 unless ($request->header('Host')) { 143 my $host = $self->has_host 144 ? $self->host 145 : $request->uri->host; 146 $host .= ':'.$request->uri->_port if $request->uri->_port; 147 $request->header('Host', $host); 148 } 149} 150 151sub _do_catalyst_request { 152 my ($self, $request) = @_; 153 154 my $uri = $request->uri; 155 $uri->scheme('http') unless defined $uri->scheme; 156 $uri->host('localhost') unless defined $uri->host; 157 158 $request = $self->prepare_request($request); 159 $self->cookie_jar->add_cookie_header($request) if $self->cookie_jar; 160 161 # Woe betide anyone who unsets CATALYST_SERVER 162 return $self->_do_remote_request($request) 163 if $ENV{CATALYST_SERVER}; 164 165 $self->_set_host_header($request); 166 167 my $res = $self->_check_external_request($request); 168 return $res if $res; 169 170 my @creds = $self->get_basic_credentials( "Basic", $uri ); 171 $request->authorization_basic( @creds ) if @creds; 172 173 require Catalyst; 174 my $response = $Catalyst::VERSION >= 5.89000 ? 175 Catalyst::Test::_local_request($self->{catalyst_app}, $request) : 176 Catalyst::Test::local_request($self->{catalyst_app}, $request); 177 178 179 # LWP would normally do this, but we don't get down that far. 180 $response->request($request); 181 182 return $response 183} 184 185sub _check_external_request { 186 my ($self, $request) = @_; 187 188 # If there's no host then definitley not an external request. 189 $request->uri->can('host_port') or return; 190 191 if ( $self->allow_external && $request->uri->host_port ne 'localhost:80' ) { 192 return $self->SUPER::_make_request($request); 193 } 194 return undef; 195} 196 197sub _do_remote_request { 198 my ($self, $request) = @_; 199 200 my $res = $self->_check_external_request($request); 201 return $res if $res; 202 203 my $server = URI->new( $ENV{CATALYST_SERVER} ); 204 205 if ( $server->path =~ m|^(.+)?/$| ) { 206 my $path = $1; 207 $server->path("$path") if $path; # need to be quoted 208 } 209 210 # the request path needs to be sanitised if $server is using a 211 # non-root path due to potential overlap between request path and 212 # response path. 213 if ($server->path) { 214 # If request path is '/', we have to add a trailing slash to the 215 # final request URI 216 my $add_trailing = $request->uri->path eq '/'; 217 218 my @sp = split '/', $server->path; 219 my @rp = split '/', $request->uri->path; 220 shift @sp;shift @rp; # leading / 221 if (@rp) { 222 foreach my $sp (@sp) { 223 $sp eq $rp[0] ? shift @rp : last 224 } 225 } 226 $request->uri->path(join '/', @rp); 227 228 if ( $add_trailing ) { 229 $request->uri->path( $request->uri->path . '/' ); 230 } 231 } 232 233 $request->uri->scheme( $server->scheme ); 234 $request->uri->host( $server->host ); 235 $request->uri->port( $server->port ); 236 $request->uri->path( $server->path . $request->uri->path ); 237 $self->_set_host_header($request); 238 return $self->SUPER::_make_request($request); 239} 240 241sub import { 242 my ($class, $app) = @_; 243 244 if (defined $app) { 245 load_class($app) 246 unless (is_class_loaded($app)); 247 $APP_CLASS = $app; 248 } 249 250} 251 252 2531; 254 255__END__ 256 257=head1 NAME 258 259Test::WWW::Mechanize::Catalyst - Test::WWW::Mechanize for Catalyst 260 261=head1 SYNOPSIS 262 263 # We're in a t/*.t test script... 264 use Test::WWW::Mechanize::Catalyst; 265 266 # To test a Catalyst application named 'Catty': 267 my $mech = Test::WWW::Mechanize::Catalyst->new(catalyst_app => 'Catty'); 268 269 $mech->get_ok("/"); # no hostname needed 270 is($mech->ct, "text/html"); 271 $mech->title_is("Root", "On the root page"); 272 $mech->content_contains("This is the root page", "Correct content"); 273 $mech->follow_link_ok({text => 'Hello'}, "Click on Hello"); 274 # ... and all other Test::WWW::Mechanize methods 275 276 # White label site testing 277 $mech->host("foo.com"); 278 $mech->get_ok("/"); 279 280=head1 DESCRIPTION 281 282L<Catalyst> is an elegant MVC Web Application Framework. 283L<Test::WWW::Mechanize> is a subclass of L<WWW::Mechanize> that incorporates 284features for web application testing. The L<Test::WWW::Mechanize::Catalyst> 285module meshes the two to allow easy testing of L<Catalyst> applications without 286needing to start up a web server. 287 288Testing web applications has always been a bit tricky, normally 289requiring starting a web server for your application and making real HTTP 290requests to it. This module allows you to test L<Catalyst> web 291applications but does not require a server or issue HTTP 292requests. Instead, it passes the HTTP request object directly to 293L<Catalyst>. Thus you do not need to use a real hostname: 294"http://localhost/" will do. However, this is optional. The following 295two lines of code do exactly the same thing: 296 297 $mech->get_ok('/action'); 298 $mech->get_ok('http://localhost/action'); 299 300Links which do not begin with / or are not for localhost can be handled 301as normal Web requests - this is handy if you have an external 302single sign-on system. You must set allow_external to true for this: 303 304 $mech->allow_external(1); 305 306You can also test a remote server by setting the environment variable 307CATALYST_SERVER; for example: 308 309 $ CATALYST_SERVER=http://example.com/myapp prove -l t 310 311will run the same tests on the application running at 312http://example.com/myapp regardless of whether or not you specify 313http:://localhost for Test::WWW::Mechanize::Catalyst. 314 315Furthermore, if you set CATALYST_SERVER, the server will be regarded 316as a remote server even if your links point to localhost. Thus, you 317can use Test::WWW::Mechanize::Catalyst to test your live webserver 318running on your local machine, if you need to test aspects of your 319deployment environment (for example, configuration options in an 320http.conf file) instead of just the Catalyst request handling. 321 322This makes testing fast and easy. L<Test::WWW::Mechanize> provides 323functions for common web testing scenarios. For example: 324 325 $mech->get_ok( $page ); 326 $mech->title_is( "Invoice Status", "Make sure we're on the invoice page" ); 327 $mech->content_contains( "Andy Lester", "My name somewhere" ); 328 $mech->content_like( qr/(cpan|perl)\.org/, "Link to perl.org or CPAN" ); 329 330This module supports cookies automatically. 331 332To use this module you must pass it the name of the application. See 333the SYNOPSIS above. 334 335Note that Catalyst has a special development feature: the debug 336screen. By default this module will treat responses which are the 337debug screen as failures. If you actually want to test debug screens, 338please use: 339 340 $mech->{catalyst_debug} = 1; 341 342An alternative to this module is L<Catalyst::Test>. 343 344=head1 CONSTRUCTOR 345 346=head2 new 347 348Behaves like, and calls, L<WWW::Mechanize>'s C<new> method. Any params 349passed in get passed to WWW::Mechanize's constructor. Note that we 350need to pass the name of the Catalyst application to the "use": 351 352 use Test::WWW::Mechanize::Catalyst 'Catty'; 353 my $mech = Test::WWW::Mechanize::Catalyst->new; 354 355=head1 METHODS 356 357=head2 allow_external 358 359Links which do not begin with / or are not for localhost can be handled 360as normal Web requests - this is handy if you have an external 361single sign-on system. You must set allow_external to true for this: 362 363 $mech->allow_external(1); 364 365head2 catalyst_app 366 367The name of the Catalyst app which we are testing against. Read-only. 368 369=head2 host 370 371The host value to set the "Host:" HTTP header to, if none is present already in 372the request. If not set (default) then Catalyst::Test will set this to 373localhost:80 374 375=head2 clear_host 376 377Unset the host attribute. 378 379=head2 has_host 380 381Do we have a value set for the host attribute 382 383=head2 $mech->get_ok($url, [ \%LWP_options ,] $desc) 384 385A wrapper around WWW::Mechanize's get(), with similar options, except the 386second argument needs to be a hash reference, not a hash. Returns true or 387false. 388 389=head2 $mech->title_is( $str [, $desc ] ) 390 391Tells if the title of the page is the given string. 392 393 $mech->title_is( "Invoice Summary" ); 394 395=head2 $mech->title_like( $regex [, $desc ] ) 396 397Tells if the title of the page matches the given regex. 398 399 $mech->title_like( qr/Invoices for (.+)/ 400 401=head2 $mech->title_unlike( $regex [, $desc ] ) 402 403Tells if the title of the page does NOT match the given regex. 404 405 $mech->title_unlike( qr/Invoices for (.+)/ 406 407=head2 $mech->content_is( $str [, $desc ] ) 408 409Tells if the content of the page matches the given string. 410 411=head2 $mech->content_contains( $str [, $desc ] ) 412 413Tells if the content of the page contains I<$str>. 414 415=head2 $mech->content_lacks( $str [, $desc ] ) 416 417Tells if the content of the page lacks I<$str>. 418 419=head2 $mech->content_like( $regex [, $desc ] ) 420 421Tells if the content of the page matches I<$regex>. 422 423=head2 $mech->content_unlike( $regex [, $desc ] ) 424 425Tells if the content of the page does NOT match I<$regex>. 426 427=head2 $mech->page_links_ok( [ $desc ] ) 428 429Follow all links on the current page and test for HTTP status 200 430 431 $mech->page_links_ok('Check all links'); 432 433=head2 $mech->page_links_content_like( $regex,[ $desc ] ) 434 435Follow all links on the current page and test their contents for I<$regex>. 436 437 $mech->page_links_content_like( qr/foo/, 438 'Check all links contain "foo"' ); 439 440=head2 $mech->page_links_content_unlike( $regex,[ $desc ] ) 441 442Follow all links on the current page and test their contents do not 443contain the specified regex. 444 445 $mech->page_links_content_unlike(qr/Restricted/, 446 'Check all links do not contain Restricted'); 447 448=head2 $mech->links_ok( $links [, $desc ] ) 449 450Check the current page for specified links and test for HTTP status 451200. The links may be specified as a reference to an array containing 452L<WWW::Mechanize::Link> objects, an array of URLs, or a scalar URL 453name. 454 455 my @links = $mech->find_all_links( url_regex => qr/cnn\.com$/ ); 456 $mech->links_ok( \@links, 'Check all links for cnn.com' ); 457 458 my @links = qw( index.html search.html about.html ); 459 $mech->links_ok( \@links, 'Check main links' ); 460 461 $mech->links_ok( 'index.html', 'Check link to index' ); 462 463=head2 $mech->link_status_is( $links, $status [, $desc ] ) 464 465Check the current page for specified links and test for HTTP status 466passed. The links may be specified as a reference to an array 467containing L<WWW::Mechanize::Link> objects, an array of URLs, or a 468scalar URL name. 469 470 my @links = $mech->links(); 471 $mech->link_status_is( \@links, 403, 472 'Check all links are restricted' ); 473 474=head2 $mech->link_status_isnt( $links, $status [, $desc ] ) 475 476Check the current page for specified links and test for HTTP status 477passed. The links may be specified as a reference to an array 478containing L<WWW::Mechanize::Link> objects, an array of URLs, or a 479scalar URL name. 480 481 my @links = $mech->links(); 482 $mech->link_status_isnt( \@links, 404, 483 'Check all links are not 404' ); 484 485=head2 $mech->link_content_like( $links, $regex [, $desc ] ) 486 487Check the current page for specified links and test the content of 488each against I<$regex>. The links may be specified as a reference to 489an array containing L<WWW::Mechanize::Link> objects, an array of URLs, 490or a scalar URL name. 491 492 my @links = $mech->links(); 493 $mech->link_content_like( \@links, qr/Restricted/, 494 'Check all links are restricted' ); 495 496=head2 $mech->link_content_unlike( $links, $regex [, $desc ] ) 497 498Check the current page for specified links and test that the content of each 499does not match I<$regex>. The links may be specified as a reference to 500an array containing L<WWW::Mechanize::Link> objects, an array of URLs, 501or a scalar URL name. 502 503 my @links = $mech->links(); 504 $mech->link_content_like( \@links, qr/Restricted/, 505 'Check all links are restricted' ); 506 507=head2 follow_link_ok( \%parms [, $comment] ) 508 509Makes a C<follow_link()> call and executes tests on the results. 510The link must be found, and then followed successfully. Otherwise, 511this test fails. 512 513I<%parms> is a hashref containing the params to pass to C<follow_link()>. 514Note that the params to C<follow_link()> are a hash whereas the parms to 515this function are a hashref. You have to call this function like: 516 517 $agent->follow_link_ok( {n=>3}, "looking for 3rd link" ); 518 519As with other test functions, C<$comment> is optional. If it is supplied 520then it will display when running the test harness in verbose mode. 521 522Returns true value if the specified link was found and followed 523successfully. The HTTP::Response object returned by follow_link() 524is not available. 525 526=head1 CAVEATS 527 528=head2 External Redirects and allow_external 529 530If you use non-fully qualified urls in your test scripts (i.e. anything without 531a host, such as C<< ->get_ok( "/foo") >> ) and your app redirects to an 532external URL, expect to be bitten once you come back to your application's urls 533(it will try to request them on the remote server). This is due to a limitation 534in WWW::Mechanize. 535 536One workaround for this is that if you are expecting to redirect to an external 537site, clone the TWMC object and use the cloned object for the external 538redirect. 539 540 541=head1 SEE ALSO 542 543Related modules which may be of interest: L<Catalyst>, 544L<Test::WWW::Mechanize>, L<WWW::Mechanize>. 545 546=head1 AUTHOR 547 548Ash Berlin C<< <ash@cpan.org> >> (current maintainer) 549 550Original Author: Leon Brocard, C<< <acme@astray.com> >> 551 552=head1 COPYRIGHT 553 554Copyright (C) 2005-9, Leon Brocard 555 556=head1 LICENSE 557 558This module is free software; you can redistribute it or modify it 559under the same terms as Perl itself. 560 561