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