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     $self->cookie_jar->add_cookie_header($request) if $self->cookie_jar;
 139
 140     # Woe betide anyone who unsets CATALYST_SERVER
 141     return Catalyst::Test::remote_request($request)
 142       if $ENV{CATALYST_SERVER};
 143
 144
 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
 211 Framework. L<Test::WWW::Mechanize> is a subclass of L<WWW::Mechanize> that
 212 incorporates features for web application testing. The
 213 L<Test::WWW::Mechanize::Catalyst> module meshes the two to allow easy
 214 testing of L<Catalyst> applications without starting up a web server.
 215
 216 Testing web applications has always been a bit tricky, normally
 217 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 start 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   $m->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 This makes testing fast and easy. L<Test::WWW::Mechanize> provides
 244 functions for common web testing scenarios. For example:
 245
 246   $mech->get_ok( $page );
 247   $mech->title_is( "Invoice Status", "Make sure we're on the invoice page" );
 248   $mech->content_contains( "Andy Lester", "My name somewhere" );
 249   $mech->content_like( qr/(cpan|perl)\.org/, "Link to perl.org or CPAN" );
 250
 251 This module supports cookies automatically.
 252
 253 To use this module you must pass it the name of the application. See
 254 the SYNOPSIS above.
 255
 256 Note that Catalyst has a special developing feature: the debug
 257 screen. By default this module will treat responses which are the
 258 debug screen as failures. If you actually want to test debug screens,
 259 please use:
 260
 261   $m->{catalyst_debug} = 1;
 262
 263 An alternative to this module is L<Catalyst::Test>.
 264
 265 =head1 CONSTRUCTOR
 266
 267 =head2 new
 268
 269 Behaves like, and calls, L<WWW::Mechanize>'s C<new> method.  Any parms
 270 passed in get passed to WWW::Mechanize's constructor. Note that we
 271 need to pass the name of the Catalyst application to the "use":
 272
 273   use Test::WWW::Mechanize::Catalyst 'Catty';
 274   my $mech = Test::WWW::Mechanize::Catalyst->new;
 275
 276 =head1 METHODS
 277
 278 =head2 allow_external
 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   $m->allow_external(1);
 285
 286 head2 catalyst_app
 287
 288 The name of the Catalyst app which we are testing against. Read-only.
 289
 290 =head2 host
 291
 292 The host value to set the "Host:" HTTP header to, if none is present already in
 293 the request. If not set (default) then Catalyst::Test will set this to
 294 localhost:80
 295
 296 =head2 clear_host
 297
 298 Unset the host attribute.
 299
 300 =head2 has_host
 301
 302 Do we have a value set for the host attribute
 303
 304 =head2 $mech->get_ok($url, [ \%LWP_options ,] $desc)
 305
 306 A wrapper around WWW::Mechanize's get(), with similar options, except the
 307 second argument needs to be a hash reference, not a hash. Returns true or
 308 false.
 309
 310 =head2 $mech->title_is( $str [, $desc ] )
 311
 312 Tells if the title of the page is the given string.
 313
 314     $mech->title_is( "Invoice Summary" );
 315
 316 =head2 $mech->title_like( $regex [, $desc ] )
 317
 318 Tells if the title of the page matches the given regex.
 319
 320     $mech->title_like( qr/Invoices for (.+)/
 321
 322 =head2 $mech->title_unlike( $regex [, $desc ] )
 323
 324 Tells if the title of the page matches the given regex.
 325
 326     $mech->title_unlike( qr/Invoices for (.+)/
 327
 328 =head2 $mech->content_is( $str [, $desc ] )
 329
 330 Tells if the content of the page matches the given string
 331
 332 =head2 $mech->content_contains( $str [, $desc ] )
 333
 334 Tells if the content of the page contains I<$str>.
 335
 336 =head2 $mech->content_lacks( $str [, $desc ] )
 337
 338 Tells if the content of the page lacks I<$str>.
 339
 340 =head2 $mech->content_like( $regex [, $desc ] )
 341
 342 Tells if the content of the page matches I<$regex>.
 343
 344 =head2 $mech->content_unlike( $regex [, $desc ] )
 345
 346 Tells if the content of the page does NOT match I<$regex>.
 347
 348 =head2 $mech->page_links_ok( [ $desc ] )
 349
 350 Follow all links on the current page and test for HTTP status 200
 351
 352     $mech->page_links_ok('Check all links');
 353
 354 =head2 $mech->page_links_content_like( $regex,[ $desc ] )
 355
 356 Follow all links on the current page and test their contents for I<$regex>.
 357
 358     $mech->page_links_content_like( qr/foo/,
 359       'Check all links contain "foo"' );
 360
 361 =head2 $mech->page_links_content_unlike( $regex,[ $desc ] )
 362
 363 Follow all links on the current page and test their contents do not
 364 contain the specified regex.
 365
 366     $mech->page_links_content_unlike(qr/Restricted/,
 367       'Check all links do not contain Restricted');
 368
 369 =head2 $mech->links_ok( $links [, $desc ] )
 370
 371 Check the current page for specified links and test for HTTP status
 372 200.  The links may be specified as a reference to an array containing
 373 L<WWW::Mechanize::Link> objects, an array of URLs, or a scalar URL
 374 name.
 375
 376     my @links = $mech->find_all_links( url_regex => qr/cnn\.com$/ );
 377     $mech->links_ok( \@links, 'Check all links for cnn.com' );
 378
 379     my @links = qw( index.html search.html about.html );
 380     $mech->links_ok( \@links, 'Check main links' );
 381
 382     $mech->links_ok( 'index.html', 'Check link to index' );
 383
 384 =head2 $mech->link_status_is( $links, $status [, $desc ] )
 385
 386 Check the current page for specified links and test for HTTP status
 387 passed.  The links may be specified as a reference to an array
 388 containing L<WWW::Mechanize::Link> objects, an array of URLs, or a
 389 scalar URL name.
 390
 391     my @links = $mech->links();
 392     $mech->link_status_is( \@links, 403,
 393       'Check all links are restricted' );
 394
 395 =head2 $mech->link_status_isnt( $links, $status [, $desc ] )
 396
 397 Check the current page for specified links and test for HTTP status
 398 passed.  The links may be specified as a reference to an array
 399 containing L<WWW::Mechanize::Link> objects, an array of URLs, or a
 400 scalar URL name.
 401
 402     my @links = $mech->links();
 403     $mech->link_status_isnt( \@links, 404,
 404       'Check all links are not 404' );
 405
 406 =head2 $mech->link_content_like( $links, $regex [, $desc ] )
 407
 408 Check the current page for specified links and test the content of
 409 each against I<$regex>.  The links may be specified as a reference to
 410 an array containing L<WWW::Mechanize::Link> objects, an array of URLs,
 411 or a scalar URL name.
 412
 413     my @links = $mech->links();
 414     $mech->link_content_like( \@links, qr/Restricted/,
 415         'Check all links are restricted' );
 416
 417 =head2 $mech->link_content_unlike( $links, $regex [, $desc ] )
 418
 419 Check the current page for specified links and test the content of each
 420 does not match I<$regex>.  The links may be specified as a reference to
 421 an array containing L<WWW::Mechanize::Link> objects, an array of URLs,
 422 or a scalar URL name.
 423
 424     my @links = $mech->links();
 425     $mech->link_content_like( \@links, qr/Restricted/,
 426       'Check all links are restricted' );
 427
 428 =head2 follow_link_ok( \%parms [, $comment] )
 429
 430 Makes a C<follow_link()> call and executes tests on the results.
 431 The link must be found, and then followed successfully.  Otherwise,
 432 this test fails.
 433
 434 I<%parms> is a hashref containing the parms to pass to C<follow_link()>.
 435 Note that the parms to C<follow_link()> are a hash whereas the parms to
 436 this function are a hashref.  You have to call this function like:
 437
 438     $agent->follow_like_ok( {n=>3}, "looking for 3rd link" );
 439
 440 As with other test functions, C<$comment> is optional.  If it is supplied
 441 then it will display when running the test harness in verbose mode.
 442
 443 Returns true value if the specified link was found and followed
 444 successfully.  The HTTP::Response object returned by follow_link()
 445 is not available.
 446
 447 =head1 SEE ALSO
 448
 449 Related modules which may be of interest: L<Catalyst>,
 450 L<Test::WWW::Mechanize>, L<WWW::Mechanize>.
 451
 452 =head1 AUTHOR
 453
 454 Ash Berlin C<< <ash@cpan.org> >> (current maintiner)
 455
 456 Original Author: Leon Brocard, C<< <acme@astray.com> >>
 457
 458 =head1 COPYRIGHT
 459
 460 Copyright (C) 2005-8, Leon Brocard
 461
 462 =head1 LICENSE
 463
 464 This module is free software; you can redistribute it or modify it
 465 under the same terms as Perl itself.
 466