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