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