Commit | Line | Data |
6bc86362 |
1 | package Test::WWW::Mechanize::Catalyst; |
254eca41 |
2 | |
f21ad406 |
3 | use Moose; |
254eca41 |
4 | |
5 | use Carp qw/croak/; |
6 | require Catalyst::Test; # Do not call import |
6bc86362 |
7 | use Encode qw(); |
8 | use HTML::Entities; |
9 | use Test::WWW::Mechanize; |
254eca41 |
10 | |
f21ad406 |
11 | extends 'Test::WWW::Mechanize', 'Moose::Object'; |
12 | |
13 | use namespace::clean -execept => 'meta'; |
254eca41 |
14 | |
cfd812d6 |
15 | our $VERSION = '0.50_2'; |
f21ad406 |
16 | our $APP_CLASS; |
6bc86362 |
17 | my $Test = Test::Builder->new(); |
18 | |
f21ad406 |
19 | has catalyst_app => ( |
20 | is => 'ro', |
ab0b00e3 |
21 | predicate => 'has_catalyst_app', |
f21ad406 |
22 | ); |
23 | |
24 | has allow_external => ( |
25 | is => 'rw', |
26 | isa => 'Bool', |
27 | default => 0 |
28 | ); |
6bc86362 |
29 | |
1f8dbf85 |
30 | has host => ( |
31 | is => 'rw', |
32 | isa => 'Str', |
33 | clearer => 'clear_host', |
34 | predicate => 'has_host', |
35 | ); |
36 | |
254eca41 |
37 | sub new { |
f21ad406 |
38 | my $class = shift; |
254eca41 |
39 | |
f21ad406 |
40 | my $obj = $class->SUPER::new(@_); |
41 | my $self = $class->meta->new_object( |
42 | __INSTANCE__ => $obj, |
ab0b00e3 |
43 | ($APP_CLASS ? (catalyst_app => $APP_CLASS) : () ), |
f21ad406 |
44 | @_ |
45 | ); |
46 | |
ab0b00e3 |
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)); |
52 | } |
254eca41 |
53 | |
f21ad406 |
54 | return $self; |
6bc86362 |
55 | } |
56 | |
57 | sub _make_request { |
58 | my ( $self, $request ) = @_; |
6bc86362 |
59 | |
ab0b00e3 |
60 | my $response = $self->_do_catalyst_request($request); |
6bc86362 |
61 | $response->header( 'Content-Base', $request->uri ); |
62 | $response->request($request); |
63 | if ( $request->uri->as_string =~ m{^/} ) { |
64 | $request->uri( |
65 | URI->new( 'http://localhost:80/' . $request->uri->as_string ) ); |
66 | } |
67 | $self->cookie_jar->extract_cookies($response) if $self->cookie_jar; |
68 | |
69 | # fail tests under the Catalyst debug screen |
70 | if ( !$self->{catalyst_debug} |
71 | && $response->code == 500 |
72 | && $response->content =~ /on Catalyst \d+\.\d+/ ) |
73 | { |
74 | my ($error) |
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(''); |
81 | } |
82 | |
83 | # check if that was a redirect |
84 | if ( $response->header('Location') |
85 | && $self->redirect_ok( $request, $response ) ) |
86 | { |
87 | |
88 | # remember the old response |
89 | my $old_response = $response; |
90 | |
91 | # *where* do they want us to redirect to? |
92 | my $location = $old_response->header('Location'); |
93 | |
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; |
98 | |
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 |
103 | { |
104 | $end_of_chain = $end_of_chain->previous; |
105 | } # of the chain... |
106 | $end_of_chain->previous($old_response); # ...and add us to it |
107 | } else { |
108 | $response->{_raw_content} = $response->content; |
109 | } |
110 | |
111 | return $response; |
112 | } |
113 | |
ab0b00e3 |
114 | sub _do_catalyst_request { |
115 | my ($self, $request) = @_; |
116 | |
117 | $self->cookie_jar->add_cookie_header($request) if $self->cookie_jar; |
118 | |
119 | # Woe betide anyone who unsets CATALYST_SERVER |
120 | return Catalyst::Test::remote_request($request) |
121 | if $ENV{CATALYST_SERVER}; |
122 | |
123 | my $uri = $request->uri; |
124 | if ($uri->as_string =~ m{^/}) { |
125 | $uri->scheme('http'); |
126 | $uri->host('localhost'); |
127 | } |
128 | |
129 | |
130 | # If there's no Host header, set one. |
131 | unless ($request->header('Host')) { |
132 | my $host = $self->has_host |
133 | ? $self->host |
134 | : $uri->host; |
135 | |
136 | $request->header('Host', $host); |
137 | } |
138 | |
139 | if ( $self->{allow_external} ) { |
140 | unless ( $request->uri->as_string =~ m{^/} |
141 | || $request->uri->host eq 'localhost' ) |
142 | { |
143 | return $self->SUPER::_make_request($request); |
144 | } |
145 | } |
146 | |
147 | my @creds = $self->get_basic_credentials( "Basic", $uri ); |
148 | $request->authorization_basic( @creds ) if @creds; |
149 | |
150 | return Catalyst::Test::local_request($self->{catalyst_app}, $request); |
151 | } |
152 | |
6bc86362 |
153 | sub import { |
254eca41 |
154 | my ($class, $app) = @_; |
f21ad406 |
155 | |
254eca41 |
156 | if (defined $app) { |
f21ad406 |
157 | Class::MOP::load_class($app) |
158 | unless (Class::MOP::is_class_loaded($app)); |
254eca41 |
159 | $APP_CLASS = $app; |
160 | } |
f21ad406 |
161 | |
6bc86362 |
162 | } |
163 | |
6bc86362 |
164 | |
165 | 1; |
166 | |
167 | __END__ |
168 | |
169 | =head1 NAME |
170 | |
171 | Test::WWW::Mechanize::Catalyst - Test::WWW::Mechanize for Catalyst |
172 | |
173 | =head1 SYNOPSIS |
174 | |
175 | # We're in a t/*.t test script... |
ab0b00e3 |
176 | use Test::WWW::Mechanize::Catalyst; |
177 | |
6bc86362 |
178 | # To test a Catalyst application named 'Catty': |
ab0b00e3 |
179 | my $mech = Test::WWW::Mechanize::Catalyst->new(catalyst_app => 'Catty'); |
6bc86362 |
180 | |
6bc86362 |
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 |
ab0b00e3 |
187 | |
188 | # White label site testing |
189 | $mech->host("foo.com"); |
190 | $mech->get_ok("/"); |
6bc86362 |
191 | |
192 | =head1 DESCRIPTION |
193 | |
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. |
199 | |
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: |
208 | |
209 | $mech->get_ok('/action'); |
210 | $mech->get_ok('http://localhost/action'); |
211 | |
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: |
215 | |
216 | $m->allow_external(1); |
217 | |
218 | You can also test a remote server by setting the environment variable |
219 | CATALYST_SERVER, for example: |
220 | |
221 | $ CATALYST_SERVER=http://example.com/myapp prove -l t |
222 | |
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. |
226 | |
227 | This makes testing fast and easy. L<Test::WWW::Mechanize> provides |
228 | functions for common web testing scenarios. For example: |
229 | |
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" ); |
234 | |
235 | This module supports cookies automatically. |
236 | |
237 | To use this module you must pass it the name of the application. See |
238 | the SYNOPSIS above. |
239 | |
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, |
243 | please use: |
244 | |
245 | $m->{catalyst_debug} = 1; |
246 | |
247 | An alternative to this module is L<Catalyst::Test>. |
248 | |
249 | =head1 CONSTRUCTOR |
250 | |
251 | =head2 new |
252 | |
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": |
256 | |
257 | use Test::WWW::Mechanize::Catalyst 'Catty'; |
258 | my $mech = Test::WWW::Mechanize::Catalyst->new; |
259 | |
260 | =head1 METHODS |
261 | |
262 | =head2 allow_external |
263 | |
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: |
267 | |
268 | $m->allow_external(1); |
269 | |
1f8dbf85 |
270 | head2 catalyst_app |
271 | |
272 | The name of the Catalyst app which we are testing against. Read-only. |
273 | |
274 | =head2 host |
275 | |
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 |
278 | localhost:80 |
279 | |
280 | =head2 clear_host |
281 | |
282 | Unset the host attribute. |
283 | |
284 | =head2 has_host |
285 | |
286 | Do we have a value set for the host attribute |
287 | |
6bc86362 |
288 | =head2 $mech->get_ok($url, [ \%LWP_options ,] $desc) |
289 | |
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 |
292 | false. |
293 | |
294 | =head2 $mech->title_is( $str [, $desc ] ) |
295 | |
296 | Tells if the title of the page is the given string. |
297 | |
298 | $mech->title_is( "Invoice Summary" ); |
299 | |
300 | =head2 $mech->title_like( $regex [, $desc ] ) |
301 | |
302 | Tells if the title of the page matches the given regex. |
303 | |
304 | $mech->title_like( qr/Invoices for (.+)/ |
305 | |
306 | =head2 $mech->title_unlike( $regex [, $desc ] ) |
307 | |
308 | Tells if the title of the page matches the given regex. |
309 | |
310 | $mech->title_unlike( qr/Invoices for (.+)/ |
311 | |
312 | =head2 $mech->content_is( $str [, $desc ] ) |
313 | |
314 | Tells if the content of the page matches the given string |
315 | |
316 | =head2 $mech->content_contains( $str [, $desc ] ) |
317 | |
318 | Tells if the content of the page contains I<$str>. |
319 | |
320 | =head2 $mech->content_lacks( $str [, $desc ] ) |
321 | |
322 | Tells if the content of the page lacks I<$str>. |
323 | |
324 | =head2 $mech->content_like( $regex [, $desc ] ) |
325 | |
326 | Tells if the content of the page matches I<$regex>. |
327 | |
328 | =head2 $mech->content_unlike( $regex [, $desc ] ) |
329 | |
330 | Tells if the content of the page does NOT match I<$regex>. |
331 | |
332 | =head2 $mech->page_links_ok( [ $desc ] ) |
333 | |
334 | Follow all links on the current page and test for HTTP status 200 |
335 | |
336 | $mech->page_links_ok('Check all links'); |
337 | |
338 | =head2 $mech->page_links_content_like( $regex,[ $desc ] ) |
339 | |
340 | Follow all links on the current page and test their contents for I<$regex>. |
341 | |
342 | $mech->page_links_content_like( qr/foo/, |
343 | 'Check all links contain "foo"' ); |
344 | |
345 | =head2 $mech->page_links_content_unlike( $regex,[ $desc ] ) |
346 | |
347 | Follow all links on the current page and test their contents do not |
348 | contain the specified regex. |
349 | |
350 | $mech->page_links_content_unlike(qr/Restricted/, |
351 | 'Check all links do not contain Restricted'); |
352 | |
353 | =head2 $mech->links_ok( $links [, $desc ] ) |
354 | |
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 |
358 | name. |
359 | |
360 | my @links = $mech->find_all_links( url_regex => qr/cnn\.com$/ ); |
361 | $mech->links_ok( \@links, 'Check all links for cnn.com' ); |
362 | |
363 | my @links = qw( index.html search.html about.html ); |
364 | $mech->links_ok( \@links, 'Check main links' ); |
365 | |
366 | $mech->links_ok( 'index.html', 'Check link to index' ); |
367 | |
368 | =head2 $mech->link_status_is( $links, $status [, $desc ] ) |
369 | |
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 |
373 | scalar URL name. |
374 | |
375 | my @links = $mech->links(); |
376 | $mech->link_status_is( \@links, 403, |
377 | 'Check all links are restricted' ); |
378 | |
379 | =head2 $mech->link_status_isnt( $links, $status [, $desc ] ) |
380 | |
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 |
384 | scalar URL name. |
385 | |
386 | my @links = $mech->links(); |
387 | $mech->link_status_isnt( \@links, 404, |
388 | 'Check all links are not 404' ); |
389 | |
390 | =head2 $mech->link_content_like( $links, $regex [, $desc ] ) |
391 | |
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. |
396 | |
397 | my @links = $mech->links(); |
398 | $mech->link_content_like( \@links, qr/Restricted/, |
399 | 'Check all links are restricted' ); |
400 | |
401 | =head2 $mech->link_content_unlike( $links, $regex [, $desc ] ) |
402 | |
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. |
407 | |
408 | my @links = $mech->links(); |
409 | $mech->link_content_like( \@links, qr/Restricted/, |
410 | 'Check all links are restricted' ); |
411 | |
412 | =head2 follow_link_ok( \%parms [, $comment] ) |
413 | |
414 | Makes a C<follow_link()> call and executes tests on the results. |
415 | The link must be found, and then followed successfully. Otherwise, |
416 | this test fails. |
417 | |
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: |
421 | |
422 | $agent->follow_like_ok( {n=>3}, "looking for 3rd link" ); |
423 | |
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. |
426 | |
427 | Returns true value if the specified link was found and followed |
428 | successfully. The HTTP::Response object returned by follow_link() |
429 | is not available. |
430 | |
431 | =head1 SEE ALSO |
432 | |
433 | Related modules which may be of interest: L<Catalyst>, |
434 | L<Test::WWW::Mechanize>, L<WWW::Mechanize>. |
435 | |
436 | =head1 AUTHOR |
437 | |
f21ad406 |
438 | Ash Berlin C<< <ash@cpan.org> >> (current maintiner) |
254eca41 |
439 | |
f21ad406 |
440 | Original Author: Leon Brocard, C<< <acme@astray.com> >> |
6bc86362 |
441 | |
442 | =head1 COPYRIGHT |
443 | |
254eca41 |
444 | Copyright (C) 2005-8, Leon Brocard |
6bc86362 |
445 | |
446 | =head1 LICENSE |
447 | |
448 | This module is free software; you can redistribute it or modify it |
449 | under the same terms as Perl itself. |
450 | |