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.53';
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 ) = @_;
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 # check if that was a redirect
98 if ( $response->header('Location')
99 && $response->is_redirect
100 && $self->redirect_ok( $request, $response ) )
103 # remember the old response
104 my $old_response = $response;
106 # *where* do they want us to redirect to?
107 my $location = $old_response->header('Location');
109 # no-one *should* be returning non-absolute URLs, but if they
110 # are then we'd better cope with it. Let's create a new URI, using
111 # our request as the base.
112 my $uri = URI->new_abs( $location, $request->uri )->as_string;
114 # make a new response, and save the old response in it
115 $response = $self->_make_request( HTTP::Request->new( GET => $uri ) );
116 my $end_of_chain = $response;
117 while ( $end_of_chain->previous ) # keep going till the end
119 $end_of_chain = $end_of_chain->previous;
121 $end_of_chain->previous($old_response); # ...and add us to it
123 $response->{_raw_content} = $response->content;
129 sub _do_catalyst_request {
130 my ($self, $request) = @_;
132 my $uri = $request->uri;
133 $uri->scheme('http') unless defined $uri->scheme;
134 $uri->host('localhost') unless defined $uri->host;
136 $request = $self->prepare_request($request);
137 $self->cookie_jar->add_cookie_header($request) if $self->cookie_jar;
139 # Woe betide anyone who unsets CATALYST_SERVER
140 return $self->_do_remote_request($request)
141 if $ENV{CATALYST_SERVER};
143 # If there's no Host header, set one.
144 unless ($request->header('Host')) {
145 my $host = $self->has_host
149 $request->header('Host', $host);
152 my $res = $self->_check_external_request($request);
155 my @creds = $self->get_basic_credentials( "Basic", $uri );
156 $request->authorization_basic( @creds ) if @creds;
158 my $response =Catalyst::Test::local_request($self->{catalyst_app}, $request);
160 # LWP would normally do this, but we dont get down that far.
161 $response->request($request);
166 sub _check_external_request {
167 my ($self, $request) = @_;
169 # If there's no host then definatley not an external request.
170 $request->uri->can('host_port') or return;
172 if ( $self->allow_external && $request->uri->host_port ne 'localhost:80' ) {
173 return $self->SUPER::_make_request($request);
178 sub _do_remote_request {
179 my ($self, $request) = @_;
181 my $res = $self->_check_external_request($request);
184 my $server = URI->new( $ENV{CATALYST_SERVER} );
186 if ( $server->path =~ m|^(.+)?/$| ) {
188 $server->path("$path") if $path; # need to be quoted
191 # the request path needs to be sanitised if $server is using a
192 # non-root path due to potential overlap between request path and
195 # If request path is '/', we have to add a trailing slash to the
197 my $add_trailing = $request->uri->path eq '/';
199 my @sp = split '/', $server->path;
200 my @rp = split '/', $request->uri->path;
201 shift @sp;shift @rp; # leading /
203 foreach my $sp (@sp) {
204 $sp eq $rp[0] ? shift @rp : last
207 $request->uri->path(join '/', @rp);
209 if ( $add_trailing ) {
210 $request->uri->path( $request->uri->path . '/' );
214 $request->uri->scheme( $server->scheme );
215 $request->uri->host( $server->host );
216 $request->uri->port( $server->port );
217 $request->uri->path( $server->path . $request->uri->path );
218 return $self->SUPER::_make_request($request);
222 my ($class, $app) = @_;
225 Class::MOP::load_class($app)
226 unless (Class::MOP::is_class_loaded($app));
239 Test::WWW::Mechanize::Catalyst - Test::WWW::Mechanize for Catalyst
243 # We're in a t/*.t test script...
244 use Test::WWW::Mechanize::Catalyst;
246 # To test a Catalyst application named 'Catty':
247 my $mech = Test::WWW::Mechanize::Catalyst->new(catalyst_app => 'Catty');
249 $mech->get_ok("/"); # no hostname needed
250 is($mech->ct, "text/html");
251 $mech->title_is("Root", "On the root page");
252 $mech->content_contains("This is the root page", "Correct content");
253 $mech->follow_link_ok({text => 'Hello'}, "Click on Hello");
254 # ... and all other Test::WWW::Mechanize methods
256 # White label site testing
257 $mech->host("foo.com");
262 L<Catalyst> is an elegant MVC Web Application Framework.
263 L<Test::WWW::Mechanize> is a subclass of L<WWW::Mechanize> that incorporates
264 features for web application testing. The L<Test::WWW::Mechanize::Catalyst>
265 module meshes the two to allow easy testing of L<Catalyst> applications without
266 needing to start up a web server.
268 Testing web applications has always been a bit tricky, normally
269 requiring starting a web server for your application and making real HTTP
270 requests to it. This module allows you to test L<Catalyst> web
271 applications but does not require a server or issue HTTP
272 requests. Instead, it passes the HTTP request object directly to
273 L<Catalyst>. Thus you do not need to use a real hostname:
274 "http://localhost/" will do. However, this is optional. The following
275 two lines of code do exactly the same thing:
277 $mech->get_ok('/action');
278 $mech->get_ok('http://localhost/action');
280 Links which do not begin with / or are not for localhost can be handled
281 as normal Web requests - this is handy if you have an external
282 single sign-on system. You must set allow_external to true for this:
284 $mech->allow_external(1);
286 You can also test a remote server by setting the environment variable
287 CATALYST_SERVER; for example:
289 $ CATALYST_SERVER=http://example.com/myapp prove -l t
291 will run the same tests on the application running at
292 http://example.com/myapp regardless of whether or not you specify
293 http:://localhost for Test::WWW::Mechanize::Catalyst.
295 Furthermore, if you set CATALYST_SERVER, the server will be regarded
296 as a remote server even if your links point to localhost. Thus, you
297 can use Test::WWW::Mechanize::Catalyst to test your live webserver
298 running on your local machine, if you need to test aspects of your
299 deployment environment (for example, configuration options in an
300 http.conf file) instead of just the Catalyst request handling.
302 This makes testing fast and easy. L<Test::WWW::Mechanize> provides
303 functions for common web testing scenarios. For example:
305 $mech->get_ok( $page );
306 $mech->title_is( "Invoice Status", "Make sure we're on the invoice page" );
307 $mech->content_contains( "Andy Lester", "My name somewhere" );
308 $mech->content_like( qr/(cpan|perl)\.org/, "Link to perl.org or CPAN" );
310 This module supports cookies automatically.
312 To use this module you must pass it the name of the application. See
315 Note that Catalyst has a special development feature: the debug
316 screen. By default this module will treat responses which are the
317 debug screen as failures. If you actually want to test debug screens,
320 $mech->{catalyst_debug} = 1;
322 An alternative to this module is L<Catalyst::Test>.
328 Behaves like, and calls, L<WWW::Mechanize>'s C<new> method. Any params
329 passed in get passed to WWW::Mechanize's constructor. Note that we
330 need to pass the name of the Catalyst application to the "use":
332 use Test::WWW::Mechanize::Catalyst 'Catty';
333 my $mech = Test::WWW::Mechanize::Catalyst->new;
337 =head2 allow_external
339 Links which do not begin with / or are not for localhost can be handled
340 as normal Web requests - this is handy if you have an external
341 single sign-on system. You must set allow_external to true for this:
343 $mech->allow_external(1);
347 The name of the Catalyst app which we are testing against. Read-only.
351 The host value to set the "Host:" HTTP header to, if none is present already in
352 the request. If not set (default) then Catalyst::Test will set this to
357 Unset the host attribute.
361 Do we have a value set for the host attribute
363 =head2 $mech->get_ok($url, [ \%LWP_options ,] $desc)
365 A wrapper around WWW::Mechanize's get(), with similar options, except the
366 second argument needs to be a hash reference, not a hash. Returns true or
369 =head2 $mech->title_is( $str [, $desc ] )
371 Tells if the title of the page is the given string.
373 $mech->title_is( "Invoice Summary" );
375 =head2 $mech->title_like( $regex [, $desc ] )
377 Tells if the title of the page matches the given regex.
379 $mech->title_like( qr/Invoices for (.+)/
381 =head2 $mech->title_unlike( $regex [, $desc ] )
383 Tells if the title of the page does NOT match the given regex.
385 $mech->title_unlike( qr/Invoices for (.+)/
387 =head2 $mech->content_is( $str [, $desc ] )
389 Tells if the content of the page matches the given string.
391 =head2 $mech->content_contains( $str [, $desc ] )
393 Tells if the content of the page contains I<$str>.
395 =head2 $mech->content_lacks( $str [, $desc ] )
397 Tells if the content of the page lacks I<$str>.
399 =head2 $mech->content_like( $regex [, $desc ] )
401 Tells if the content of the page matches I<$regex>.
403 =head2 $mech->content_unlike( $regex [, $desc ] )
405 Tells if the content of the page does NOT match I<$regex>.
407 =head2 $mech->page_links_ok( [ $desc ] )
409 Follow all links on the current page and test for HTTP status 200
411 $mech->page_links_ok('Check all links');
413 =head2 $mech->page_links_content_like( $regex,[ $desc ] )
415 Follow all links on the current page and test their contents for I<$regex>.
417 $mech->page_links_content_like( qr/foo/,
418 'Check all links contain "foo"' );
420 =head2 $mech->page_links_content_unlike( $regex,[ $desc ] )
422 Follow all links on the current page and test their contents do not
423 contain the specified regex.
425 $mech->page_links_content_unlike(qr/Restricted/,
426 'Check all links do not contain Restricted');
428 =head2 $mech->links_ok( $links [, $desc ] )
430 Check the current page for specified links and test for HTTP status
431 200. The links may be specified as a reference to an array containing
432 L<WWW::Mechanize::Link> objects, an array of URLs, or a scalar URL
435 my @links = $mech->find_all_links( url_regex => qr/cnn\.com$/ );
436 $mech->links_ok( \@links, 'Check all links for cnn.com' );
438 my @links = qw( index.html search.html about.html );
439 $mech->links_ok( \@links, 'Check main links' );
441 $mech->links_ok( 'index.html', 'Check link to index' );
443 =head2 $mech->link_status_is( $links, $status [, $desc ] )
445 Check the current page for specified links and test for HTTP status
446 passed. The links may be specified as a reference to an array
447 containing L<WWW::Mechanize::Link> objects, an array of URLs, or a
450 my @links = $mech->links();
451 $mech->link_status_is( \@links, 403,
452 'Check all links are restricted' );
454 =head2 $mech->link_status_isnt( $links, $status [, $desc ] )
456 Check the current page for specified links and test for HTTP status
457 passed. The links may be specified as a reference to an array
458 containing L<WWW::Mechanize::Link> objects, an array of URLs, or a
461 my @links = $mech->links();
462 $mech->link_status_isnt( \@links, 404,
463 'Check all links are not 404' );
465 =head2 $mech->link_content_like( $links, $regex [, $desc ] )
467 Check the current page for specified links and test the content of
468 each against I<$regex>. The links may be specified as a reference to
469 an array containing L<WWW::Mechanize::Link> objects, an array of URLs,
470 or a scalar URL name.
472 my @links = $mech->links();
473 $mech->link_content_like( \@links, qr/Restricted/,
474 'Check all links are restricted' );
476 =head2 $mech->link_content_unlike( $links, $regex [, $desc ] )
478 Check the current page for specified links and test that the content of each
479 does not match I<$regex>. The links may be specified as a reference to
480 an array containing L<WWW::Mechanize::Link> objects, an array of URLs,
481 or a scalar URL name.
483 my @links = $mech->links();
484 $mech->link_content_like( \@links, qr/Restricted/,
485 'Check all links are restricted' );
487 =head2 follow_link_ok( \%parms [, $comment] )
489 Makes a C<follow_link()> call and executes tests on the results.
490 The link must be found, and then followed successfully. Otherwise,
493 I<%parms> is a hashref containing the params to pass to C<follow_link()>.
494 Note that the params to C<follow_link()> are a hash whereas the parms to
495 this function are a hashref. You have to call this function like:
497 $agent->follow_link_ok( {n=>3}, "looking for 3rd link" );
499 As with other test functions, C<$comment> is optional. If it is supplied
500 then it will display when running the test harness in verbose mode.
502 Returns true value if the specified link was found and followed
503 successfully. The HTTP::Response object returned by follow_link()
508 =head2 External Redirects and allow_external
510 If you use non-fully qualified urls in your test scripts (i.e. anything without
511 a host, such as C<< ->get_ok( "/foo") >> ) and your app redirects to an
512 external URL, expect to be bitten once you come back to your application's urls
513 (it will try to request them on the remote server). This is due to a limitation
516 One workaround for this is that if you are expecting to redirect to an external
517 site, clone the TWMC object and use the cloned object for the external
523 Related modules which may be of interest: L<Catalyst>,
524 L<Test::WWW::Mechanize>, L<WWW::Mechanize>.
528 Ash Berlin C<< <ash@cpan.org> >> (current maintiner)
530 Original Author: Leon Brocard, C<< <acme@astray.com> >>
534 Copyright (C) 2005-9, Leon Brocard
538 This module is free software; you can redistribute it or modify it
539 under the same terms as Perl itself.