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