1 package Test::WWW::Mechanize::Catalyst;
6 use Test::WWW::Mechanize;
7 use base qw(Test::WWW::Mechanize);
9 my $Test = Test::Builder->new();
11 # the reason for the auxiliary package is that both WWW::Mechanize and
12 # Catalyst::Test have a subroutine named 'request'
15 my ( $self, $value ) = @_;
16 return $self->{allow_external} unless defined $value;
17 $self->{allow_external} = $value;
21 my ( $self, $request ) = @_;
22 $self->cookie_jar->add_cookie_header($request) if $self->cookie_jar;
24 if ( $self->{allow_external} ) {
25 unless ( $request->uri->as_string =~ m{^/}
26 || $request->uri->host eq 'localhost' )
28 return $self->SUPER::_make_request($request);
32 my $uri = $request->uri;
33 if ($uri->as_string =~ m{^/}) {
35 $uri->host('localhost');
37 my @creds = $self->get_basic_credentials( "Basic", $uri );
38 $request->authorization_basic( @creds ) if @creds;
40 my $response = Test::WWW::Mechanize::Catalyst::Aux::request($request);
41 $response->header( 'Content-Base', $request->uri );
42 $response->request($request);
43 if ( $request->uri->as_string =~ m{^/} ) {
45 URI->new( 'http://localhost:80/' . $request->uri->as_string ) );
47 $self->cookie_jar->extract_cookies($response) if $self->cookie_jar;
49 # fail tests under the Catalyst debug screen
50 if ( !$self->{catalyst_debug}
51 && $response->code == 500
52 && $response->content =~ /on Catalyst \d+\.\d+/ )
55 = ( $response->content =~ /<code class="error">(.*?)<\/code>/s );
56 $error ||= "unknown error";
57 decode_entities($error);
58 $Test->diag("Catalyst error screen: $error");
59 $response->content('');
60 $response->content_type('');
63 # check if that was a redirect
64 if ( $response->header('Location')
65 && $self->redirect_ok( $request, $response ) )
68 # remember the old response
69 my $old_response = $response;
71 # *where* do they want us to redirect to?
72 my $location = $old_response->header('Location');
74 # no-one *should* be returning non-absolute URLs, but if they
75 # are then we'd better cope with it. Let's create a new URI, using
76 # our request as the base.
77 my $uri = URI->new_abs( $location, $request->uri )->as_string;
79 # make a new response, and save the old response in it
80 $response = $self->_make_request( HTTP::Request->new( GET => $uri ) );
81 my $end_of_chain = $response;
82 while ( $end_of_chain->previous ) # keep going till the end
84 $end_of_chain = $end_of_chain->previous;
86 $end_of_chain->previous($old_response); # ...and add us to it
88 $response->{_raw_content} = $response->content;
95 Test::WWW::Mechanize::Catalyst::Aux::import(@_);
98 package Test::WWW::Mechanize::Catalyst::Aux;
101 my ( $class, @args ) = @_;
103 require Catalyst::Test;
104 Catalyst::Test::import(@_);
115 Test::WWW::Mechanize::Catalyst - Test::WWW::Mechanize for Catalyst
119 # We're in a t/*.t test script...
120 # To test a Catalyst application named 'Catty':
121 use Test::WWW::Mechanize::Catalyst 'Catty';
123 my $mech = Test::WWW::Mechanize::Catalyst->new;
124 $mech->get_ok("/"); # no hostname needed
125 is($mech->ct, "text/html");
126 $mech->title_is("Root", "On the root page");
127 $mech->content_contains("This is the root page", "Correct content");
128 $mech->follow_link_ok({text => 'Hello'}, "Click on Hello");
129 # ... and all other Test::WWW::Mechanize methods
133 L<Catalyst> is an elegant MVC Web Application
134 Framework. L<Test::WWW::Mechanize> is a subclass of L<WWW::Mechanize> that
135 incorporates features for web application testing. The
136 L<Test::WWW::Mechanize::Catalyst> module meshes the two to allow easy
137 testing of L<Catalyst> applications without starting up a web server.
139 Testing web applications has always been a bit tricky, normally
140 starting a web server for your application and making real HTTP
141 requests to it. This module allows you to test L<Catalyst> web
142 applications but does not start a server or issue HTTP
143 requests. Instead, it passes the HTTP request object directly to
144 L<Catalyst>. Thus you do not need to use a real hostname:
145 "http://localhost/" will do. However, this is optional. The following
146 two lines of code do exactly the same thing:
148 $mech->get_ok('/action');
149 $mech->get_ok('http://localhost/action');
151 Links which do not begin with / or are not for localhost can be handled
152 as normal Web requests - this is handy if you have an external
153 single sign-on system. You must set allow_external to true for this:
155 $m->allow_external(1);
157 You can also test a remote server by setting the environment variable
158 CATALYST_SERVER, for example:
160 $ CATALYST_SERVER=http://example.com/myapp prove -l t
162 will run the same tests on the application running at
163 http://example.com/myapp regardless of whether or not you specify
164 http:://localhost for Test::WWW::Mechanize::Catalyst.
166 This makes testing fast and easy. L<Test::WWW::Mechanize> provides
167 functions for common web testing scenarios. For example:
169 $mech->get_ok( $page );
170 $mech->title_is( "Invoice Status", "Make sure we're on the invoice page" );
171 $mech->content_contains( "Andy Lester", "My name somewhere" );
172 $mech->content_like( qr/(cpan|perl)\.org/, "Link to perl.org or CPAN" );
174 This module supports cookies automatically.
176 To use this module you must pass it the name of the application. See
179 Note that Catalyst has a special developing feature: the debug
180 screen. By default this module will treat responses which are the
181 debug screen as failures. If you actually want to test debug screens,
184 $m->{catalyst_debug} = 1;
186 An alternative to this module is L<Catalyst::Test>.
192 Behaves like, and calls, L<WWW::Mechanize>'s C<new> method. Any parms
193 passed in get passed to WWW::Mechanize's constructor. Note that we
194 need to pass the name of the Catalyst application to the "use":
196 use Test::WWW::Mechanize::Catalyst 'Catty';
197 my $mech = Test::WWW::Mechanize::Catalyst->new;
201 =head2 allow_external
203 Links which do not begin with / or are not for localhost can be handled
204 as normal Web requests - this is handy if you have an external
205 single sign-on system. You must set allow_external to true for this:
207 $m->allow_external(1);
209 =head2 $mech->get_ok($url, [ \%LWP_options ,] $desc)
211 A wrapper around WWW::Mechanize's get(), with similar options, except the
212 second argument needs to be a hash reference, not a hash. Returns true or
215 =head2 $mech->title_is( $str [, $desc ] )
217 Tells if the title of the page is the given string.
219 $mech->title_is( "Invoice Summary" );
221 =head2 $mech->title_like( $regex [, $desc ] )
223 Tells if the title of the page matches the given regex.
225 $mech->title_like( qr/Invoices for (.+)/
227 =head2 $mech->title_unlike( $regex [, $desc ] )
229 Tells if the title of the page matches the given regex.
231 $mech->title_unlike( qr/Invoices for (.+)/
233 =head2 $mech->content_is( $str [, $desc ] )
235 Tells if the content of the page matches the given string
237 =head2 $mech->content_contains( $str [, $desc ] )
239 Tells if the content of the page contains I<$str>.
241 =head2 $mech->content_lacks( $str [, $desc ] )
243 Tells if the content of the page lacks I<$str>.
245 =head2 $mech->content_like( $regex [, $desc ] )
247 Tells if the content of the page matches I<$regex>.
249 =head2 $mech->content_unlike( $regex [, $desc ] )
251 Tells if the content of the page does NOT match I<$regex>.
253 =head2 $mech->page_links_ok( [ $desc ] )
255 Follow all links on the current page and test for HTTP status 200
257 $mech->page_links_ok('Check all links');
259 =head2 $mech->page_links_content_like( $regex,[ $desc ] )
261 Follow all links on the current page and test their contents for I<$regex>.
263 $mech->page_links_content_like( qr/foo/,
264 'Check all links contain "foo"' );
266 =head2 $mech->page_links_content_unlike( $regex,[ $desc ] )
268 Follow all links on the current page and test their contents do not
269 contain the specified regex.
271 $mech->page_links_content_unlike(qr/Restricted/,
272 'Check all links do not contain Restricted');
274 =head2 $mech->links_ok( $links [, $desc ] )
276 Check the current page for specified links and test for HTTP status
277 200. The links may be specified as a reference to an array containing
278 L<WWW::Mechanize::Link> objects, an array of URLs, or a scalar URL
281 my @links = $mech->find_all_links( url_regex => qr/cnn\.com$/ );
282 $mech->links_ok( \@links, 'Check all links for cnn.com' );
284 my @links = qw( index.html search.html about.html );
285 $mech->links_ok( \@links, 'Check main links' );
287 $mech->links_ok( 'index.html', 'Check link to index' );
289 =head2 $mech->link_status_is( $links, $status [, $desc ] )
291 Check the current page for specified links and test for HTTP status
292 passed. The links may be specified as a reference to an array
293 containing L<WWW::Mechanize::Link> objects, an array of URLs, or a
296 my @links = $mech->links();
297 $mech->link_status_is( \@links, 403,
298 'Check all links are restricted' );
300 =head2 $mech->link_status_isnt( $links, $status [, $desc ] )
302 Check the current page for specified links and test for HTTP status
303 passed. The links may be specified as a reference to an array
304 containing L<WWW::Mechanize::Link> objects, an array of URLs, or a
307 my @links = $mech->links();
308 $mech->link_status_isnt( \@links, 404,
309 'Check all links are not 404' );
311 =head2 $mech->link_content_like( $links, $regex [, $desc ] )
313 Check the current page for specified links and test the content of
314 each against I<$regex>. The links may be specified as a reference to
315 an array containing L<WWW::Mechanize::Link> objects, an array of URLs,
316 or a scalar URL name.
318 my @links = $mech->links();
319 $mech->link_content_like( \@links, qr/Restricted/,
320 'Check all links are restricted' );
322 =head2 $mech->link_content_unlike( $links, $regex [, $desc ] )
324 Check the current page for specified links and test the content of each
325 does not match I<$regex>. The links may be specified as a reference to
326 an array containing L<WWW::Mechanize::Link> objects, an array of URLs,
327 or a scalar URL name.
329 my @links = $mech->links();
330 $mech->link_content_like( \@links, qr/Restricted/,
331 'Check all links are restricted' );
333 =head2 follow_link_ok( \%parms [, $comment] )
335 Makes a C<follow_link()> call and executes tests on the results.
336 The link must be found, and then followed successfully. Otherwise,
339 I<%parms> is a hashref containing the parms to pass to C<follow_link()>.
340 Note that the parms to C<follow_link()> are a hash whereas the parms to
341 this function are a hashref. You have to call this function like:
343 $agent->follow_like_ok( {n=>3}, "looking for 3rd link" );
345 As with other test functions, C<$comment> is optional. If it is supplied
346 then it will display when running the test harness in verbose mode.
348 Returns true value if the specified link was found and followed
349 successfully. The HTTP::Response object returned by follow_link()
354 Related modules which may be of interest: L<Catalyst>,
355 L<Test::WWW::Mechanize>, L<WWW::Mechanize>.
359 Leon Brocard, C<< <acme@astray.com> >>
363 Copyright (C) 2005-7, Leon Brocard
367 This module is free software; you can redistribute it or modify it
368 under the same terms as Perl itself.