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.50_1';
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 $obj = $class->SUPER::new(@_);
41 my $self = $class->meta->new_object(
43 ($APP_CLASS ? (catalyst_app => $APP_CLASS) : () ),
47 unless ($ENV{CATALYST_SERVER}) {
48 croak "catalyst_app attribute is required unless CATALYST_SERVER env variable is set"
49 unless $self->has_catalyst_app;
50 Class::MOP::load_class($self->catalyst_app)
51 unless (Class::MOP::is_class_loaded($self->catalyst_app));
58 my ( $self, $request ) = @_;
60 my $response = $self->_do_catalyst_request($request);
61 $response->header( 'Content-Base', $request->uri );
62 $response->request($request);
63 if ( $request->uri->as_string =~ m{^/} ) {
65 URI->new( 'http://localhost:80/' . $request->uri->as_string ) );
67 $self->cookie_jar->extract_cookies($response) if $self->cookie_jar;
69 # fail tests under the Catalyst debug screen
70 if ( !$self->{catalyst_debug}
71 && $response->code == 500
72 && $response->content =~ /on Catalyst \d+\.\d+/ )
75 = ( $response->content =~ /<code class="error">(.*?)<\/code>/s );
76 $error ||= "unknown error";
77 decode_entities($error);
78 $Test->diag("Catalyst error screen: $error");
79 $response->content('');
80 $response->content_type('');
83 # check if that was a redirect
84 if ( $response->header('Location')
85 && $self->redirect_ok( $request, $response ) )
88 # remember the old response
89 my $old_response = $response;
91 # *where* do they want us to redirect to?
92 my $location = $old_response->header('Location');
94 # no-one *should* be returning non-absolute URLs, but if they
95 # are then we'd better cope with it. Let's create a new URI, using
96 # our request as the base.
97 my $uri = URI->new_abs( $location, $request->uri )->as_string;
99 # make a new response, and save the old response in it
100 $response = $self->_make_request( HTTP::Request->new( GET => $uri ) );
101 my $end_of_chain = $response;
102 while ( $end_of_chain->previous ) # keep going till the end
104 $end_of_chain = $end_of_chain->previous;
106 $end_of_chain->previous($old_response); # ...and add us to it
108 $response->{_raw_content} = $response->content;
114 sub _do_catalyst_request {
115 my ($self, $request) = @_;
117 $self->cookie_jar->add_cookie_header($request) if $self->cookie_jar;
119 # Woe betide anyone who unsets CATALYST_SERVER
120 return Catalyst::Test::remote_request($request)
121 if $ENV{CATALYST_SERVER};
123 my $uri = $request->uri;
124 if ($uri->as_string =~ m{^/}) {
125 $uri->scheme('http');
126 $uri->host('localhost');
130 # If there's no Host header, set one.
131 unless ($request->header('Host')) {
132 my $host = $self->has_host
136 $request->header('Host', $host);
139 if ( $self->{allow_external} ) {
140 unless ( $request->uri->as_string =~ m{^/}
141 || $request->uri->host eq 'localhost' )
143 return $self->SUPER::_make_request($request);
147 my @creds = $self->get_basic_credentials( "Basic", $uri );
148 $request->authorization_basic( @creds ) if @creds;
150 return Catalyst::Test::local_request($self->{catalyst_app}, $request);
154 my ($class, $app) = @_;
157 Class::MOP::load_class($app)
158 unless (Class::MOP::is_class_loaded($app));
171 Test::WWW::Mechanize::Catalyst - Test::WWW::Mechanize for Catalyst
175 # We're in a t/*.t test script...
176 use Test::WWW::Mechanize::Catalyst;
178 # To test a Catalyst application named 'Catty':
179 my $mech = Test::WWW::Mechanize::Catalyst->new(catalyst_app => 'Catty');
181 $mech->get_ok("/"); # no hostname needed
182 is($mech->ct, "text/html");
183 $mech->title_is("Root", "On the root page");
184 $mech->content_contains("This is the root page", "Correct content");
185 $mech->follow_link_ok({text => 'Hello'}, "Click on Hello");
186 # ... and all other Test::WWW::Mechanize methods
188 # White label site testing
189 $mech->host("foo.com");
194 L<Catalyst> is an elegant MVC Web Application
195 Framework. L<Test::WWW::Mechanize> is a subclass of L<WWW::Mechanize> that
196 incorporates features for web application testing. The
197 L<Test::WWW::Mechanize::Catalyst> module meshes the two to allow easy
198 testing of L<Catalyst> applications without starting up a web server.
200 Testing web applications has always been a bit tricky, normally
201 starting a web server for your application and making real HTTP
202 requests to it. This module allows you to test L<Catalyst> web
203 applications but does not start a server or issue HTTP
204 requests. Instead, it passes the HTTP request object directly to
205 L<Catalyst>. Thus you do not need to use a real hostname:
206 "http://localhost/" will do. However, this is optional. The following
207 two lines of code do exactly the same thing:
209 $mech->get_ok('/action');
210 $mech->get_ok('http://localhost/action');
212 Links which do not begin with / or are not for localhost can be handled
213 as normal Web requests - this is handy if you have an external
214 single sign-on system. You must set allow_external to true for this:
216 $m->allow_external(1);
218 You can also test a remote server by setting the environment variable
219 CATALYST_SERVER, for example:
221 $ CATALYST_SERVER=http://example.com/myapp prove -l t
223 will run the same tests on the application running at
224 http://example.com/myapp regardless of whether or not you specify
225 http:://localhost for Test::WWW::Mechanize::Catalyst.
227 This makes testing fast and easy. L<Test::WWW::Mechanize> provides
228 functions for common web testing scenarios. For example:
230 $mech->get_ok( $page );
231 $mech->title_is( "Invoice Status", "Make sure we're on the invoice page" );
232 $mech->content_contains( "Andy Lester", "My name somewhere" );
233 $mech->content_like( qr/(cpan|perl)\.org/, "Link to perl.org or CPAN" );
235 This module supports cookies automatically.
237 To use this module you must pass it the name of the application. See
240 Note that Catalyst has a special developing feature: the debug
241 screen. By default this module will treat responses which are the
242 debug screen as failures. If you actually want to test debug screens,
245 $m->{catalyst_debug} = 1;
247 An alternative to this module is L<Catalyst::Test>.
253 Behaves like, and calls, L<WWW::Mechanize>'s C<new> method. Any parms
254 passed in get passed to WWW::Mechanize's constructor. Note that we
255 need to pass the name of the Catalyst application to the "use":
257 use Test::WWW::Mechanize::Catalyst 'Catty';
258 my $mech = Test::WWW::Mechanize::Catalyst->new;
262 =head2 allow_external
264 Links which do not begin with / or are not for localhost can be handled
265 as normal Web requests - this is handy if you have an external
266 single sign-on system. You must set allow_external to true for this:
268 $m->allow_external(1);
272 The name of the Catalyst app which we are testing against. Read-only.
276 The host value to set the "Host:" HTTP header to, if none is present already in
277 the request. If not set (default) then Catalyst::Test will set this to
282 Unset the host attribute.
286 Do we have a value set for the host attribute
288 =head2 $mech->get_ok($url, [ \%LWP_options ,] $desc)
290 A wrapper around WWW::Mechanize's get(), with similar options, except the
291 second argument needs to be a hash reference, not a hash. Returns true or
294 =head2 $mech->title_is( $str [, $desc ] )
296 Tells if the title of the page is the given string.
298 $mech->title_is( "Invoice Summary" );
300 =head2 $mech->title_like( $regex [, $desc ] )
302 Tells if the title of the page matches the given regex.
304 $mech->title_like( qr/Invoices for (.+)/
306 =head2 $mech->title_unlike( $regex [, $desc ] )
308 Tells if the title of the page matches the given regex.
310 $mech->title_unlike( qr/Invoices for (.+)/
312 =head2 $mech->content_is( $str [, $desc ] )
314 Tells if the content of the page matches the given string
316 =head2 $mech->content_contains( $str [, $desc ] )
318 Tells if the content of the page contains I<$str>.
320 =head2 $mech->content_lacks( $str [, $desc ] )
322 Tells if the content of the page lacks I<$str>.
324 =head2 $mech->content_like( $regex [, $desc ] )
326 Tells if the content of the page matches I<$regex>.
328 =head2 $mech->content_unlike( $regex [, $desc ] )
330 Tells if the content of the page does NOT match I<$regex>.
332 =head2 $mech->page_links_ok( [ $desc ] )
334 Follow all links on the current page and test for HTTP status 200
336 $mech->page_links_ok('Check all links');
338 =head2 $mech->page_links_content_like( $regex,[ $desc ] )
340 Follow all links on the current page and test their contents for I<$regex>.
342 $mech->page_links_content_like( qr/foo/,
343 'Check all links contain "foo"' );
345 =head2 $mech->page_links_content_unlike( $regex,[ $desc ] )
347 Follow all links on the current page and test their contents do not
348 contain the specified regex.
350 $mech->page_links_content_unlike(qr/Restricted/,
351 'Check all links do not contain Restricted');
353 =head2 $mech->links_ok( $links [, $desc ] )
355 Check the current page for specified links and test for HTTP status
356 200. The links may be specified as a reference to an array containing
357 L<WWW::Mechanize::Link> objects, an array of URLs, or a scalar URL
360 my @links = $mech->find_all_links( url_regex => qr/cnn\.com$/ );
361 $mech->links_ok( \@links, 'Check all links for cnn.com' );
363 my @links = qw( index.html search.html about.html );
364 $mech->links_ok( \@links, 'Check main links' );
366 $mech->links_ok( 'index.html', 'Check link to index' );
368 =head2 $mech->link_status_is( $links, $status [, $desc ] )
370 Check the current page for specified links and test for HTTP status
371 passed. The links may be specified as a reference to an array
372 containing L<WWW::Mechanize::Link> objects, an array of URLs, or a
375 my @links = $mech->links();
376 $mech->link_status_is( \@links, 403,
377 'Check all links are restricted' );
379 =head2 $mech->link_status_isnt( $links, $status [, $desc ] )
381 Check the current page for specified links and test for HTTP status
382 passed. The links may be specified as a reference to an array
383 containing L<WWW::Mechanize::Link> objects, an array of URLs, or a
386 my @links = $mech->links();
387 $mech->link_status_isnt( \@links, 404,
388 'Check all links are not 404' );
390 =head2 $mech->link_content_like( $links, $regex [, $desc ] )
392 Check the current page for specified links and test the content of
393 each against I<$regex>. The links may be specified as a reference to
394 an array containing L<WWW::Mechanize::Link> objects, an array of URLs,
395 or a scalar URL name.
397 my @links = $mech->links();
398 $mech->link_content_like( \@links, qr/Restricted/,
399 'Check all links are restricted' );
401 =head2 $mech->link_content_unlike( $links, $regex [, $desc ] )
403 Check the current page for specified links and test the content of each
404 does not match I<$regex>. The links may be specified as a reference to
405 an array containing L<WWW::Mechanize::Link> objects, an array of URLs,
406 or a scalar URL name.
408 my @links = $mech->links();
409 $mech->link_content_like( \@links, qr/Restricted/,
410 'Check all links are restricted' );
412 =head2 follow_link_ok( \%parms [, $comment] )
414 Makes a C<follow_link()> call and executes tests on the results.
415 The link must be found, and then followed successfully. Otherwise,
418 I<%parms> is a hashref containing the parms to pass to C<follow_link()>.
419 Note that the parms to C<follow_link()> are a hash whereas the parms to
420 this function are a hashref. You have to call this function like:
422 $agent->follow_like_ok( {n=>3}, "looking for 3rd link" );
424 As with other test functions, C<$comment> is optional. If it is supplied
425 then it will display when running the test harness in verbose mode.
427 Returns true value if the specified link was found and followed
428 successfully. The HTTP::Response object returned by follow_link()
433 Related modules which may be of interest: L<Catalyst>,
434 L<Test::WWW::Mechanize>, L<WWW::Mechanize>.
438 Ash Berlin C<< <ash@cpan.org> >> (current maintiner)
440 Original Author: Leon Brocard, C<< <acme@astray.com> >>
444 Copyright (C) 2005-8, Leon Brocard
448 This module is free software; you can redistribute it or modify it
449 under the same terms as Perl itself.