1 package Test::WWW::Mechanize::Catalyst;
6 require Catalyst::Test; # Do not call import
7 use Class::Load qw(load_class is_class_loaded);
10 use Test::WWW::Mechanize;
12 extends 'Test::WWW::Mechanize', 'Moose::Object';
14 #use namespace::clean -except => 'meta';
16 our $VERSION = '0.62';
18 my $Test = Test::Builder->new();
22 predicate => 'has_catalyst_app',
25 has allow_external => (
34 clearer => 'clear_host',
35 predicate => 'has_host',
41 my $args = ref $_[0] ? $_[0] : { @_ };
43 # Dont let LWP complain about options for our attributes
44 my %attr_options = map {
46 defined $n && exists $args->{$n}
47 ? ( $n => delete $args->{$n} )
49 } $class->meta->get_all_attributes;
51 my $obj = $class->SUPER::new(%$args);
52 my $self = $class->meta->new_object(
54 ($APP_CLASS ? (catalyst_app => $APP_CLASS) : () ),
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));
76 my ( $self, $request, $arg, $size, $previous) = @_;
78 my $response = $self->_do_catalyst_request($request);
79 $response->header( 'Content-Base', $response->request->uri )
80 unless $response->header('Content-Base');
82 $self->cookie_jar->extract_cookies($response) if $self->cookie_jar;
84 # fail tests under the Catalyst debug screen
85 if ( !$self->{catalyst_debug}
86 && $response->code == 500
87 && $response->content =~ /on Catalyst \d+\.\d+/ )
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('');
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);
105 # check if that was a redirect
106 if ( $response->header('Location')
107 && $response->is_redirect
108 && $self->redirect_ok( $request, $response ) )
110 return $self->_redirect_loop_detected($response) if $self->max_redirect <= 0;
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...
115 # *where* do they want us to redirect to?
116 my $location = $response->header('Location');
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 );
125 $response->{_raw_content} = $response->content;
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;
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
145 : $request->uri->host;
146 $host .= ':'.$request->uri->_port if $request->uri->_port;
147 $request->header('Host', $host);
151 sub _do_catalyst_request {
152 my ($self, $request) = @_;
154 my $uri = $request->uri;
155 $uri->scheme('http') unless defined $uri->scheme;
156 $uri->host('localhost') unless defined $uri->host;
158 $request = $self->prepare_request($request);
159 $self->cookie_jar->add_cookie_header($request) if $self->cookie_jar;
161 # Woe betide anyone who unsets CATALYST_SERVER
162 return $self->_do_remote_request($request)
163 if $ENV{CATALYST_SERVER};
165 $self->_set_host_header($request);
167 my $res = $self->_check_external_request($request);
170 my @creds = $self->get_basic_credentials( "Basic", $uri );
171 $request->authorization_basic( @creds ) if @creds;
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);
179 # LWP would normally do this, but we don't get down that far.
180 $response->request($request);
185 sub _check_external_request {
186 my ($self, $request) = @_;
188 # If there's no host then definitley not an external request.
189 $request->uri->can('host_port') or return;
191 if ( $self->allow_external && $request->uri->host_port ne 'localhost:80' ) {
192 return $self->SUPER::_make_request($request);
197 sub _do_remote_request {
198 my ($self, $request) = @_;
200 my $res = $self->_check_external_request($request);
203 my $server = URI->new( $ENV{CATALYST_SERVER} );
205 if ( $server->path =~ m|^(.+)?/$| ) {
207 $server->path("$path") if $path; # need to be quoted
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
214 # If request path is '/', we have to add a trailing slash to the
216 my $add_trailing = $request->uri->path eq '/';
218 my @sp = split '/', $server->path;
219 my @rp = split '/', $request->uri->path;
220 shift @sp;shift @rp; # leading /
222 foreach my $sp (@sp) {
223 $sp eq $rp[0] ? shift @rp : last
226 $request->uri->path(join '/', @rp);
228 if ( $add_trailing ) {
229 $request->uri->path( $request->uri->path . '/' );
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);
242 my ($class, $app) = @_;
246 unless (is_class_loaded($app));
259 Test::WWW::Mechanize::Catalyst - Test::WWW::Mechanize for Catalyst
263 # We're in a t/*.t test script...
264 use Test::WWW::Mechanize::Catalyst;
266 # To test a Catalyst application named 'Catty':
267 my $mech = Test::WWW::Mechanize::Catalyst->new(catalyst_app => 'Catty');
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
276 # White label site testing
277 $mech->host("foo.com");
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.
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:
297 $mech->get_ok('/action');
298 $mech->get_ok('http://localhost/action');
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:
304 $mech->allow_external(1);
306 You can also test a remote server by setting the environment variable
307 CATALYST_SERVER; for example:
309 $ CATALYST_SERVER=http://example.com/myapp prove -l t
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.
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.
322 This makes testing fast and easy. L<Test::WWW::Mechanize> provides
323 functions for common web testing scenarios. For example:
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" );
330 This module supports cookies automatically.
332 To use this module you must pass it the name of the application. See
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,
340 $mech->{catalyst_debug} = 1;
342 An alternative to this module is L<Catalyst::Test>.
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":
352 use Test::WWW::Mechanize::Catalyst 'Catty';
353 my $mech = Test::WWW::Mechanize::Catalyst->new;
357 =head2 allow_external
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:
363 $mech->allow_external(1);
367 The name of the Catalyst app which we are testing against. Read-only.
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
377 Unset the host attribute.
381 Do we have a value set for the host attribute
383 =head2 $mech->get_ok($url, [ \%LWP_options ,] $desc)
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
389 =head2 $mech->title_is( $str [, $desc ] )
391 Tells if the title of the page is the given string.
393 $mech->title_is( "Invoice Summary" );
395 =head2 $mech->title_like( $regex [, $desc ] )
397 Tells if the title of the page matches the given regex.
399 $mech->title_like( qr/Invoices for (.+)/
401 =head2 $mech->title_unlike( $regex [, $desc ] )
403 Tells if the title of the page does NOT match the given regex.
405 $mech->title_unlike( qr/Invoices for (.+)/
407 =head2 $mech->content_is( $str [, $desc ] )
409 Tells if the content of the page matches the given string.
411 =head2 $mech->content_contains( $str [, $desc ] )
413 Tells if the content of the page contains I<$str>.
415 =head2 $mech->content_lacks( $str [, $desc ] )
417 Tells if the content of the page lacks I<$str>.
419 =head2 $mech->content_like( $regex [, $desc ] )
421 Tells if the content of the page matches I<$regex>.
423 =head2 $mech->content_unlike( $regex [, $desc ] )
425 Tells if the content of the page does NOT match I<$regex>.
427 =head2 $mech->page_links_ok( [ $desc ] )
429 Follow all links on the current page and test for HTTP status 200
431 $mech->page_links_ok('Check all links');
433 =head2 $mech->page_links_content_like( $regex,[ $desc ] )
435 Follow all links on the current page and test their contents for I<$regex>.
437 $mech->page_links_content_like( qr/foo/,
438 'Check all links contain "foo"' );
440 =head2 $mech->page_links_content_unlike( $regex,[ $desc ] )
442 Follow all links on the current page and test their contents do not
443 contain the specified regex.
445 $mech->page_links_content_unlike(qr/Restricted/,
446 'Check all links do not contain Restricted');
448 =head2 $mech->links_ok( $links [, $desc ] )
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
455 my @links = $mech->find_all_links( url_regex => qr/cnn\.com$/ );
456 $mech->links_ok( \@links, 'Check all links for cnn.com' );
458 my @links = qw( index.html search.html about.html );
459 $mech->links_ok( \@links, 'Check main links' );
461 $mech->links_ok( 'index.html', 'Check link to index' );
463 =head2 $mech->link_status_is( $links, $status [, $desc ] )
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
470 my @links = $mech->links();
471 $mech->link_status_is( \@links, 403,
472 'Check all links are restricted' );
474 =head2 $mech->link_status_isnt( $links, $status [, $desc ] )
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
481 my @links = $mech->links();
482 $mech->link_status_isnt( \@links, 404,
483 'Check all links are not 404' );
485 =head2 $mech->link_content_like( $links, $regex [, $desc ] )
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.
492 my @links = $mech->links();
493 $mech->link_content_like( \@links, qr/Restricted/,
494 'Check all links are restricted' );
496 =head2 $mech->link_content_unlike( $links, $regex [, $desc ] )
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.
503 my @links = $mech->links();
504 $mech->link_content_like( \@links, qr/Restricted/,
505 'Check all links are restricted' );
507 =head2 follow_link_ok( \%parms [, $comment] )
509 Makes a C<follow_link()> call and executes tests on the results.
510 The link must be found, and then followed successfully. Otherwise,
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:
517 $agent->follow_link_ok( {n=>3}, "looking for 3rd link" );
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.
522 Returns true value if the specified link was found and followed
523 successfully. The HTTP::Response object returned by follow_link()
528 =head2 External Redirects and allow_external
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
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
543 Related modules which may be of interest: L<Catalyst>,
544 L<Test::WWW::Mechanize>, L<WWW::Mechanize>.
548 Ash Berlin C<< <ash@cpan.org> >> (current maintainer)
550 Original Author: Leon Brocard, C<< <acme@astray.com> >>
554 Copyright (C) 2005-9, Leon Brocard
558 This module is free software; you can redistribute it or modify it
559 under the same terms as Perl itself.