1 package Test::WWW::Mechanize::Catalyst;
6 require Catalyst::Test; # Do not call import
9 use Test::WWW::Mechanize;
11 extends 'Test::WWW::Mechanize', 'Moose::Object';
13 #use namespace::clean -execept => 'meta';
15 our $VERSION = '0.58';
17 my $Test = Test::Builder->new();
21 predicate => 'has_catalyst_app',
24 has allow_external => (
33 clearer => 'clear_host',
34 predicate => 'has_host',
40 my $args = ref $_[0] ? $_[0] : { @_ };
42 # Dont let LWP complain about options for our attributes
43 my %attr_options = map {
45 defined $n && exists $args->{$n}
46 ? ( $n => delete $args->{$n} )
48 } $class->meta->get_all_attributes;
50 my $obj = $class->SUPER::new(%$args);
51 my $self = $class->meta->new_object(
53 ($APP_CLASS ? (catalyst_app => $APP_CLASS) : () ),
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));
75 my ( $self, $request, $arg, $size, $previous) = @_;
77 my $response = $self->_do_catalyst_request($request);
78 $response->header( 'Content-Base', $response->request->uri )
79 unless $response->header('Content-Base');
81 $self->cookie_jar->extract_cookies($response) if $self->cookie_jar;
83 # fail tests under the Catalyst debug screen
84 if ( !$self->{catalyst_debug}
85 && $response->code == 500
86 && $response->content =~ /on Catalyst \d+\.\d+/ )
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('');
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);
104 # check if that was a redirect
105 if ( $response->header('Location')
106 && $response->is_redirect
107 && $self->redirect_ok( $request, $response ) )
109 return $self->_redirect_loop_detected($response) if $self->max_redirect <= 0;
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...
114 # *where* do they want us to redirect to?
115 my $location = $response->header('Location');
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 );
124 $response->{_raw_content} = $response->content;
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;
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
144 : $request->uri->host;
145 $host .= ':'.$request->uri->_port if $request->uri->_port;
146 $request->header('Host', $host);
150 sub _do_catalyst_request {
151 my ($self, $request) = @_;
153 my $uri = $request->uri;
154 $uri->scheme('http') unless defined $uri->scheme;
155 $uri->host('localhost') unless defined $uri->host;
157 $request = $self->prepare_request($request);
158 $self->cookie_jar->add_cookie_header($request) if $self->cookie_jar;
160 # Woe betide anyone who unsets CATALYST_SERVER
161 return $self->_do_remote_request($request)
162 if $ENV{CATALYST_SERVER};
164 $self->_set_host_header($request);
166 my $res = $self->_check_external_request($request);
169 my @creds = $self->get_basic_credentials( "Basic", $uri );
170 $request->authorization_basic( @creds ) if @creds;
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);
178 # LWP would normally do this, but we dont get down that far.
179 $response->request($request);
184 sub _check_external_request {
185 my ($self, $request) = @_;
187 # If there's no host then definatley not an external request.
188 $request->uri->can('host_port') or return;
190 if ( $self->allow_external && $request->uri->host_port ne 'localhost:80' ) {
191 return $self->SUPER::_make_request($request);
196 sub _do_remote_request {
197 my ($self, $request) = @_;
199 my $res = $self->_check_external_request($request);
202 my $server = URI->new( $ENV{CATALYST_SERVER} );
204 if ( $server->path =~ m|^(.+)?/$| ) {
206 $server->path("$path") if $path; # need to be quoted
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
213 # If request path is '/', we have to add a trailing slash to the
215 my $add_trailing = $request->uri->path eq '/';
217 my @sp = split '/', $server->path;
218 my @rp = split '/', $request->uri->path;
219 shift @sp;shift @rp; # leading /
221 foreach my $sp (@sp) {
222 $sp eq $rp[0] ? shift @rp : last
225 $request->uri->path(join '/', @rp);
227 if ( $add_trailing ) {
228 $request->uri->path( $request->uri->path . '/' );
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);
241 my ($class, $app) = @_;
244 Class::MOP::load_class($app)
245 unless (Class::MOP::is_class_loaded($app));
258 Test::WWW::Mechanize::Catalyst - Test::WWW::Mechanize for Catalyst
262 # We're in a t/*.t test script...
263 use Test::WWW::Mechanize::Catalyst;
265 # To test a Catalyst application named 'Catty':
266 my $mech = Test::WWW::Mechanize::Catalyst->new(catalyst_app => 'Catty');
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
275 # White label site testing
276 $mech->host("foo.com");
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.
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:
296 $mech->get_ok('/action');
297 $mech->get_ok('http://localhost/action');
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:
303 $mech->allow_external(1);
305 You can also test a remote server by setting the environment variable
306 CATALYST_SERVER; for example:
308 $ CATALYST_SERVER=http://example.com/myapp prove -l t
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.
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.
321 This makes testing fast and easy. L<Test::WWW::Mechanize> provides
322 functions for common web testing scenarios. For example:
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" );
329 This module supports cookies automatically.
331 To use this module you must pass it the name of the application. See
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,
339 $mech->{catalyst_debug} = 1;
341 An alternative to this module is L<Catalyst::Test>.
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":
351 use Test::WWW::Mechanize::Catalyst 'Catty';
352 my $mech = Test::WWW::Mechanize::Catalyst->new;
356 =head2 allow_external
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:
362 $mech->allow_external(1);
366 The name of the Catalyst app which we are testing against. Read-only.
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
376 Unset the host attribute.
380 Do we have a value set for the host attribute
382 =head2 $mech->get_ok($url, [ \%LWP_options ,] $desc)
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
388 =head2 $mech->title_is( $str [, $desc ] )
390 Tells if the title of the page is the given string.
392 $mech->title_is( "Invoice Summary" );
394 =head2 $mech->title_like( $regex [, $desc ] )
396 Tells if the title of the page matches the given regex.
398 $mech->title_like( qr/Invoices for (.+)/
400 =head2 $mech->title_unlike( $regex [, $desc ] )
402 Tells if the title of the page does NOT match the given regex.
404 $mech->title_unlike( qr/Invoices for (.+)/
406 =head2 $mech->content_is( $str [, $desc ] )
408 Tells if the content of the page matches the given string.
410 =head2 $mech->content_contains( $str [, $desc ] )
412 Tells if the content of the page contains I<$str>.
414 =head2 $mech->content_lacks( $str [, $desc ] )
416 Tells if the content of the page lacks I<$str>.
418 =head2 $mech->content_like( $regex [, $desc ] )
420 Tells if the content of the page matches I<$regex>.
422 =head2 $mech->content_unlike( $regex [, $desc ] )
424 Tells if the content of the page does NOT match I<$regex>.
426 =head2 $mech->page_links_ok( [ $desc ] )
428 Follow all links on the current page and test for HTTP status 200
430 $mech->page_links_ok('Check all links');
432 =head2 $mech->page_links_content_like( $regex,[ $desc ] )
434 Follow all links on the current page and test their contents for I<$regex>.
436 $mech->page_links_content_like( qr/foo/,
437 'Check all links contain "foo"' );
439 =head2 $mech->page_links_content_unlike( $regex,[ $desc ] )
441 Follow all links on the current page and test their contents do not
442 contain the specified regex.
444 $mech->page_links_content_unlike(qr/Restricted/,
445 'Check all links do not contain Restricted');
447 =head2 $mech->links_ok( $links [, $desc ] )
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
454 my @links = $mech->find_all_links( url_regex => qr/cnn\.com$/ );
455 $mech->links_ok( \@links, 'Check all links for cnn.com' );
457 my @links = qw( index.html search.html about.html );
458 $mech->links_ok( \@links, 'Check main links' );
460 $mech->links_ok( 'index.html', 'Check link to index' );
462 =head2 $mech->link_status_is( $links, $status [, $desc ] )
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
469 my @links = $mech->links();
470 $mech->link_status_is( \@links, 403,
471 'Check all links are restricted' );
473 =head2 $mech->link_status_isnt( $links, $status [, $desc ] )
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
480 my @links = $mech->links();
481 $mech->link_status_isnt( \@links, 404,
482 'Check all links are not 404' );
484 =head2 $mech->link_content_like( $links, $regex [, $desc ] )
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.
491 my @links = $mech->links();
492 $mech->link_content_like( \@links, qr/Restricted/,
493 'Check all links are restricted' );
495 =head2 $mech->link_content_unlike( $links, $regex [, $desc ] )
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.
502 my @links = $mech->links();
503 $mech->link_content_like( \@links, qr/Restricted/,
504 'Check all links are restricted' );
506 =head2 follow_link_ok( \%parms [, $comment] )
508 Makes a C<follow_link()> call and executes tests on the results.
509 The link must be found, and then followed successfully. Otherwise,
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:
516 $agent->follow_link_ok( {n=>3}, "looking for 3rd link" );
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.
521 Returns true value if the specified link was found and followed
522 successfully. The HTTP::Response object returned by follow_link()
527 =head2 External Redirects and allow_external
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
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
542 Related modules which may be of interest: L<Catalyst>,
543 L<Test::WWW::Mechanize>, L<WWW::Mechanize>.
547 Ash Berlin C<< <ash@cpan.org> >> (current maintiner)
549 Original Author: Leon Brocard, C<< <acme@astray.com> >>
553 Copyright (C) 2005-9, Leon Brocard
557 This module is free software; you can redistribute it or modify it
558 under the same terms as Perl itself.