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';
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', $request->uri );
79 $response->request($request);
80 if ( $request->uri->as_string =~ m{^/} ) {
82 URI->new( 'http://localhost:80/' . $request->uri->as_string ) );
84 $self->cookie_jar->extract_cookies($response) if $self->cookie_jar;
86 # fail tests under the Catalyst debug screen
87 if ( !$self->{catalyst_debug}
88 && $response->code == 500
89 && $response->content =~ /on Catalyst \d+\.\d+/ )
92 = ( $response->content =~ /<code class="error">(.*?)<\/code>/s );
93 $error ||= "unknown error";
94 decode_entities($error);
95 $Test->diag("Catalyst error screen: $error");
96 $response->content('');
97 $response->content_type('');
100 # check if that was a redirect
101 if ( $response->header('Location')
102 && $self->redirect_ok( $request, $response ) )
105 # remember the old response
106 my $old_response = $response;
108 # *where* do they want us to redirect to?
109 my $location = $old_response->header('Location');
111 # no-one *should* be returning non-absolute URLs, but if they
112 # are then we'd better cope with it. Let's create a new URI, using
113 # our request as the base.
114 my $uri = URI->new_abs( $location, $request->uri )->as_string;
116 # make a new response, and save the old response in it
117 $response = $self->_make_request( HTTP::Request->new( GET => $uri ) );
118 my $end_of_chain = $response;
119 while ( $end_of_chain->previous ) # keep going till the end
121 $end_of_chain = $end_of_chain->previous;
123 $end_of_chain->previous($old_response); # ...and add us to it
125 $response->{_raw_content} = $response->content;
131 sub _do_catalyst_request {
132 my ($self, $request) = @_;
134 my $uri = $request->uri;
135 $uri->scheme('http') unless defined $uri->scheme;
136 $uri->host('localhost') unless defined $uri->host;
138 $self->cookie_jar->add_cookie_header($request) if $self->cookie_jar;
140 # Woe betide anyone who unsets CATALYST_SERVER
141 return Catalyst::Test::remote_request($request)
142 if $ENV{CATALYST_SERVER};
146 # If there's no Host header, set one.
147 unless ($request->header('Host')) {
148 my $host = $self->has_host
152 $request->header('Host', $host);
155 if ( $self->{allow_external} ) {
156 unless ( $request->uri->as_string =~ m{^/}
157 || $request->uri->host eq 'localhost' )
159 return $self->SUPER::_make_request($request);
163 my @creds = $self->get_basic_credentials( "Basic", $uri );
164 $request->authorization_basic( @creds ) if @creds;
166 return Catalyst::Test::local_request($self->{catalyst_app}, $request);
170 my ($class, $app) = @_;
173 Class::MOP::load_class($app)
174 unless (Class::MOP::is_class_loaded($app));
187 Test::WWW::Mechanize::Catalyst - Test::WWW::Mechanize for Catalyst
191 # We're in a t/*.t test script...
192 use Test::WWW::Mechanize::Catalyst;
194 # To test a Catalyst application named 'Catty':
195 my $mech = Test::WWW::Mechanize::Catalyst->new(catalyst_app => 'Catty');
197 $mech->get_ok("/"); # no hostname needed
198 is($mech->ct, "text/html");
199 $mech->title_is("Root", "On the root page");
200 $mech->content_contains("This is the root page", "Correct content");
201 $mech->follow_link_ok({text => 'Hello'}, "Click on Hello");
202 # ... and all other Test::WWW::Mechanize methods
204 # White label site testing
205 $mech->host("foo.com");
210 L<Catalyst> is an elegant MVC Web Application
211 Framework. L<Test::WWW::Mechanize> is a subclass of L<WWW::Mechanize> that
212 incorporates features for web application testing. The
213 L<Test::WWW::Mechanize::Catalyst> module meshes the two to allow easy
214 testing of L<Catalyst> applications without starting up a web server.
216 Testing web applications has always been a bit tricky, normally
217 starting a web server for your application and making real HTTP
218 requests to it. This module allows you to test L<Catalyst> web
219 applications but does not start a server or issue HTTP
220 requests. Instead, it passes the HTTP request object directly to
221 L<Catalyst>. Thus you do not need to use a real hostname:
222 "http://localhost/" will do. However, this is optional. The following
223 two lines of code do exactly the same thing:
225 $mech->get_ok('/action');
226 $mech->get_ok('http://localhost/action');
228 Links which do not begin with / or are not for localhost can be handled
229 as normal Web requests - this is handy if you have an external
230 single sign-on system. You must set allow_external to true for this:
232 $m->allow_external(1);
234 You can also test a remote server by setting the environment variable
235 CATALYST_SERVER, for example:
237 $ CATALYST_SERVER=http://example.com/myapp prove -l t
239 will run the same tests on the application running at
240 http://example.com/myapp regardless of whether or not you specify
241 http:://localhost for Test::WWW::Mechanize::Catalyst.
243 This makes testing fast and easy. L<Test::WWW::Mechanize> provides
244 functions for common web testing scenarios. For example:
246 $mech->get_ok( $page );
247 $mech->title_is( "Invoice Status", "Make sure we're on the invoice page" );
248 $mech->content_contains( "Andy Lester", "My name somewhere" );
249 $mech->content_like( qr/(cpan|perl)\.org/, "Link to perl.org or CPAN" );
251 This module supports cookies automatically.
253 To use this module you must pass it the name of the application. See
256 Note that Catalyst has a special developing feature: the debug
257 screen. By default this module will treat responses which are the
258 debug screen as failures. If you actually want to test debug screens,
261 $m->{catalyst_debug} = 1;
263 An alternative to this module is L<Catalyst::Test>.
269 Behaves like, and calls, L<WWW::Mechanize>'s C<new> method. Any parms
270 passed in get passed to WWW::Mechanize's constructor. Note that we
271 need to pass the name of the Catalyst application to the "use":
273 use Test::WWW::Mechanize::Catalyst 'Catty';
274 my $mech = Test::WWW::Mechanize::Catalyst->new;
278 =head2 allow_external
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 $m->allow_external(1);
288 The name of the Catalyst app which we are testing against. Read-only.
292 The host value to set the "Host:" HTTP header to, if none is present already in
293 the request. If not set (default) then Catalyst::Test will set this to
298 Unset the host attribute.
302 Do we have a value set for the host attribute
304 =head2 $mech->get_ok($url, [ \%LWP_options ,] $desc)
306 A wrapper around WWW::Mechanize's get(), with similar options, except the
307 second argument needs to be a hash reference, not a hash. Returns true or
310 =head2 $mech->title_is( $str [, $desc ] )
312 Tells if the title of the page is the given string.
314 $mech->title_is( "Invoice Summary" );
316 =head2 $mech->title_like( $regex [, $desc ] )
318 Tells if the title of the page matches the given regex.
320 $mech->title_like( qr/Invoices for (.+)/
322 =head2 $mech->title_unlike( $regex [, $desc ] )
324 Tells if the title of the page matches the given regex.
326 $mech->title_unlike( qr/Invoices for (.+)/
328 =head2 $mech->content_is( $str [, $desc ] )
330 Tells if the content of the page matches the given string
332 =head2 $mech->content_contains( $str [, $desc ] )
334 Tells if the content of the page contains I<$str>.
336 =head2 $mech->content_lacks( $str [, $desc ] )
338 Tells if the content of the page lacks I<$str>.
340 =head2 $mech->content_like( $regex [, $desc ] )
342 Tells if the content of the page matches I<$regex>.
344 =head2 $mech->content_unlike( $regex [, $desc ] )
346 Tells if the content of the page does NOT match I<$regex>.
348 =head2 $mech->page_links_ok( [ $desc ] )
350 Follow all links on the current page and test for HTTP status 200
352 $mech->page_links_ok('Check all links');
354 =head2 $mech->page_links_content_like( $regex,[ $desc ] )
356 Follow all links on the current page and test their contents for I<$regex>.
358 $mech->page_links_content_like( qr/foo/,
359 'Check all links contain "foo"' );
361 =head2 $mech->page_links_content_unlike( $regex,[ $desc ] )
363 Follow all links on the current page and test their contents do not
364 contain the specified regex.
366 $mech->page_links_content_unlike(qr/Restricted/,
367 'Check all links do not contain Restricted');
369 =head2 $mech->links_ok( $links [, $desc ] )
371 Check the current page for specified links and test for HTTP status
372 200. The links may be specified as a reference to an array containing
373 L<WWW::Mechanize::Link> objects, an array of URLs, or a scalar URL
376 my @links = $mech->find_all_links( url_regex => qr/cnn\.com$/ );
377 $mech->links_ok( \@links, 'Check all links for cnn.com' );
379 my @links = qw( index.html search.html about.html );
380 $mech->links_ok( \@links, 'Check main links' );
382 $mech->links_ok( 'index.html', 'Check link to index' );
384 =head2 $mech->link_status_is( $links, $status [, $desc ] )
386 Check the current page for specified links and test for HTTP status
387 passed. The links may be specified as a reference to an array
388 containing L<WWW::Mechanize::Link> objects, an array of URLs, or a
391 my @links = $mech->links();
392 $mech->link_status_is( \@links, 403,
393 'Check all links are restricted' );
395 =head2 $mech->link_status_isnt( $links, $status [, $desc ] )
397 Check the current page for specified links and test for HTTP status
398 passed. The links may be specified as a reference to an array
399 containing L<WWW::Mechanize::Link> objects, an array of URLs, or a
402 my @links = $mech->links();
403 $mech->link_status_isnt( \@links, 404,
404 'Check all links are not 404' );
406 =head2 $mech->link_content_like( $links, $regex [, $desc ] )
408 Check the current page for specified links and test the content of
409 each against I<$regex>. The links may be specified as a reference to
410 an array containing L<WWW::Mechanize::Link> objects, an array of URLs,
411 or a scalar URL name.
413 my @links = $mech->links();
414 $mech->link_content_like( \@links, qr/Restricted/,
415 'Check all links are restricted' );
417 =head2 $mech->link_content_unlike( $links, $regex [, $desc ] )
419 Check the current page for specified links and test the content of each
420 does not match I<$regex>. The links may be specified as a reference to
421 an array containing L<WWW::Mechanize::Link> objects, an array of URLs,
422 or a scalar URL name.
424 my @links = $mech->links();
425 $mech->link_content_like( \@links, qr/Restricted/,
426 'Check all links are restricted' );
428 =head2 follow_link_ok( \%parms [, $comment] )
430 Makes a C<follow_link()> call and executes tests on the results.
431 The link must be found, and then followed successfully. Otherwise,
434 I<%parms> is a hashref containing the parms to pass to C<follow_link()>.
435 Note that the parms to C<follow_link()> are a hash whereas the parms to
436 this function are a hashref. You have to call this function like:
438 $agent->follow_like_ok( {n=>3}, "looking for 3rd link" );
440 As with other test functions, C<$comment> is optional. If it is supplied
441 then it will display when running the test harness in verbose mode.
443 Returns true value if the specified link was found and followed
444 successfully. The HTTP::Response object returned by follow_link()
449 Related modules which may be of interest: L<Catalyst>,
450 L<Test::WWW::Mechanize>, L<WWW::Mechanize>.
454 Ash Berlin C<< <ash@cpan.org> >> (current maintiner)
456 Original Author: Leon Brocard, C<< <acme@astray.com> >>
460 Copyright (C) 2005-8, Leon Brocard
464 This module is free software; you can redistribute it or modify it
465 under the same terms as Perl itself.