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 $request->header('Host', $host);
140 sub _do_catalyst_request {
141 my ($self, $request) = @_;
143 my $uri = $request->uri;
144 $uri->scheme('http') unless defined $uri->scheme;
145 $uri->host('localhost') unless defined $uri->host;
147 $request = $self->prepare_request($request);
148 $self->cookie_jar->add_cookie_header($request) if $self->cookie_jar;
150 # Woe betide anyone who unsets CATALYST_SERVER
151 return $self->_do_remote_request($request)
152 if $ENV{CATALYST_SERVER};
154 $self->_set_host_header($request);
156 my $res = $self->_check_external_request($request);
159 my @creds = $self->get_basic_credentials( "Basic", $uri );
160 $request->authorization_basic( @creds ) if @creds;
163 my $response = $Catalyst::VERSION >= 5.89000 ?
164 Catalyst::Test::_local_request($self->{catalyst_app}, $request) :
165 Catalyst::Test::local_request($self->{catalyst_app}, $request);
168 # LWP would normally do this, but we dont get down that far.
169 $response->request($request);
174 sub _check_external_request {
175 my ($self, $request) = @_;
177 # If there's no host then definatley not an external request.
178 $request->uri->can('host_port') or return;
180 if ( $self->allow_external && $request->uri->host_port ne 'localhost:80' ) {
181 return $self->SUPER::_make_request($request);
186 sub _do_remote_request {
187 my ($self, $request) = @_;
189 my $res = $self->_check_external_request($request);
192 my $server = URI->new( $ENV{CATALYST_SERVER} );
194 if ( $server->path =~ m|^(.+)?/$| ) {
196 $server->path("$path") if $path; # need to be quoted
199 # the request path needs to be sanitised if $server is using a
200 # non-root path due to potential overlap between request path and
203 # If request path is '/', we have to add a trailing slash to the
205 my $add_trailing = $request->uri->path eq '/';
207 my @sp = split '/', $server->path;
208 my @rp = split '/', $request->uri->path;
209 shift @sp;shift @rp; # leading /
211 foreach my $sp (@sp) {
212 $sp eq $rp[0] ? shift @rp : last
215 $request->uri->path(join '/', @rp);
217 if ( $add_trailing ) {
218 $request->uri->path( $request->uri->path . '/' );
222 $request->uri->scheme( $server->scheme );
223 $request->uri->host( $server->host );
224 $request->uri->port( $server->port );
225 $request->uri->path( $server->path . $request->uri->path );
226 $self->_set_host_header($request);
227 return $self->SUPER::_make_request($request);
231 my ($class, $app) = @_;
234 Class::MOP::load_class($app)
235 unless (Class::MOP::is_class_loaded($app));
248 Test::WWW::Mechanize::Catalyst - Test::WWW::Mechanize for Catalyst
252 # We're in a t/*.t test script...
253 use Test::WWW::Mechanize::Catalyst;
255 # To test a Catalyst application named 'Catty':
256 my $mech = Test::WWW::Mechanize::Catalyst->new(catalyst_app => 'Catty');
258 $mech->get_ok("/"); # no hostname needed
259 is($mech->ct, "text/html");
260 $mech->title_is("Root", "On the root page");
261 $mech->content_contains("This is the root page", "Correct content");
262 $mech->follow_link_ok({text => 'Hello'}, "Click on Hello");
263 # ... and all other Test::WWW::Mechanize methods
265 # White label site testing
266 $mech->host("foo.com");
271 L<Catalyst> is an elegant MVC Web Application Framework.
272 L<Test::WWW::Mechanize> is a subclass of L<WWW::Mechanize> that incorporates
273 features for web application testing. The L<Test::WWW::Mechanize::Catalyst>
274 module meshes the two to allow easy testing of L<Catalyst> applications without
275 needing to start up a web server.
277 Testing web applications has always been a bit tricky, normally
278 requiring starting a web server for your application and making real HTTP
279 requests to it. This module allows you to test L<Catalyst> web
280 applications but does not require a server or issue HTTP
281 requests. Instead, it passes the HTTP request object directly to
282 L<Catalyst>. Thus you do not need to use a real hostname:
283 "http://localhost/" will do. However, this is optional. The following
284 two lines of code do exactly the same thing:
286 $mech->get_ok('/action');
287 $mech->get_ok('http://localhost/action');
289 Links which do not begin with / or are not for localhost can be handled
290 as normal Web requests - this is handy if you have an external
291 single sign-on system. You must set allow_external to true for this:
293 $mech->allow_external(1);
295 You can also test a remote server by setting the environment variable
296 CATALYST_SERVER; for example:
298 $ CATALYST_SERVER=http://example.com/myapp prove -l t
300 will run the same tests on the application running at
301 http://example.com/myapp regardless of whether or not you specify
302 http:://localhost for Test::WWW::Mechanize::Catalyst.
304 Furthermore, if you set CATALYST_SERVER, the server will be regarded
305 as a remote server even if your links point to localhost. Thus, you
306 can use Test::WWW::Mechanize::Catalyst to test your live webserver
307 running on your local machine, if you need to test aspects of your
308 deployment environment (for example, configuration options in an
309 http.conf file) instead of just the Catalyst request handling.
311 This makes testing fast and easy. L<Test::WWW::Mechanize> provides
312 functions for common web testing scenarios. For example:
314 $mech->get_ok( $page );
315 $mech->title_is( "Invoice Status", "Make sure we're on the invoice page" );
316 $mech->content_contains( "Andy Lester", "My name somewhere" );
317 $mech->content_like( qr/(cpan|perl)\.org/, "Link to perl.org or CPAN" );
319 This module supports cookies automatically.
321 To use this module you must pass it the name of the application. See
324 Note that Catalyst has a special development feature: the debug
325 screen. By default this module will treat responses which are the
326 debug screen as failures. If you actually want to test debug screens,
329 $mech->{catalyst_debug} = 1;
331 An alternative to this module is L<Catalyst::Test>.
337 Behaves like, and calls, L<WWW::Mechanize>'s C<new> method. Any params
338 passed in get passed to WWW::Mechanize's constructor. Note that we
339 need to pass the name of the Catalyst application to the "use":
341 use Test::WWW::Mechanize::Catalyst 'Catty';
342 my $mech = Test::WWW::Mechanize::Catalyst->new;
346 =head2 allow_external
348 Links which do not begin with / or are not for localhost can be handled
349 as normal Web requests - this is handy if you have an external
350 single sign-on system. You must set allow_external to true for this:
352 $mech->allow_external(1);
356 The name of the Catalyst app which we are testing against. Read-only.
360 The host value to set the "Host:" HTTP header to, if none is present already in
361 the request. If not set (default) then Catalyst::Test will set this to
366 Unset the host attribute.
370 Do we have a value set for the host attribute
372 =head2 $mech->get_ok($url, [ \%LWP_options ,] $desc)
374 A wrapper around WWW::Mechanize's get(), with similar options, except the
375 second argument needs to be a hash reference, not a hash. Returns true or
378 =head2 $mech->title_is( $str [, $desc ] )
380 Tells if the title of the page is the given string.
382 $mech->title_is( "Invoice Summary" );
384 =head2 $mech->title_like( $regex [, $desc ] )
386 Tells if the title of the page matches the given regex.
388 $mech->title_like( qr/Invoices for (.+)/
390 =head2 $mech->title_unlike( $regex [, $desc ] )
392 Tells if the title of the page does NOT match the given regex.
394 $mech->title_unlike( qr/Invoices for (.+)/
396 =head2 $mech->content_is( $str [, $desc ] )
398 Tells if the content of the page matches the given string.
400 =head2 $mech->content_contains( $str [, $desc ] )
402 Tells if the content of the page contains I<$str>.
404 =head2 $mech->content_lacks( $str [, $desc ] )
406 Tells if the content of the page lacks I<$str>.
408 =head2 $mech->content_like( $regex [, $desc ] )
410 Tells if the content of the page matches I<$regex>.
412 =head2 $mech->content_unlike( $regex [, $desc ] )
414 Tells if the content of the page does NOT match I<$regex>.
416 =head2 $mech->page_links_ok( [ $desc ] )
418 Follow all links on the current page and test for HTTP status 200
420 $mech->page_links_ok('Check all links');
422 =head2 $mech->page_links_content_like( $regex,[ $desc ] )
424 Follow all links on the current page and test their contents for I<$regex>.
426 $mech->page_links_content_like( qr/foo/,
427 'Check all links contain "foo"' );
429 =head2 $mech->page_links_content_unlike( $regex,[ $desc ] )
431 Follow all links on the current page and test their contents do not
432 contain the specified regex.
434 $mech->page_links_content_unlike(qr/Restricted/,
435 'Check all links do not contain Restricted');
437 =head2 $mech->links_ok( $links [, $desc ] )
439 Check the current page for specified links and test for HTTP status
440 200. The links may be specified as a reference to an array containing
441 L<WWW::Mechanize::Link> objects, an array of URLs, or a scalar URL
444 my @links = $mech->find_all_links( url_regex => qr/cnn\.com$/ );
445 $mech->links_ok( \@links, 'Check all links for cnn.com' );
447 my @links = qw( index.html search.html about.html );
448 $mech->links_ok( \@links, 'Check main links' );
450 $mech->links_ok( 'index.html', 'Check link to index' );
452 =head2 $mech->link_status_is( $links, $status [, $desc ] )
454 Check the current page for specified links and test for HTTP status
455 passed. The links may be specified as a reference to an array
456 containing L<WWW::Mechanize::Link> objects, an array of URLs, or a
459 my @links = $mech->links();
460 $mech->link_status_is( \@links, 403,
461 'Check all links are restricted' );
463 =head2 $mech->link_status_isnt( $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_isnt( \@links, 404,
472 'Check all links are not 404' );
474 =head2 $mech->link_content_like( $links, $regex [, $desc ] )
476 Check the current page for specified links and test the content of
477 each against I<$regex>. The links may be specified as a reference to
478 an array containing L<WWW::Mechanize::Link> objects, an array of URLs,
479 or a scalar URL name.
481 my @links = $mech->links();
482 $mech->link_content_like( \@links, qr/Restricted/,
483 'Check all links are restricted' );
485 =head2 $mech->link_content_unlike( $links, $regex [, $desc ] )
487 Check the current page for specified links and test that the content of each
488 does not match 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 follow_link_ok( \%parms [, $comment] )
498 Makes a C<follow_link()> call and executes tests on the results.
499 The link must be found, and then followed successfully. Otherwise,
502 I<%parms> is a hashref containing the params to pass to C<follow_link()>.
503 Note that the params to C<follow_link()> are a hash whereas the parms to
504 this function are a hashref. You have to call this function like:
506 $agent->follow_link_ok( {n=>3}, "looking for 3rd link" );
508 As with other test functions, C<$comment> is optional. If it is supplied
509 then it will display when running the test harness in verbose mode.
511 Returns true value if the specified link was found and followed
512 successfully. The HTTP::Response object returned by follow_link()
517 =head2 External Redirects and allow_external
519 If you use non-fully qualified urls in your test scripts (i.e. anything without
520 a host, such as C<< ->get_ok( "/foo") >> ) and your app redirects to an
521 external URL, expect to be bitten once you come back to your application's urls
522 (it will try to request them on the remote server). This is due to a limitation
525 One workaround for this is that if you are expecting to redirect to an external
526 site, clone the TWMC object and use the cloned object for the external
532 Related modules which may be of interest: L<Catalyst>,
533 L<Test::WWW::Mechanize>, L<WWW::Mechanize>.
537 Ash Berlin C<< <ash@cpan.org> >> (current maintiner)
539 Original Author: Leon Brocard, C<< <acme@astray.com> >>
543 Copyright (C) 2005-9, Leon Brocard
547 This module is free software; you can redistribute it or modify it
548 under the same terms as Perl itself.