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