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