lib/Test/WWW/Mechanize/Catalyst.pm

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