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 |
d25179ec |
7 | use Class::Load qw(load_class is_class_loaded); |
6bc86362 |
8 | use Encode qw(); |
9 | use HTML::Entities; |
10 | use Test::WWW::Mechanize; |
254eca41 |
11 | |
f21ad406 |
12 | extends 'Test::WWW::Mechanize', 'Moose::Object'; |
13 | |
2e30e0ba |
14 | #use namespace::clean -except => 'meta'; |
254eca41 |
15 | |
ad3a9fad |
16 | our $VERSION = '0.58'; |
f21ad406 |
17 | our $APP_CLASS; |
6bc86362 |
18 | my $Test = Test::Builder->new(); |
19 | |
f21ad406 |
20 | has catalyst_app => ( |
21 | is => 'ro', |
ab0b00e3 |
22 | predicate => 'has_catalyst_app', |
f21ad406 |
23 | ); |
24 | |
25 | has allow_external => ( |
26 | is => 'rw', |
27 | isa => 'Bool', |
28 | default => 0 |
29 | ); |
6bc86362 |
30 | |
1f8dbf85 |
31 | has host => ( |
32 | is => 'rw', |
33 | isa => 'Str', |
34 | clearer => 'clear_host', |
35 | predicate => 'has_host', |
36 | ); |
37 | |
254eca41 |
38 | sub new { |
f21ad406 |
39 | my $class = shift; |
254eca41 |
40 | |
dabec5e2 |
41 | my $args = ref $_[0] ? $_[0] : { @_ }; |
42 | |
43 | # Dont let LWP complain about options for our attributes |
44 | my %attr_options = map { |
45 | my $n = $_->init_arg; |
46 | defined $n && exists $args->{$n} |
47 | ? ( $n => delete $args->{$n} ) |
48 | : ( ); |
49 | } $class->meta->get_all_attributes; |
50 | |
51 | my $obj = $class->SUPER::new(%$args); |
f21ad406 |
52 | my $self = $class->meta->new_object( |
53 | __INSTANCE__ => $obj, |
ab0b00e3 |
54 | ($APP_CLASS ? (catalyst_app => $APP_CLASS) : () ), |
dabec5e2 |
55 | %attr_options |
f21ad406 |
56 | ); |
57 | |
dabec5e2 |
58 | $self->BUILDALL; |
59 | |
60 | |
61 | return $self; |
62 | } |
63 | |
64 | sub BUILD { |
65 | my ($self) = @_; |
66 | |
ab0b00e3 |
67 | unless ($ENV{CATALYST_SERVER}) { |
68 | croak "catalyst_app attribute is required unless CATALYST_SERVER env variable is set" |
69 | unless $self->has_catalyst_app; |
d25179ec |
70 | load_class($self->catalyst_app) |
71 | unless (is_class_loaded($self->catalyst_app)); |
ab0b00e3 |
72 | } |
6bc86362 |
73 | } |
74 | |
75 | sub _make_request { |
60f2b4d9 |
76 | my ( $self, $request, $arg, $size, $previous) = @_; |
6bc86362 |
77 | |
ab0b00e3 |
78 | my $response = $self->_do_catalyst_request($request); |
97ae89ab |
79 | $response->header( 'Content-Base', $response->request->uri ) |
80 | unless $response->header('Content-Base'); |
81 | |
6bc86362 |
82 | $self->cookie_jar->extract_cookies($response) if $self->cookie_jar; |
83 | |
84 | # fail tests under the Catalyst debug screen |
85 | if ( !$self->{catalyst_debug} |
86 | && $response->code == 500 |
87 | && $response->content =~ /on Catalyst \d+\.\d+/ ) |
88 | { |
89 | my ($error) |
90 | = ( $response->content =~ /<code class="error">(.*?)<\/code>/s ); |
91 | $error ||= "unknown error"; |
92 | decode_entities($error); |
93 | $Test->diag("Catalyst error screen: $error"); |
94 | $response->content(''); |
95 | $response->content_type(''); |
96 | } |
97 | |
60f2b4d9 |
98 | # NOTE: cargo-culted redirect checking from LWP::UserAgent: |
99 | $response->previous($previous) if $previous; |
100 | my $redirects = defined $response->redirects ? $response->redirects : 0; |
101 | if ($redirects > 0 and $redirects >= $self->max_redirect) { |
102 | return $self->_redirect_loop_detected($response); |
103 | } |
104 | |
6bc86362 |
105 | # check if that was a redirect |
106 | if ( $response->header('Location') |
affa35d5 |
107 | && $response->is_redirect |
6bc86362 |
108 | && $self->redirect_ok( $request, $response ) ) |
109 | { |
60f2b4d9 |
110 | return $self->_redirect_loop_detected($response) if $self->max_redirect <= 0; |
6bc86362 |
111 | |
60f2b4d9 |
112 | # TODO: this should probably create the request by cloning the original |
113 | # request and modifying it as LWP::UserAgent::request does. But for now... |
6bc86362 |
114 | |
115 | # *where* do they want us to redirect to? |
60f2b4d9 |
116 | my $location = $response->header('Location'); |
6bc86362 |
117 | |
118 | # no-one *should* be returning non-absolute URLs, but if they |
119 | # are then we'd better cope with it. Let's create a new URI, using |
120 | # our request as the base. |
121 | my $uri = URI->new_abs( $location, $request->uri )->as_string; |
60f2b4d9 |
122 | my $referral = HTTP::Request->new( GET => $uri ); |
123 | return $self->request( $referral, $arg, $size, $response ); |
6bc86362 |
124 | } else { |
125 | $response->{_raw_content} = $response->content; |
126 | } |
127 | |
128 | return $response; |
129 | } |
130 | |
60f2b4d9 |
131 | sub _redirect_loop_detected { |
132 | my ( $self, $response ) = @_; |
133 | $response->header("Client-Warning" => |
134 | "Redirect loop detected (max_redirect = " . $self->max_redirect . ")"); |
135 | $response->{_raw_content} = $response->content; |
136 | return $response; |
137 | } |
138 | |
39ba6f9a |
139 | sub _set_host_header { |
140 | my ( $self, $request ) = @_; |
141 | # If there's no Host header, set one. |
142 | unless ($request->header('Host')) { |
143 | my $host = $self->has_host |
144 | ? $self->host |
145 | : $request->uri->host; |
6ad1315b |
146 | $host .= ':'.$request->uri->_port if $request->uri->_port; |
39ba6f9a |
147 | $request->header('Host', $host); |
148 | } |
149 | } |
150 | |
ab0b00e3 |
151 | sub _do_catalyst_request { |
152 | my ($self, $request) = @_; |
153 | |
dabec5e2 |
154 | my $uri = $request->uri; |
155 | $uri->scheme('http') unless defined $uri->scheme; |
156 | $uri->host('localhost') unless defined $uri->host; |
157 | |
d6fc3a22 |
158 | $request = $self->prepare_request($request); |
ab0b00e3 |
159 | $self->cookie_jar->add_cookie_header($request) if $self->cookie_jar; |
160 | |
161 | # Woe betide anyone who unsets CATALYST_SERVER |
97ae89ab |
162 | return $self->_do_remote_request($request) |
ab0b00e3 |
163 | if $ENV{CATALYST_SERVER}; |
164 | |
39ba6f9a |
165 | $self->_set_host_header($request); |
ee072621 |
166 | |
97ae89ab |
167 | my $res = $self->_check_external_request($request); |
168 | return $res if $res; |
169 | |
ab0b00e3 |
170 | my @creds = $self->get_basic_credentials( "Basic", $uri ); |
171 | $request->authorization_basic( @creds ) if @creds; |
172 | |
ee072621 |
173 | require Catalyst; |
174 | my $response = $Catalyst::VERSION >= 5.89000 ? |
175 | Catalyst::Test::_local_request($self->{catalyst_app}, $request) : |
176 | Catalyst::Test::local_request($self->{catalyst_app}, $request); |
177 | |
97ae89ab |
178 | |
2e30e0ba |
179 | # LWP would normally do this, but we don't get down that far. |
97ae89ab |
180 | $response->request($request); |
181 | |
182 | return $response |
183 | } |
184 | |
185 | sub _check_external_request { |
186 | my ($self, $request) = @_; |
187 | |
2e30e0ba |
188 | # If there's no host then definitley not an external request. |
97ae89ab |
189 | $request->uri->can('host_port') or return; |
190 | |
191 | if ( $self->allow_external && $request->uri->host_port ne 'localhost:80' ) { |
192 | return $self->SUPER::_make_request($request); |
193 | } |
194 | return undef; |
195 | } |
196 | |
197 | sub _do_remote_request { |
198 | my ($self, $request) = @_; |
199 | |
200 | my $res = $self->_check_external_request($request); |
201 | return $res if $res; |
202 | |
203 | my $server = URI->new( $ENV{CATALYST_SERVER} ); |
204 | |
205 | if ( $server->path =~ m|^(.+)?/$| ) { |
206 | my $path = $1; |
207 | $server->path("$path") if $path; # need to be quoted |
208 | } |
209 | |
210 | # the request path needs to be sanitised if $server is using a |
211 | # non-root path due to potential overlap between request path and |
212 | # response path. |
213 | if ($server->path) { |
214 | # If request path is '/', we have to add a trailing slash to the |
215 | # final request URI |
216 | my $add_trailing = $request->uri->path eq '/'; |
217 | |
218 | my @sp = split '/', $server->path; |
219 | my @rp = split '/', $request->uri->path; |
220 | shift @sp;shift @rp; # leading / |
221 | if (@rp) { |
222 | foreach my $sp (@sp) { |
223 | $sp eq $rp[0] ? shift @rp : last |
224 | } |
225 | } |
226 | $request->uri->path(join '/', @rp); |
227 | |
228 | if ( $add_trailing ) { |
229 | $request->uri->path( $request->uri->path . '/' ); |
230 | } |
231 | } |
232 | |
233 | $request->uri->scheme( $server->scheme ); |
234 | $request->uri->host( $server->host ); |
235 | $request->uri->port( $server->port ); |
236 | $request->uri->path( $server->path . $request->uri->path ); |
39ba6f9a |
237 | $self->_set_host_header($request); |
97ae89ab |
238 | return $self->SUPER::_make_request($request); |
ab0b00e3 |
239 | } |
240 | |
6bc86362 |
241 | sub import { |
254eca41 |
242 | my ($class, $app) = @_; |
f21ad406 |
243 | |
254eca41 |
244 | if (defined $app) { |
d25179ec |
245 | load_class($app) |
246 | unless (is_class_loaded($app)); |
254eca41 |
247 | $APP_CLASS = $app; |
248 | } |
f21ad406 |
249 | |
6bc86362 |
250 | } |
251 | |
6bc86362 |
252 | |
253 | 1; |
254 | |
255 | __END__ |
256 | |
257 | =head1 NAME |
258 | |
259 | Test::WWW::Mechanize::Catalyst - Test::WWW::Mechanize for Catalyst |
260 | |
261 | =head1 SYNOPSIS |
262 | |
263 | # We're in a t/*.t test script... |
ab0b00e3 |
264 | use Test::WWW::Mechanize::Catalyst; |
265 | |
6bc86362 |
266 | # To test a Catalyst application named 'Catty': |
ab0b00e3 |
267 | my $mech = Test::WWW::Mechanize::Catalyst->new(catalyst_app => 'Catty'); |
6bc86362 |
268 | |
6bc86362 |
269 | $mech->get_ok("/"); # no hostname needed |
270 | is($mech->ct, "text/html"); |
271 | $mech->title_is("Root", "On the root page"); |
272 | $mech->content_contains("This is the root page", "Correct content"); |
273 | $mech->follow_link_ok({text => 'Hello'}, "Click on Hello"); |
274 | # ... and all other Test::WWW::Mechanize methods |
ab0b00e3 |
275 | |
276 | # White label site testing |
277 | $mech->host("foo.com"); |
278 | $mech->get_ok("/"); |
6bc86362 |
279 | |
280 | =head1 DESCRIPTION |
281 | |
d6fc3a22 |
282 | L<Catalyst> is an elegant MVC Web Application Framework. |
283 | L<Test::WWW::Mechanize> is a subclass of L<WWW::Mechanize> that incorporates |
284 | features for web application testing. The L<Test::WWW::Mechanize::Catalyst> |
285 | module meshes the two to allow easy testing of L<Catalyst> applications without |
6675038c |
286 | needing to start up a web server. |
6bc86362 |
287 | |
288 | Testing web applications has always been a bit tricky, normally |
d6fc3a22 |
289 | requiring starting a web server for your application and making real HTTP |
6bc86362 |
290 | requests to it. This module allows you to test L<Catalyst> web |
d6fc3a22 |
291 | applications but does not require a server or issue HTTP |
6bc86362 |
292 | requests. Instead, it passes the HTTP request object directly to |
293 | L<Catalyst>. Thus you do not need to use a real hostname: |
294 | "http://localhost/" will do. However, this is optional. The following |
295 | two lines of code do exactly the same thing: |
296 | |
297 | $mech->get_ok('/action'); |
298 | $mech->get_ok('http://localhost/action'); |
299 | |
300 | Links which do not begin with / or are not for localhost can be handled |
301 | as normal Web requests - this is handy if you have an external |
302 | single sign-on system. You must set allow_external to true for this: |
303 | |
d6fc3a22 |
304 | $mech->allow_external(1); |
6bc86362 |
305 | |
306 | You can also test a remote server by setting the environment variable |
d6fc3a22 |
307 | CATALYST_SERVER; for example: |
6bc86362 |
308 | |
309 | $ CATALYST_SERVER=http://example.com/myapp prove -l t |
310 | |
311 | will run the same tests on the application running at |
312 | http://example.com/myapp regardless of whether or not you specify |
313 | http:://localhost for Test::WWW::Mechanize::Catalyst. |
d6fc3a22 |
314 | |
315 | Furthermore, if you set CATALYST_SERVER, the server will be regarded |
316 | as a remote server even if your links point to localhost. Thus, you |
317 | can use Test::WWW::Mechanize::Catalyst to test your live webserver |
318 | running on your local machine, if you need to test aspects of your |
319 | deployment environment (for example, configuration options in an |
320 | http.conf file) instead of just the Catalyst request handling. |
6bc86362 |
321 | |
322 | This makes testing fast and easy. L<Test::WWW::Mechanize> provides |
323 | functions for common web testing scenarios. For example: |
324 | |
325 | $mech->get_ok( $page ); |
326 | $mech->title_is( "Invoice Status", "Make sure we're on the invoice page" ); |
327 | $mech->content_contains( "Andy Lester", "My name somewhere" ); |
328 | $mech->content_like( qr/(cpan|perl)\.org/, "Link to perl.org or CPAN" ); |
329 | |
330 | This module supports cookies automatically. |
331 | |
332 | To use this module you must pass it the name of the application. See |
333 | the SYNOPSIS above. |
334 | |
6675038c |
335 | Note that Catalyst has a special development feature: the debug |
6bc86362 |
336 | screen. By default this module will treat responses which are the |
337 | debug screen as failures. If you actually want to test debug screens, |
338 | please use: |
339 | |
6675038c |
340 | $mech->{catalyst_debug} = 1; |
6bc86362 |
341 | |
342 | An alternative to this module is L<Catalyst::Test>. |
343 | |
344 | =head1 CONSTRUCTOR |
345 | |
346 | =head2 new |
347 | |
d6fc3a22 |
348 | Behaves like, and calls, L<WWW::Mechanize>'s C<new> method. Any params |
6bc86362 |
349 | passed in get passed to WWW::Mechanize's constructor. Note that we |
350 | need to pass the name of the Catalyst application to the "use": |
351 | |
352 | use Test::WWW::Mechanize::Catalyst 'Catty'; |
353 | my $mech = Test::WWW::Mechanize::Catalyst->new; |
354 | |
355 | =head1 METHODS |
356 | |
357 | =head2 allow_external |
358 | |
359 | Links which do not begin with / or are not for localhost can be handled |
360 | as normal Web requests - this is handy if you have an external |
361 | single sign-on system. You must set allow_external to true for this: |
362 | |
6675038c |
363 | $mech->allow_external(1); |
6bc86362 |
364 | |
1f8dbf85 |
365 | head2 catalyst_app |
366 | |
367 | The name of the Catalyst app which we are testing against. Read-only. |
368 | |
369 | =head2 host |
370 | |
371 | The host value to set the "Host:" HTTP header to, if none is present already in |
372 | the request. If not set (default) then Catalyst::Test will set this to |
373 | localhost:80 |
374 | |
375 | =head2 clear_host |
376 | |
377 | Unset the host attribute. |
378 | |
379 | =head2 has_host |
380 | |
381 | Do we have a value set for the host attribute |
382 | |
6bc86362 |
383 | =head2 $mech->get_ok($url, [ \%LWP_options ,] $desc) |
384 | |
385 | A wrapper around WWW::Mechanize's get(), with similar options, except the |
386 | second argument needs to be a hash reference, not a hash. Returns true or |
387 | false. |
388 | |
389 | =head2 $mech->title_is( $str [, $desc ] ) |
390 | |
391 | Tells if the title of the page is the given string. |
392 | |
393 | $mech->title_is( "Invoice Summary" ); |
394 | |
395 | =head2 $mech->title_like( $regex [, $desc ] ) |
396 | |
397 | Tells if the title of the page matches the given regex. |
398 | |
399 | $mech->title_like( qr/Invoices for (.+)/ |
400 | |
401 | =head2 $mech->title_unlike( $regex [, $desc ] ) |
402 | |
d6fc3a22 |
403 | Tells if the title of the page does NOT match the given regex. |
6bc86362 |
404 | |
405 | $mech->title_unlike( qr/Invoices for (.+)/ |
406 | |
407 | =head2 $mech->content_is( $str [, $desc ] ) |
408 | |
6675038c |
409 | Tells if the content of the page matches the given string. |
6bc86362 |
410 | |
411 | =head2 $mech->content_contains( $str [, $desc ] ) |
412 | |
413 | Tells if the content of the page contains I<$str>. |
414 | |
415 | =head2 $mech->content_lacks( $str [, $desc ] ) |
416 | |
417 | Tells if the content of the page lacks I<$str>. |
418 | |
419 | =head2 $mech->content_like( $regex [, $desc ] ) |
420 | |
421 | Tells if the content of the page matches I<$regex>. |
422 | |
423 | =head2 $mech->content_unlike( $regex [, $desc ] ) |
424 | |
425 | Tells if the content of the page does NOT match I<$regex>. |
426 | |
427 | =head2 $mech->page_links_ok( [ $desc ] ) |
428 | |
429 | Follow all links on the current page and test for HTTP status 200 |
430 | |
431 | $mech->page_links_ok('Check all links'); |
432 | |
433 | =head2 $mech->page_links_content_like( $regex,[ $desc ] ) |
434 | |
435 | Follow all links on the current page and test their contents for I<$regex>. |
436 | |
437 | $mech->page_links_content_like( qr/foo/, |
438 | 'Check all links contain "foo"' ); |
439 | |
440 | =head2 $mech->page_links_content_unlike( $regex,[ $desc ] ) |
441 | |
442 | Follow all links on the current page and test their contents do not |
443 | contain the specified regex. |
444 | |
445 | $mech->page_links_content_unlike(qr/Restricted/, |
446 | 'Check all links do not contain Restricted'); |
447 | |
448 | =head2 $mech->links_ok( $links [, $desc ] ) |
449 | |
450 | Check the current page for specified links and test for HTTP status |
451 | 200. The links may be specified as a reference to an array containing |
452 | L<WWW::Mechanize::Link> objects, an array of URLs, or a scalar URL |
453 | name. |
454 | |
455 | my @links = $mech->find_all_links( url_regex => qr/cnn\.com$/ ); |
456 | $mech->links_ok( \@links, 'Check all links for cnn.com' ); |
457 | |
458 | my @links = qw( index.html search.html about.html ); |
459 | $mech->links_ok( \@links, 'Check main links' ); |
460 | |
461 | $mech->links_ok( 'index.html', 'Check link to index' ); |
462 | |
463 | =head2 $mech->link_status_is( $links, $status [, $desc ] ) |
464 | |
465 | Check the current page for specified links and test for HTTP status |
466 | passed. The links may be specified as a reference to an array |
467 | containing L<WWW::Mechanize::Link> objects, an array of URLs, or a |
468 | scalar URL name. |
469 | |
470 | my @links = $mech->links(); |
471 | $mech->link_status_is( \@links, 403, |
472 | 'Check all links are restricted' ); |
473 | |
474 | =head2 $mech->link_status_isnt( $links, $status [, $desc ] ) |
475 | |
476 | Check the current page for specified links and test for HTTP status |
477 | passed. The links may be specified as a reference to an array |
478 | containing L<WWW::Mechanize::Link> objects, an array of URLs, or a |
479 | scalar URL name. |
480 | |
481 | my @links = $mech->links(); |
482 | $mech->link_status_isnt( \@links, 404, |
483 | 'Check all links are not 404' ); |
484 | |
485 | =head2 $mech->link_content_like( $links, $regex [, $desc ] ) |
486 | |
487 | Check the current page for specified links and test the content of |
488 | each against I<$regex>. The links may be specified as a reference to |
489 | an array containing L<WWW::Mechanize::Link> objects, an array of URLs, |
490 | or a scalar URL name. |
491 | |
492 | my @links = $mech->links(); |
493 | $mech->link_content_like( \@links, qr/Restricted/, |
494 | 'Check all links are restricted' ); |
495 | |
496 | =head2 $mech->link_content_unlike( $links, $regex [, $desc ] ) |
497 | |
6675038c |
498 | Check the current page for specified links and test that the content of each |
6bc86362 |
499 | does not match I<$regex>. The links may be specified as a reference to |
500 | an array containing L<WWW::Mechanize::Link> objects, an array of URLs, |
501 | or a scalar URL name. |
502 | |
503 | my @links = $mech->links(); |
504 | $mech->link_content_like( \@links, qr/Restricted/, |
505 | 'Check all links are restricted' ); |
506 | |
507 | =head2 follow_link_ok( \%parms [, $comment] ) |
508 | |
509 | Makes a C<follow_link()> call and executes tests on the results. |
510 | The link must be found, and then followed successfully. Otherwise, |
511 | this test fails. |
512 | |
d6fc3a22 |
513 | I<%parms> is a hashref containing the params to pass to C<follow_link()>. |
514 | Note that the params to C<follow_link()> are a hash whereas the parms to |
6bc86362 |
515 | this function are a hashref. You have to call this function like: |
516 | |
f319e68f |
517 | $agent->follow_link_ok( {n=>3}, "looking for 3rd link" ); |
6bc86362 |
518 | |
519 | As with other test functions, C<$comment> is optional. If it is supplied |
520 | then it will display when running the test harness in verbose mode. |
521 | |
522 | Returns true value if the specified link was found and followed |
523 | successfully. The HTTP::Response object returned by follow_link() |
524 | is not available. |
525 | |
532f2706 |
526 | =head1 CAVEATS |
527 | |
528 | =head2 External Redirects and allow_external |
529 | |
530 | If you use non-fully qualified urls in your test scripts (i.e. anything without |
531 | a host, such as C<< ->get_ok( "/foo") >> ) and your app redirects to an |
532 | external URL, expect to be bitten once you come back to your application's urls |
6675038c |
533 | (it will try to request them on the remote server). This is due to a limitation |
532f2706 |
534 | in WWW::Mechanize. |
535 | |
536 | One workaround for this is that if you are expecting to redirect to an external |
6675038c |
537 | site, clone the TWMC object and use the cloned object for the external |
532f2706 |
538 | redirect. |
539 | |
540 | |
6bc86362 |
541 | =head1 SEE ALSO |
542 | |
543 | Related modules which may be of interest: L<Catalyst>, |
544 | L<Test::WWW::Mechanize>, L<WWW::Mechanize>. |
545 | |
546 | =head1 AUTHOR |
547 | |
2e30e0ba |
548 | Ash Berlin C<< <ash@cpan.org> >> (current maintainer) |
254eca41 |
549 | |
f21ad406 |
550 | Original Author: Leon Brocard, C<< <acme@astray.com> >> |
6bc86362 |
551 | |
552 | =head1 COPYRIGHT |
553 | |
6675038c |
554 | Copyright (C) 2005-9, Leon Brocard |
6bc86362 |
555 | |
556 | =head1 LICENSE |
557 | |
558 | This module is free software; you can redistribute it or modify it |
559 | under the same terms as Perl itself. |
560 | |