lib/Test/WWW/Mechanize/Catalyst.pm

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