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