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.54';
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;
159 my $response = $Catalyst::VERSION >= 5.89000 ?
160 Catalyst::Test::_local_request($self->{catalyst_app}, $request) :
161 Catalyst::Test::local_request($self->{catalyst_app}, $request);
164 # LWP would normally do this, but we dont get down that far.
165 $response->request($request);
170 sub _check_external_request {
171 my ($self, $request) = @_;
173 # If there's no host then definatley not an external request.
174 $request->uri->can('host_port') or return;
176 if ( $self->allow_external && $request->uri->host_port ne 'localhost:80' ) {
177 return $self->SUPER::_make_request($request);
182 sub _do_remote_request {
183 my ($self, $request) = @_;
185 my $res = $self->_check_external_request($request);
188 my $server = URI->new( $ENV{CATALYST_SERVER} );
190 if ( $server->path =~ m|^(.+)?/$| ) {
192 $server->path("$path") if $path; # need to be quoted
195 # the request path needs to be sanitised if $server is using a
196 # non-root path due to potential overlap between request path and
199 # If request path is '/', we have to add a trailing slash to the
201 my $add_trailing = $request->uri->path eq '/';
203 my @sp = split '/', $server->path;
204 my @rp = split '/', $request->uri->path;
205 shift @sp;shift @rp; # leading /
207 foreach my $sp (@sp) {
208 $sp eq $rp[0] ? shift @rp : last
211 $request->uri->path(join '/', @rp);
213 if ( $add_trailing ) {
214 $request->uri->path( $request->uri->path . '/' );
218 $request->uri->scheme( $server->scheme );
219 $request->uri->host( $server->host );
220 $request->uri->port( $server->port );
221 $request->uri->path( $server->path . $request->uri->path );
222 return $self->SUPER::_make_request($request);
226 my ($class, $app) = @_;
229 Class::MOP::load_class($app)
230 unless (Class::MOP::is_class_loaded($app));
243 Test::WWW::Mechanize::Catalyst - Test::WWW::Mechanize for Catalyst
247 # We're in a t/*.t test script...
248 use Test::WWW::Mechanize::Catalyst;
250 # To test a Catalyst application named 'Catty':
251 my $mech = Test::WWW::Mechanize::Catalyst->new(catalyst_app => 'Catty');
253 $mech->get_ok("/"); # no hostname needed
254 is($mech->ct, "text/html");
255 $mech->title_is("Root", "On the root page");
256 $mech->content_contains("This is the root page", "Correct content");
257 $mech->follow_link_ok({text => 'Hello'}, "Click on Hello");
258 # ... and all other Test::WWW::Mechanize methods
260 # White label site testing
261 $mech->host("foo.com");
266 L<Catalyst> is an elegant MVC Web Application Framework.
267 L<Test::WWW::Mechanize> is a subclass of L<WWW::Mechanize> that incorporates
268 features for web application testing. The L<Test::WWW::Mechanize::Catalyst>
269 module meshes the two to allow easy testing of L<Catalyst> applications without
270 needing to start up a web server.
272 Testing web applications has always been a bit tricky, normally
273 requiring starting a web server for your application and making real HTTP
274 requests to it. This module allows you to test L<Catalyst> web
275 applications but does not require a server or issue HTTP
276 requests. Instead, it passes the HTTP request object directly to
277 L<Catalyst>. Thus you do not need to use a real hostname:
278 "http://localhost/" will do. However, this is optional. The following
279 two lines of code do exactly the same thing:
281 $mech->get_ok('/action');
282 $mech->get_ok('http://localhost/action');
284 Links which do not begin with / or are not for localhost can be handled
285 as normal Web requests - this is handy if you have an external
286 single sign-on system. You must set allow_external to true for this:
288 $mech->allow_external(1);
290 You can also test a remote server by setting the environment variable
291 CATALYST_SERVER; for example:
293 $ CATALYST_SERVER=http://example.com/myapp prove -l t
295 will run the same tests on the application running at
296 http://example.com/myapp regardless of whether or not you specify
297 http:://localhost for Test::WWW::Mechanize::Catalyst.
299 Furthermore, if you set CATALYST_SERVER, the server will be regarded
300 as a remote server even if your links point to localhost. Thus, you
301 can use Test::WWW::Mechanize::Catalyst to test your live webserver
302 running on your local machine, if you need to test aspects of your
303 deployment environment (for example, configuration options in an
304 http.conf file) instead of just the Catalyst request handling.
306 This makes testing fast and easy. L<Test::WWW::Mechanize> provides
307 functions for common web testing scenarios. For example:
309 $mech->get_ok( $page );
310 $mech->title_is( "Invoice Status", "Make sure we're on the invoice page" );
311 $mech->content_contains( "Andy Lester", "My name somewhere" );
312 $mech->content_like( qr/(cpan|perl)\.org/, "Link to perl.org or CPAN" );
314 This module supports cookies automatically.
316 To use this module you must pass it the name of the application. See
319 Note that Catalyst has a special development feature: the debug
320 screen. By default this module will treat responses which are the
321 debug screen as failures. If you actually want to test debug screens,
324 $mech->{catalyst_debug} = 1;
326 An alternative to this module is L<Catalyst::Test>.
332 Behaves like, and calls, L<WWW::Mechanize>'s C<new> method. Any params
333 passed in get passed to WWW::Mechanize's constructor. Note that we
334 need to pass the name of the Catalyst application to the "use":
336 use Test::WWW::Mechanize::Catalyst 'Catty';
337 my $mech = Test::WWW::Mechanize::Catalyst->new;
341 =head2 allow_external
343 Links which do not begin with / or are not for localhost can be handled
344 as normal Web requests - this is handy if you have an external
345 single sign-on system. You must set allow_external to true for this:
347 $mech->allow_external(1);
351 The name of the Catalyst app which we are testing against. Read-only.
355 The host value to set the "Host:" HTTP header to, if none is present already in
356 the request. If not set (default) then Catalyst::Test will set this to
361 Unset the host attribute.
365 Do we have a value set for the host attribute
367 =head2 $mech->get_ok($url, [ \%LWP_options ,] $desc)
369 A wrapper around WWW::Mechanize's get(), with similar options, except the
370 second argument needs to be a hash reference, not a hash. Returns true or
373 =head2 $mech->title_is( $str [, $desc ] )
375 Tells if the title of the page is the given string.
377 $mech->title_is( "Invoice Summary" );
379 =head2 $mech->title_like( $regex [, $desc ] )
381 Tells if the title of the page matches the given regex.
383 $mech->title_like( qr/Invoices for (.+)/
385 =head2 $mech->title_unlike( $regex [, $desc ] )
387 Tells if the title of the page does NOT match the given regex.
389 $mech->title_unlike( qr/Invoices for (.+)/
391 =head2 $mech->content_is( $str [, $desc ] )
393 Tells if the content of the page matches the given string.
395 =head2 $mech->content_contains( $str [, $desc ] )
397 Tells if the content of the page contains I<$str>.
399 =head2 $mech->content_lacks( $str [, $desc ] )
401 Tells if the content of the page lacks I<$str>.
403 =head2 $mech->content_like( $regex [, $desc ] )
405 Tells if the content of the page matches I<$regex>.
407 =head2 $mech->content_unlike( $regex [, $desc ] )
409 Tells if the content of the page does NOT match I<$regex>.
411 =head2 $mech->page_links_ok( [ $desc ] )
413 Follow all links on the current page and test for HTTP status 200
415 $mech->page_links_ok('Check all links');
417 =head2 $mech->page_links_content_like( $regex,[ $desc ] )
419 Follow all links on the current page and test their contents for I<$regex>.
421 $mech->page_links_content_like( qr/foo/,
422 'Check all links contain "foo"' );
424 =head2 $mech->page_links_content_unlike( $regex,[ $desc ] )
426 Follow all links on the current page and test their contents do not
427 contain the specified regex.
429 $mech->page_links_content_unlike(qr/Restricted/,
430 'Check all links do not contain Restricted');
432 =head2 $mech->links_ok( $links [, $desc ] )
434 Check the current page for specified links and test for HTTP status
435 200. The links may be specified as a reference to an array containing
436 L<WWW::Mechanize::Link> objects, an array of URLs, or a scalar URL
439 my @links = $mech->find_all_links( url_regex => qr/cnn\.com$/ );
440 $mech->links_ok( \@links, 'Check all links for cnn.com' );
442 my @links = qw( index.html search.html about.html );
443 $mech->links_ok( \@links, 'Check main links' );
445 $mech->links_ok( 'index.html', 'Check link to index' );
447 =head2 $mech->link_status_is( $links, $status [, $desc ] )
449 Check the current page for specified links and test for HTTP status
450 passed. The links may be specified as a reference to an array
451 containing L<WWW::Mechanize::Link> objects, an array of URLs, or a
454 my @links = $mech->links();
455 $mech->link_status_is( \@links, 403,
456 'Check all links are restricted' );
458 =head2 $mech->link_status_isnt( $links, $status [, $desc ] )
460 Check the current page for specified links and test for HTTP status
461 passed. The links may be specified as a reference to an array
462 containing L<WWW::Mechanize::Link> objects, an array of URLs, or a
465 my @links = $mech->links();
466 $mech->link_status_isnt( \@links, 404,
467 'Check all links are not 404' );
469 =head2 $mech->link_content_like( $links, $regex [, $desc ] )
471 Check the current page for specified links and test the content of
472 each against I<$regex>. The links may be specified as a reference to
473 an array containing L<WWW::Mechanize::Link> objects, an array of URLs,
474 or a scalar URL name.
476 my @links = $mech->links();
477 $mech->link_content_like( \@links, qr/Restricted/,
478 'Check all links are restricted' );
480 =head2 $mech->link_content_unlike( $links, $regex [, $desc ] )
482 Check the current page for specified links and test that the content of each
483 does not match I<$regex>. The links may be specified as a reference to
484 an array containing L<WWW::Mechanize::Link> objects, an array of URLs,
485 or a scalar URL name.
487 my @links = $mech->links();
488 $mech->link_content_like( \@links, qr/Restricted/,
489 'Check all links are restricted' );
491 =head2 follow_link_ok( \%parms [, $comment] )
493 Makes a C<follow_link()> call and executes tests on the results.
494 The link must be found, and then followed successfully. Otherwise,
497 I<%parms> is a hashref containing the params to pass to C<follow_link()>.
498 Note that the params to C<follow_link()> are a hash whereas the parms to
499 this function are a hashref. You have to call this function like:
501 $agent->follow_link_ok( {n=>3}, "looking for 3rd link" );
503 As with other test functions, C<$comment> is optional. If it is supplied
504 then it will display when running the test harness in verbose mode.
506 Returns true value if the specified link was found and followed
507 successfully. The HTTP::Response object returned by follow_link()
512 =head2 External Redirects and allow_external
514 If you use non-fully qualified urls in your test scripts (i.e. anything without
515 a host, such as C<< ->get_ok( "/foo") >> ) and your app redirects to an
516 external URL, expect to be bitten once you come back to your application's urls
517 (it will try to request them on the remote server). This is due to a limitation
520 One workaround for this is that if you are expecting to redirect to an external
521 site, clone the TWMC object and use the cloned object for the external
527 Related modules which may be of interest: L<Catalyst>,
528 L<Test::WWW::Mechanize>, L<WWW::Mechanize>.
532 Ash Berlin C<< <ash@cpan.org> >> (current maintiner)
534 Original Author: Leon Brocard, C<< <acme@astray.com> >>
538 Copyright (C) 2005-9, Leon Brocard
542 This module is free software; you can redistribute it or modify it
543 under the same terms as Perl itself.