lib/Test/WWW/Mechanize/Catalyst.pm

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