Commit | Line | Data |
6bc86362 |
1 | package Test::WWW::Mechanize::Catalyst; |
2 | use strict; |
3 | use warnings; |
4 | use Encode qw(); |
5 | use HTML::Entities; |
6 | use Test::WWW::Mechanize; |
7 | use base qw(Test::WWW::Mechanize); |
8 | our $VERSION = '0.45'; |
9 | my $Test = Test::Builder->new(); |
10 | |
11 | # the reason for the auxiliary package is that both WWW::Mechanize and |
12 | # Catalyst::Test have a subroutine named 'request' |
13 | |
14 | sub allow_external { |
15 | my ( $self, $value ) = @_; |
16 | return $self->{allow_external} unless defined $value; |
17 | $self->{allow_external} = $value; |
18 | } |
19 | |
20 | sub _make_request { |
21 | my ( $self, $request ) = @_; |
22 | $self->cookie_jar->add_cookie_header($request) if $self->cookie_jar; |
23 | |
24 | if ( $self->{allow_external} ) { |
25 | unless ( $request->uri->as_string =~ m{^/} |
26 | || $request->uri->host eq 'localhost' ) |
27 | { |
28 | return $self->SUPER::_make_request($request); |
29 | } |
30 | } |
31 | |
32 | $request->authorization_basic( |
33 | LWP::UserAgent->get_basic_credentials( |
34 | undef, "Basic", $request->uri |
35 | ) |
36 | ) |
37 | if LWP::UserAgent->get_basic_credentials( undef, "Basic", |
38 | $request->uri ); |
39 | |
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{^/} ) { |
44 | $request->uri( |
45 | URI->new( 'http://localhost:80/' . $request->uri->as_string ) ); |
46 | } |
47 | $self->cookie_jar->extract_cookies($response) if $self->cookie_jar; |
48 | |
49 | # fail tests under the Catalyst debug screen |
50 | if ( !$self->{catalyst_debug} |
51 | && $response->code == 500 |
52 | && $response->content =~ /on Catalyst \d+\.\d+/ ) |
53 | { |
54 | my ($error) |
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(''); |
61 | } |
62 | |
63 | # check if that was a redirect |
64 | if ( $response->header('Location') |
65 | && $self->redirect_ok( $request, $response ) ) |
66 | { |
67 | |
68 | # remember the old response |
69 | my $old_response = $response; |
70 | |
71 | # *where* do they want us to redirect to? |
72 | my $location = $old_response->header('Location'); |
73 | |
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; |
78 | |
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 |
83 | { |
84 | $end_of_chain = $end_of_chain->previous; |
85 | } # of the chain... |
86 | $end_of_chain->previous($old_response); # ...and add us to it |
87 | } else { |
88 | $response->{_raw_content} = $response->content; |
89 | } |
90 | |
91 | return $response; |
92 | } |
93 | |
94 | sub import { |
95 | Test::WWW::Mechanize::Catalyst::Aux::import(@_); |
96 | } |
97 | |
98 | package Test::WWW::Mechanize::Catalyst::Aux; |
99 | |
100 | sub import { |
101 | my ( $class, @args ) = @_; |
102 | eval { |
103 | require Catalyst::Test; |
104 | Catalyst::Test::import(@_); |
105 | }; |
106 | warn $@ if $@; |
107 | } |
108 | |
109 | 1; |
110 | |
111 | __END__ |
112 | |
113 | =head1 NAME |
114 | |
115 | Test::WWW::Mechanize::Catalyst - Test::WWW::Mechanize for Catalyst |
116 | |
117 | =head1 SYNOPSIS |
118 | |
119 | # We're in a t/*.t test script... |
120 | # To test a Catalyst application named 'Catty': |
121 | use Test::WWW::Mechanize::Catalyst 'Catty'; |
122 | |
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 |
130 | |
131 | =head1 DESCRIPTION |
132 | |
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. |
138 | |
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: |
147 | |
148 | $mech->get_ok('/action'); |
149 | $mech->get_ok('http://localhost/action'); |
150 | |
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: |
154 | |
155 | $m->allow_external(1); |
156 | |
157 | You can also test a remote server by setting the environment variable |
158 | CATALYST_SERVER, for example: |
159 | |
160 | $ CATALYST_SERVER=http://example.com/myapp prove -l t |
161 | |
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. |
165 | |
166 | This makes testing fast and easy. L<Test::WWW::Mechanize> provides |
167 | functions for common web testing scenarios. For example: |
168 | |
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" ); |
173 | |
174 | This module supports cookies automatically. |
175 | |
176 | To use this module you must pass it the name of the application. See |
177 | the SYNOPSIS above. |
178 | |
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, |
182 | please use: |
183 | |
184 | $m->{catalyst_debug} = 1; |
185 | |
186 | An alternative to this module is L<Catalyst::Test>. |
187 | |
188 | =head1 CONSTRUCTOR |
189 | |
190 | =head2 new |
191 | |
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": |
195 | |
196 | use Test::WWW::Mechanize::Catalyst 'Catty'; |
197 | my $mech = Test::WWW::Mechanize::Catalyst->new; |
198 | |
199 | =head1 METHODS |
200 | |
201 | =head2 allow_external |
202 | |
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: |
206 | |
207 | $m->allow_external(1); |
208 | |
209 | =head2 $mech->get_ok($url, [ \%LWP_options ,] $desc) |
210 | |
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 |
213 | false. |
214 | |
215 | =head2 $mech->title_is( $str [, $desc ] ) |
216 | |
217 | Tells if the title of the page is the given string. |
218 | |
219 | $mech->title_is( "Invoice Summary" ); |
220 | |
221 | =head2 $mech->title_like( $regex [, $desc ] ) |
222 | |
223 | Tells if the title of the page matches the given regex. |
224 | |
225 | $mech->title_like( qr/Invoices for (.+)/ |
226 | |
227 | =head2 $mech->title_unlike( $regex [, $desc ] ) |
228 | |
229 | Tells if the title of the page matches the given regex. |
230 | |
231 | $mech->title_unlike( qr/Invoices for (.+)/ |
232 | |
233 | =head2 $mech->content_is( $str [, $desc ] ) |
234 | |
235 | Tells if the content of the page matches the given string |
236 | |
237 | =head2 $mech->content_contains( $str [, $desc ] ) |
238 | |
239 | Tells if the content of the page contains I<$str>. |
240 | |
241 | =head2 $mech->content_lacks( $str [, $desc ] ) |
242 | |
243 | Tells if the content of the page lacks I<$str>. |
244 | |
245 | =head2 $mech->content_like( $regex [, $desc ] ) |
246 | |
247 | Tells if the content of the page matches I<$regex>. |
248 | |
249 | =head2 $mech->content_unlike( $regex [, $desc ] ) |
250 | |
251 | Tells if the content of the page does NOT match I<$regex>. |
252 | |
253 | =head2 $mech->page_links_ok( [ $desc ] ) |
254 | |
255 | Follow all links on the current page and test for HTTP status 200 |
256 | |
257 | $mech->page_links_ok('Check all links'); |
258 | |
259 | =head2 $mech->page_links_content_like( $regex,[ $desc ] ) |
260 | |
261 | Follow all links on the current page and test their contents for I<$regex>. |
262 | |
263 | $mech->page_links_content_like( qr/foo/, |
264 | 'Check all links contain "foo"' ); |
265 | |
266 | =head2 $mech->page_links_content_unlike( $regex,[ $desc ] ) |
267 | |
268 | Follow all links on the current page and test their contents do not |
269 | contain the specified regex. |
270 | |
271 | $mech->page_links_content_unlike(qr/Restricted/, |
272 | 'Check all links do not contain Restricted'); |
273 | |
274 | =head2 $mech->links_ok( $links [, $desc ] ) |
275 | |
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 |
279 | name. |
280 | |
281 | my @links = $mech->find_all_links( url_regex => qr/cnn\.com$/ ); |
282 | $mech->links_ok( \@links, 'Check all links for cnn.com' ); |
283 | |
284 | my @links = qw( index.html search.html about.html ); |
285 | $mech->links_ok( \@links, 'Check main links' ); |
286 | |
287 | $mech->links_ok( 'index.html', 'Check link to index' ); |
288 | |
289 | =head2 $mech->link_status_is( $links, $status [, $desc ] ) |
290 | |
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 |
294 | scalar URL name. |
295 | |
296 | my @links = $mech->links(); |
297 | $mech->link_status_is( \@links, 403, |
298 | 'Check all links are restricted' ); |
299 | |
300 | =head2 $mech->link_status_isnt( $links, $status [, $desc ] ) |
301 | |
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 |
305 | scalar URL name. |
306 | |
307 | my @links = $mech->links(); |
308 | $mech->link_status_isnt( \@links, 404, |
309 | 'Check all links are not 404' ); |
310 | |
311 | =head2 $mech->link_content_like( $links, $regex [, $desc ] ) |
312 | |
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. |
317 | |
318 | my @links = $mech->links(); |
319 | $mech->link_content_like( \@links, qr/Restricted/, |
320 | 'Check all links are restricted' ); |
321 | |
322 | =head2 $mech->link_content_unlike( $links, $regex [, $desc ] ) |
323 | |
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. |
328 | |
329 | my @links = $mech->links(); |
330 | $mech->link_content_like( \@links, qr/Restricted/, |
331 | 'Check all links are restricted' ); |
332 | |
333 | =head2 follow_link_ok( \%parms [, $comment] ) |
334 | |
335 | Makes a C<follow_link()> call and executes tests on the results. |
336 | The link must be found, and then followed successfully. Otherwise, |
337 | this test fails. |
338 | |
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: |
342 | |
343 | $agent->follow_like_ok( {n=>3}, "looking for 3rd link" ); |
344 | |
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. |
347 | |
348 | Returns true value if the specified link was found and followed |
349 | successfully. The HTTP::Response object returned by follow_link() |
350 | is not available. |
351 | |
352 | =head1 SEE ALSO |
353 | |
354 | Related modules which may be of interest: L<Catalyst>, |
355 | L<Test::WWW::Mechanize>, L<WWW::Mechanize>. |
356 | |
357 | =head1 AUTHOR |
358 | |
359 | Leon Brocard, C<< <acme@astray.com> >> |
360 | |
361 | =head1 COPYRIGHT |
362 | |
363 | Copyright (C) 2005-7, Leon Brocard |
364 | |
365 | =head1 LICENSE |
366 | |
367 | This module is free software; you can redistribute it or modify it |
368 | under the same terms as Perl itself. |
369 | |