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.55';
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 _set_host_header {
130 my ( $self, $request ) = @_;
131 # If there's no Host header, set one.
132 unless ($request->header('Host')) {
133 my $host = $self->has_host
135 : $request->uri->host;
136 $host .= ':'.$request->uri->_port if $request->uri->_port;
137 $request->header('Host', $host);
141 sub _do_catalyst_request {
142 my ($self, $request) = @_;
144 my $uri = $request->uri;
145 $uri->scheme('http') unless defined $uri->scheme;
146 $uri->host('localhost') unless defined $uri->host;
148 $request = $self->prepare_request($request);
149 $self->cookie_jar->add_cookie_header($request) if $self->cookie_jar;
151 # Woe betide anyone who unsets CATALYST_SERVER
152 return $self->_do_remote_request($request)
153 if $ENV{CATALYST_SERVER};
155 $self->_set_host_header($request);
157 my $res = $self->_check_external_request($request);
160 my @creds = $self->get_basic_credentials( "Basic", $uri );
161 $request->authorization_basic( @creds ) if @creds;
164 my $response = $Catalyst::VERSION >= 5.89000 ?
165 Catalyst::Test::_local_request($self->{catalyst_app}, $request) :
166 Catalyst::Test::local_request($self->{catalyst_app}, $request);
169 # LWP would normally do this, but we dont get down that far.
170 $response->request($request);
175 sub _check_external_request {
176 my ($self, $request) = @_;
178 # If there's no host then definatley not an external request.
179 $request->uri->can('host_port') or return;
181 if ( $self->allow_external && $request->uri->host_port ne 'localhost:80' ) {
182 return $self->SUPER::_make_request($request);
187 sub _do_remote_request {
188 my ($self, $request) = @_;
190 my $res = $self->_check_external_request($request);
193 my $server = URI->new( $ENV{CATALYST_SERVER} );
195 if ( $server->path =~ m|^(.+)?/$| ) {
197 $server->path("$path") if $path; # need to be quoted
200 # the request path needs to be sanitised if $server is using a
201 # non-root path due to potential overlap between request path and
204 # If request path is '/', we have to add a trailing slash to the
206 my $add_trailing = $request->uri->path eq '/';
208 my @sp = split '/', $server->path;
209 my @rp = split '/', $request->uri->path;
210 shift @sp;shift @rp; # leading /
212 foreach my $sp (@sp) {
213 $sp eq $rp[0] ? shift @rp : last
216 $request->uri->path(join '/', @rp);
218 if ( $add_trailing ) {
219 $request->uri->path( $request->uri->path . '/' );
223 $request->uri->scheme( $server->scheme );
224 $request->uri->host( $server->host );
225 $request->uri->port( $server->port );
226 $request->uri->path( $server->path . $request->uri->path );
227 $self->_set_host_header($request);
228 return $self->SUPER::_make_request($request);
232 my ($class, $app) = @_;
235 Class::MOP::load_class($app)
236 unless (Class::MOP::is_class_loaded($app));
249 Test::WWW::Mechanize::Catalyst - Test::WWW::Mechanize for Catalyst
253 # We're in a t/*.t test script...
254 use Test::WWW::Mechanize::Catalyst;
256 # To test a Catalyst application named 'Catty':
257 my $mech = Test::WWW::Mechanize::Catalyst->new(catalyst_app => 'Catty');
259 $mech->get_ok("/"); # no hostname needed
260 is($mech->ct, "text/html");
261 $mech->title_is("Root", "On the root page");
262 $mech->content_contains("This is the root page", "Correct content");
263 $mech->follow_link_ok({text => 'Hello'}, "Click on Hello");
264 # ... and all other Test::WWW::Mechanize methods
266 # White label site testing
267 $mech->host("foo.com");
272 L<Catalyst> is an elegant MVC Web Application Framework.
273 L<Test::WWW::Mechanize> is a subclass of L<WWW::Mechanize> that incorporates
274 features for web application testing. The L<Test::WWW::Mechanize::Catalyst>
275 module meshes the two to allow easy testing of L<Catalyst> applications without
276 needing to start up a web server.
278 Testing web applications has always been a bit tricky, normally
279 requiring starting a web server for your application and making real HTTP
280 requests to it. This module allows you to test L<Catalyst> web
281 applications but does not require a server or issue HTTP
282 requests. Instead, it passes the HTTP request object directly to
283 L<Catalyst>. Thus you do not need to use a real hostname:
284 "http://localhost/" will do. However, this is optional. The following
285 two lines of code do exactly the same thing:
287 $mech->get_ok('/action');
288 $mech->get_ok('http://localhost/action');
290 Links which do not begin with / or are not for localhost can be handled
291 as normal Web requests - this is handy if you have an external
292 single sign-on system. You must set allow_external to true for this:
294 $mech->allow_external(1);
296 You can also test a remote server by setting the environment variable
297 CATALYST_SERVER; for example:
299 $ CATALYST_SERVER=http://example.com/myapp prove -l t
301 will run the same tests on the application running at
302 http://example.com/myapp regardless of whether or not you specify
303 http:://localhost for Test::WWW::Mechanize::Catalyst.
305 Furthermore, if you set CATALYST_SERVER, the server will be regarded
306 as a remote server even if your links point to localhost. Thus, you
307 can use Test::WWW::Mechanize::Catalyst to test your live webserver
308 running on your local machine, if you need to test aspects of your
309 deployment environment (for example, configuration options in an
310 http.conf file) instead of just the Catalyst request handling.
312 This makes testing fast and easy. L<Test::WWW::Mechanize> provides
313 functions for common web testing scenarios. For example:
315 $mech->get_ok( $page );
316 $mech->title_is( "Invoice Status", "Make sure we're on the invoice page" );
317 $mech->content_contains( "Andy Lester", "My name somewhere" );
318 $mech->content_like( qr/(cpan|perl)\.org/, "Link to perl.org or CPAN" );
320 This module supports cookies automatically.
322 To use this module you must pass it the name of the application. See
325 Note that Catalyst has a special development feature: the debug
326 screen. By default this module will treat responses which are the
327 debug screen as failures. If you actually want to test debug screens,
330 $mech->{catalyst_debug} = 1;
332 An alternative to this module is L<Catalyst::Test>.
338 Behaves like, and calls, L<WWW::Mechanize>'s C<new> method. Any params
339 passed in get passed to WWW::Mechanize's constructor. Note that we
340 need to pass the name of the Catalyst application to the "use":
342 use Test::WWW::Mechanize::Catalyst 'Catty';
343 my $mech = Test::WWW::Mechanize::Catalyst->new;
347 =head2 allow_external
349 Links which do not begin with / or are not for localhost can be handled
350 as normal Web requests - this is handy if you have an external
351 single sign-on system. You must set allow_external to true for this:
353 $mech->allow_external(1);
357 The name of the Catalyst app which we are testing against. Read-only.
361 The host value to set the "Host:" HTTP header to, if none is present already in
362 the request. If not set (default) then Catalyst::Test will set this to
367 Unset the host attribute.
371 Do we have a value set for the host attribute
373 =head2 $mech->get_ok($url, [ \%LWP_options ,] $desc)
375 A wrapper around WWW::Mechanize's get(), with similar options, except the
376 second argument needs to be a hash reference, not a hash. Returns true or
379 =head2 $mech->title_is( $str [, $desc ] )
381 Tells if the title of the page is the given string.
383 $mech->title_is( "Invoice Summary" );
385 =head2 $mech->title_like( $regex [, $desc ] )
387 Tells if the title of the page matches the given regex.
389 $mech->title_like( qr/Invoices for (.+)/
391 =head2 $mech->title_unlike( $regex [, $desc ] )
393 Tells if the title of the page does NOT match the given regex.
395 $mech->title_unlike( qr/Invoices for (.+)/
397 =head2 $mech->content_is( $str [, $desc ] )
399 Tells if the content of the page matches the given string.
401 =head2 $mech->content_contains( $str [, $desc ] )
403 Tells if the content of the page contains I<$str>.
405 =head2 $mech->content_lacks( $str [, $desc ] )
407 Tells if the content of the page lacks I<$str>.
409 =head2 $mech->content_like( $regex [, $desc ] )
411 Tells if the content of the page matches I<$regex>.
413 =head2 $mech->content_unlike( $regex [, $desc ] )
415 Tells if the content of the page does NOT match I<$regex>.
417 =head2 $mech->page_links_ok( [ $desc ] )
419 Follow all links on the current page and test for HTTP status 200
421 $mech->page_links_ok('Check all links');
423 =head2 $mech->page_links_content_like( $regex,[ $desc ] )
425 Follow all links on the current page and test their contents for I<$regex>.
427 $mech->page_links_content_like( qr/foo/,
428 'Check all links contain "foo"' );
430 =head2 $mech->page_links_content_unlike( $regex,[ $desc ] )
432 Follow all links on the current page and test their contents do not
433 contain the specified regex.
435 $mech->page_links_content_unlike(qr/Restricted/,
436 'Check all links do not contain Restricted');
438 =head2 $mech->links_ok( $links [, $desc ] )
440 Check the current page for specified links and test for HTTP status
441 200. The links may be specified as a reference to an array containing
442 L<WWW::Mechanize::Link> objects, an array of URLs, or a scalar URL
445 my @links = $mech->find_all_links( url_regex => qr/cnn\.com$/ );
446 $mech->links_ok( \@links, 'Check all links for cnn.com' );
448 my @links = qw( index.html search.html about.html );
449 $mech->links_ok( \@links, 'Check main links' );
451 $mech->links_ok( 'index.html', 'Check link to index' );
453 =head2 $mech->link_status_is( $links, $status [, $desc ] )
455 Check the current page for specified links and test for HTTP status
456 passed. The links may be specified as a reference to an array
457 containing L<WWW::Mechanize::Link> objects, an array of URLs, or a
460 my @links = $mech->links();
461 $mech->link_status_is( \@links, 403,
462 'Check all links are restricted' );
464 =head2 $mech->link_status_isnt( $links, $status [, $desc ] )
466 Check the current page for specified links and test for HTTP status
467 passed. The links may be specified as a reference to an array
468 containing L<WWW::Mechanize::Link> objects, an array of URLs, or a
471 my @links = $mech->links();
472 $mech->link_status_isnt( \@links, 404,
473 'Check all links are not 404' );
475 =head2 $mech->link_content_like( $links, $regex [, $desc ] )
477 Check the current page for specified links and test the content of
478 each against I<$regex>. The links may be specified as a reference to
479 an array containing L<WWW::Mechanize::Link> objects, an array of URLs,
480 or a scalar URL name.
482 my @links = $mech->links();
483 $mech->link_content_like( \@links, qr/Restricted/,
484 'Check all links are restricted' );
486 =head2 $mech->link_content_unlike( $links, $regex [, $desc ] )
488 Check the current page for specified links and test that the content of each
489 does not match I<$regex>. The links may be specified as a reference to
490 an array containing L<WWW::Mechanize::Link> objects, an array of URLs,
491 or a scalar URL name.
493 my @links = $mech->links();
494 $mech->link_content_like( \@links, qr/Restricted/,
495 'Check all links are restricted' );
497 =head2 follow_link_ok( \%parms [, $comment] )
499 Makes a C<follow_link()> call and executes tests on the results.
500 The link must be found, and then followed successfully. Otherwise,
503 I<%parms> is a hashref containing the params to pass to C<follow_link()>.
504 Note that the params to C<follow_link()> are a hash whereas the parms to
505 this function are a hashref. You have to call this function like:
507 $agent->follow_link_ok( {n=>3}, "looking for 3rd link" );
509 As with other test functions, C<$comment> is optional. If it is supplied
510 then it will display when running the test harness in verbose mode.
512 Returns true value if the specified link was found and followed
513 successfully. The HTTP::Response object returned by follow_link()
518 =head2 External Redirects and allow_external
520 If you use non-fully qualified urls in your test scripts (i.e. anything without
521 a host, such as C<< ->get_ok( "/foo") >> ) and your app redirects to an
522 external URL, expect to be bitten once you come back to your application's urls
523 (it will try to request them on the remote server). This is due to a limitation
526 One workaround for this is that if you are expecting to redirect to an external
527 site, clone the TWMC object and use the cloned object for the external
533 Related modules which may be of interest: L<Catalyst>,
534 L<Test::WWW::Mechanize>, L<WWW::Mechanize>.
538 Ash Berlin C<< <ash@cpan.org> >> (current maintiner)
540 Original Author: Leon Brocard, C<< <acme@astray.com> >>
544 Copyright (C) 2005-9, Leon Brocard
548 This module is free software; you can redistribute it or modify it
549 under the same terms as Perl itself.