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