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