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