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