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