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 Class::Load qw(load_class is_class_loaded);
   8 use Encode qw();
   9 use HTML::Entities;
  10 use Test::WWW::Mechanize;
  11
  12 extends 'Test::WWW::Mechanize', 'Moose::Object';
  13
  14 #use namespace::clean -except => 'meta';
  15
  16 our $VERSION = '0.58';
  17 our $APP_CLASS;
  18 my $Test = Test::Builder->new();
  19
  20 has catalyst_app => (
  21   is => 'ro',
  22   predicate => 'has_catalyst_app',
  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 $args = ref $_[0] ? $_[0] : { @_ };
  42
  43   # Dont let LWP complain about options for our attributes
  44   my %attr_options = map {
  45     my $n = $_->init_arg;
  46     defined $n && exists $args->{$n}
  47         ? ( $n => delete $args->{$n} )
  48         : ( );
  49   } $class->meta->get_all_attributes;
  50
  51   my $obj = $class->SUPER::new(%$args);
  52   my $self = $class->meta->new_object(
  53     __INSTANCE__ => $obj,
  54     ($APP_CLASS ? (catalyst_app => $APP_CLASS) : () ),
  55     %attr_options
  56   );
  57
  58   $self->BUILDALL;
  59
  60
  61   return $self;
  62 }
  63
  64 sub BUILD {
  65   my ($self) = @_;
  66
  67   unless ($ENV{CATALYST_SERVER}) {
  68     croak "catalyst_app attribute is required unless CATALYST_SERVER env variable is set"
  69       unless $self->has_catalyst_app;
  70     load_class($self->catalyst_app)
  71       unless (is_class_loaded($self->catalyst_app));
  72   }
  73 }
  74
  75 sub _make_request {
  76     my ( $self, $request, $arg, $size, $previous) = @_;
  77
  78     my $response = $self->_do_catalyst_request($request);
  79     $response->header( 'Content-Base', $response->request->uri )
  80       unless $response->header('Content-Base');
  81
  82     $self->cookie_jar->extract_cookies($response) if $self->cookie_jar;
  83
  84     # fail tests under the Catalyst debug screen
  85     if (  !$self->{catalyst_debug}
  86         && $response->code == 500
  87         && $response->content =~ /on Catalyst \d+\.\d+/ )
  88     {
  89         my ($error)
  90             = ( $response->content =~ /<code class="error">(.*?)<\/code>/s );
  91         $error ||= "unknown error";
  92         decode_entities($error);
  93         $Test->diag("Catalyst error screen: $error");
  94         $response->content('');
  95         $response->content_type('');
  96     }
  97
  98     # NOTE: cargo-culted redirect checking from LWP::UserAgent:
  99     $response->previous($previous) if $previous;
 100     my $redirects = defined $response->redirects ? $response->redirects : 0;
 101     if ($redirects > 0 and $redirects >= $self->max_redirect) {
 102         return $self->_redirect_loop_detected($response);
 103     }
 104
 105     # check if that was a redirect
 106     if (   $response->header('Location')
 107         && $response->is_redirect
 108         && $self->redirect_ok( $request, $response ) )
 109     {
 110         return $self->_redirect_loop_detected($response) if $self->max_redirect <= 0;
 111
 112         # TODO: this should probably create the request by cloning the original
 113         # request and modifying it as LWP::UserAgent::request does.  But for now...
 114
 115         # *where* do they want us to redirect to?
 116         my $location = $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         my $referral = HTTP::Request->new( GET => $uri );
 123         return $self->request( $referral, $arg, $size, $response );
 124     } else {
 125         $response->{_raw_content} = $response->content;
 126     }
 127
 128     return $response;
 129 }
 130
 131 sub _redirect_loop_detected {
 132     my ( $self, $response ) = @_;
 133     $response->header("Client-Warning" =>
 134                       "Redirect loop detected (max_redirect = " . $self->max_redirect . ")");
 135     $response->{_raw_content} = $response->content;
 136     return $response;
 137 }
 138
 139 sub _set_host_header {
 140     my ( $self, $request ) = @_;
 141     # If there's no Host header, set one.
 142     unless ($request->header('Host')) {
 143       my $host = $self->has_host
 144                ? $self->host
 145                : $request->uri->host;
 146       $host .= ':'.$request->uri->_port if $request->uri->_port;
 147       $request->header('Host', $host);
 148     }
 149 }
 150
 151 sub _do_catalyst_request {
 152     my ($self, $request) = @_;
 153
 154     my $uri = $request->uri;
 155     $uri->scheme('http') unless defined $uri->scheme;
 156     $uri->host('localhost') unless defined $uri->host;
 157
 158     $request = $self->prepare_request($request);
 159     $self->cookie_jar->add_cookie_header($request) if $self->cookie_jar;
 160
 161     # Woe betide anyone who unsets CATALYST_SERVER
 162     return $self->_do_remote_request($request)
 163       if $ENV{CATALYST_SERVER};
 164
 165     $self->_set_host_header($request);
 166
 167     my $res = $self->_check_external_request($request);
 168     return $res if $res;
 169
 170     my @creds = $self->get_basic_credentials( "Basic", $uri );
 171     $request->authorization_basic( @creds ) if @creds;
 172
 173     require Catalyst;
 174     my $response = $Catalyst::VERSION >= 5.89000 ?
 175       Catalyst::Test::_local_request($self->{catalyst_app}, $request) :
 176         Catalyst::Test::local_request($self->{catalyst_app}, $request);
 177
 178
 179     # LWP would normally do this, but we don't get down that far.
 180     $response->request($request);
 181
 182     return $response
 183 }
 184
 185 sub _check_external_request {
 186     my ($self, $request) = @_;
 187
 188     # If there's no host then definitley not an external request.
 189     $request->uri->can('host_port') or return;
 190
 191     if ( $self->allow_external && $request->uri->host_port ne 'localhost:80' ) {
 192         return $self->SUPER::_make_request($request);
 193     }
 194     return undef;
 195 }
 196
 197 sub _do_remote_request {
 198     my ($self, $request) = @_;
 199
 200     my $res = $self->_check_external_request($request);
 201     return $res if $res;
 202
 203     my $server  = URI->new( $ENV{CATALYST_SERVER} );
 204
 205     if ( $server->path =~ m|^(.+)?/$| ) {
 206         my $path = $1;
 207         $server->path("$path") if $path;    # need to be quoted
 208     }
 209
 210     # the request path needs to be sanitised if $server is using a
 211     # non-root path due to potential overlap between request path and
 212     # response path.
 213     if ($server->path) {
 214         # If request path is '/', we have to add a trailing slash to the
 215         # final request URI
 216         my $add_trailing = $request->uri->path eq '/';
 217
 218         my @sp = split '/', $server->path;
 219         my @rp = split '/', $request->uri->path;
 220         shift @sp;shift @rp; # leading /
 221         if (@rp) {
 222             foreach my $sp (@sp) {
 223                 $sp eq $rp[0] ? shift @rp : last
 224             }
 225         }
 226         $request->uri->path(join '/', @rp);
 227
 228         if ( $add_trailing ) {
 229             $request->uri->path( $request->uri->path . '/' );
 230         }
 231     }
 232
 233     $request->uri->scheme( $server->scheme );
 234     $request->uri->host( $server->host );
 235     $request->uri->port( $server->port );
 236     $request->uri->path( $server->path . $request->uri->path );
 237     $self->_set_host_header($request);
 238     return $self->SUPER::_make_request($request);
 239 }
 240
 241 sub import {
 242   my ($class, $app) = @_;
 243
 244   if (defined $app) {
 245     load_class($app)
 246       unless (is_class_loaded($app));
 247     $APP_CLASS = $app;
 248   }
 249
 250 }
 251
 252
 253 1;
 254
 255 __END__
 256
 257 =head1 NAME
 258
 259 Test::WWW::Mechanize::Catalyst - Test::WWW::Mechanize for Catalyst
 260
 261 =head1 SYNOPSIS
 262
 263   # We're in a t/*.t test script...
 264   use Test::WWW::Mechanize::Catalyst;
 265
 266   # To test a Catalyst application named 'Catty':
 267   my $mech = Test::WWW::Mechanize::Catalyst->new(catalyst_app => 'Catty');
 268
 269   $mech->get_ok("/"); # no hostname needed
 270   is($mech->ct, "text/html");
 271   $mech->title_is("Root", "On the root page");
 272   $mech->content_contains("This is the root page", "Correct content");
 273   $mech->follow_link_ok({text => 'Hello'}, "Click on Hello");
 274   # ... and all other Test::WWW::Mechanize methods
 275
 276   # White label site testing
 277   $mech->host("foo.com");
 278   $mech->get_ok("/");
 279
 280 =head1 DESCRIPTION
 281
 282 L<Catalyst> is an elegant MVC Web Application Framework.
 283 L<Test::WWW::Mechanize> is a subclass of L<WWW::Mechanize> that incorporates
 284 features for web application testing. The L<Test::WWW::Mechanize::Catalyst>
 285 module meshes the two to allow easy testing of L<Catalyst> applications without
 286 needing to start up a web server.
 287
 288 Testing web applications has always been a bit tricky, normally
 289 requiring starting a web server for your application and making real HTTP
 290 requests to it. This module allows you to test L<Catalyst> web
 291 applications but does not require a server or issue HTTP
 292 requests. Instead, it passes the HTTP request object directly to
 293 L<Catalyst>. Thus you do not need to use a real hostname:
 294 "http://localhost/" will do. However, this is optional. The following
 295 two lines of code do exactly the same thing:
 296
 297   $mech->get_ok('/action');
 298   $mech->get_ok('http://localhost/action');
 299
 300 Links which do not begin with / or are not for localhost can be handled
 301 as normal Web requests - this is handy if you have an external
 302 single sign-on system. You must set allow_external to true for this:
 303
 304   $mech->allow_external(1);
 305
 306 You can also test a remote server by setting the environment variable
 307 CATALYST_SERVER; for example:
 308
 309   $ CATALYST_SERVER=http://example.com/myapp prove -l t
 310
 311 will run the same tests on the application running at
 312 http://example.com/myapp regardless of whether or not you specify
 313 http:://localhost for Test::WWW::Mechanize::Catalyst.
 314
 315 Furthermore, if you set CATALYST_SERVER, the server will be regarded
 316 as a remote server even if your links point to localhost. Thus, you
 317 can use Test::WWW::Mechanize::Catalyst to test your live webserver
 318 running on your local machine, if you need to test aspects of your
 319 deployment environment (for example, configuration options in an
 320 http.conf file) instead of just the Catalyst request handling.
 321
 322 This makes testing fast and easy. L<Test::WWW::Mechanize> provides
 323 functions for common web testing scenarios. For example:
 324
 325   $mech->get_ok( $page );
 326   $mech->title_is( "Invoice Status", "Make sure we're on the invoice page" );
 327   $mech->content_contains( "Andy Lester", "My name somewhere" );
 328   $mech->content_like( qr/(cpan|perl)\.org/, "Link to perl.org or CPAN" );
 329
 330 This module supports cookies automatically.
 331
 332 To use this module you must pass it the name of the application. See
 333 the SYNOPSIS above.
 334
 335 Note that Catalyst has a special development feature: the debug
 336 screen. By default this module will treat responses which are the
 337 debug screen as failures. If you actually want to test debug screens,
 338 please use:
 339
 340   $mech->{catalyst_debug} = 1;
 341
 342 An alternative to this module is L<Catalyst::Test>.
 343
 344 =head1 CONSTRUCTOR
 345
 346 =head2 new
 347
 348 Behaves like, and calls, L<WWW::Mechanize>'s C<new> method.  Any params
 349 passed in get passed to WWW::Mechanize's constructor. Note that we
 350 need to pass the name of the Catalyst application to the "use":
 351
 352   use Test::WWW::Mechanize::Catalyst 'Catty';
 353   my $mech = Test::WWW::Mechanize::Catalyst->new;
 354
 355 =head1 METHODS
 356
 357 =head2 allow_external
 358
 359 Links which do not begin with / or are not for localhost can be handled
 360 as normal Web requests - this is handy if you have an external
 361 single sign-on system. You must set allow_external to true for this:
 362
 363   $mech->allow_external(1);
 364
 365 head2 catalyst_app
 366
 367 The name of the Catalyst app which we are testing against. Read-only.
 368
 369 =head2 host
 370
 371 The host value to set the "Host:" HTTP header to, if none is present already in
 372 the request. If not set (default) then Catalyst::Test will set this to
 373 localhost:80
 374
 375 =head2 clear_host
 376
 377 Unset the host attribute.
 378
 379 =head2 has_host
 380
 381 Do we have a value set for the host attribute
 382
 383 =head2 $mech->get_ok($url, [ \%LWP_options ,] $desc)
 384
 385 A wrapper around WWW::Mechanize's get(), with similar options, except the
 386 second argument needs to be a hash reference, not a hash. Returns true or
 387 false.
 388
 389 =head2 $mech->title_is( $str [, $desc ] )
 390
 391 Tells if the title of the page is the given string.
 392
 393     $mech->title_is( "Invoice Summary" );
 394
 395 =head2 $mech->title_like( $regex [, $desc ] )
 396
 397 Tells if the title of the page matches the given regex.
 398
 399     $mech->title_like( qr/Invoices for (.+)/
 400
 401 =head2 $mech->title_unlike( $regex [, $desc ] )
 402
 403 Tells if the title of the page does NOT match the given regex.
 404
 405     $mech->title_unlike( qr/Invoices for (.+)/
 406
 407 =head2 $mech->content_is( $str [, $desc ] )
 408
 409 Tells if the content of the page matches the given string.
 410
 411 =head2 $mech->content_contains( $str [, $desc ] )
 412
 413 Tells if the content of the page contains I<$str>.
 414
 415 =head2 $mech->content_lacks( $str [, $desc ] )
 416
 417 Tells if the content of the page lacks I<$str>.
 418
 419 =head2 $mech->content_like( $regex [, $desc ] )
 420
 421 Tells if the content of the page matches I<$regex>.
 422
 423 =head2 $mech->content_unlike( $regex [, $desc ] )
 424
 425 Tells if the content of the page does NOT match I<$regex>.
 426
 427 =head2 $mech->page_links_ok( [ $desc ] )
 428
 429 Follow all links on the current page and test for HTTP status 200
 430
 431     $mech->page_links_ok('Check all links');
 432
 433 =head2 $mech->page_links_content_like( $regex,[ $desc ] )
 434
 435 Follow all links on the current page and test their contents for I<$regex>.
 436
 437     $mech->page_links_content_like( qr/foo/,
 438       'Check all links contain "foo"' );
 439
 440 =head2 $mech->page_links_content_unlike( $regex,[ $desc ] )
 441
 442 Follow all links on the current page and test their contents do not
 443 contain the specified regex.
 444
 445     $mech->page_links_content_unlike(qr/Restricted/,
 446       'Check all links do not contain Restricted');
 447
 448 =head2 $mech->links_ok( $links [, $desc ] )
 449
 450 Check the current page for specified links and test for HTTP status
 451 200.  The links may be specified as a reference to an array containing
 452 L<WWW::Mechanize::Link> objects, an array of URLs, or a scalar URL
 453 name.
 454
 455     my @links = $mech->find_all_links( url_regex => qr/cnn\.com$/ );
 456     $mech->links_ok( \@links, 'Check all links for cnn.com' );
 457
 458     my @links = qw( index.html search.html about.html );
 459     $mech->links_ok( \@links, 'Check main links' );
 460
 461     $mech->links_ok( 'index.html', 'Check link to index' );
 462
 463 =head2 $mech->link_status_is( $links, $status [, $desc ] )
 464
 465 Check the current page for specified links and test for HTTP status
 466 passed.  The links may be specified as a reference to an array
 467 containing L<WWW::Mechanize::Link> objects, an array of URLs, or a
 468 scalar URL name.
 469
 470     my @links = $mech->links();
 471     $mech->link_status_is( \@links, 403,
 472       'Check all links are restricted' );
 473
 474 =head2 $mech->link_status_isnt( $links, $status [, $desc ] )
 475
 476 Check the current page for specified links and test for HTTP status
 477 passed.  The links may be specified as a reference to an array
 478 containing L<WWW::Mechanize::Link> objects, an array of URLs, or a
 479 scalar URL name.
 480
 481     my @links = $mech->links();
 482     $mech->link_status_isnt( \@links, 404,
 483       'Check all links are not 404' );
 484
 485 =head2 $mech->link_content_like( $links, $regex [, $desc ] )
 486
 487 Check the current page for specified links and test the content of
 488 each against I<$regex>.  The links may be specified as a reference to
 489 an array containing L<WWW::Mechanize::Link> objects, an array of URLs,
 490 or a scalar URL name.
 491
 492     my @links = $mech->links();
 493     $mech->link_content_like( \@links, qr/Restricted/,
 494         'Check all links are restricted' );
 495
 496 =head2 $mech->link_content_unlike( $links, $regex [, $desc ] )
 497
 498 Check the current page for specified links and test that the content of each
 499 does not match I<$regex>.  The links may be specified as a reference to
 500 an array containing L<WWW::Mechanize::Link> objects, an array of URLs,
 501 or a scalar URL name.
 502
 503     my @links = $mech->links();
 504     $mech->link_content_like( \@links, qr/Restricted/,
 505       'Check all links are restricted' );
 506
 507 =head2 follow_link_ok( \%parms [, $comment] )
 508
 509 Makes a C<follow_link()> call and executes tests on the results.
 510 The link must be found, and then followed successfully.  Otherwise,
 511 this test fails.
 512
 513 I<%parms> is a hashref containing the params to pass to C<follow_link()>.
 514 Note that the params to C<follow_link()> are a hash whereas the parms to
 515 this function are a hashref.  You have to call this function like:
 516
 517     $agent->follow_link_ok( {n=>3}, "looking for 3rd link" );
 518
 519 As with other test functions, C<$comment> is optional.  If it is supplied
 520 then it will display when running the test harness in verbose mode.
 521
 522 Returns true value if the specified link was found and followed
 523 successfully.  The HTTP::Response object returned by follow_link()
 524 is not available.
 525
 526 =head1 CAVEATS
 527
 528 =head2 External Redirects and allow_external
 529
 530 If you use non-fully qualified urls in your test scripts (i.e. anything without
 531 a host, such as C<< ->get_ok( "/foo") >> ) and your app redirects to an
 532 external URL, expect to be bitten once you come back to your application's urls
 533 (it will try to request them on the remote server). This is due to a limitation
 534 in WWW::Mechanize.
 535
 536 One workaround for this is that if you are expecting to redirect to an external
 537 site, clone the TWMC object and use the cloned object for the external
 538 redirect.
 539
 540
 541 =head1 SEE ALSO
 542
 543 Related modules which may be of interest: L<Catalyst>,
 544 L<Test::WWW::Mechanize>, L<WWW::Mechanize>.
 545
 546 =head1 AUTHOR
 547
 548 Ash Berlin C<< <ash@cpan.org> >> (current maintainer)
 549
 550 Original Author: Leon Brocard, C<< <acme@astray.com> >>
 551
 552 =head1 COPYRIGHT
 553
 554 Copyright (C) 2005-9, Leon Brocard
 555
 556 =head1 LICENSE
 557
 558 This module is free software; you can redistribute it or modify it
 559 under the same terms as Perl itself.
 560