Commit | Line | Data |
fc7ec1d9 |
1 | package Catalyst::Test; |
2 | |
d9d04ded |
3 | use strict; |
4 | use warnings; |
b474372a |
5 | use Test::More (); |
e8d0f69a |
6 | |
5203d720 |
7 | use Plack::Test; |
a2f2cde9 |
8 | use Catalyst::Exception; |
d837e1a7 |
9 | use Catalyst::Utils; |
e7399d8b |
10 | use Class::Load qw(load_class is_class_loaded); |
87cbe5e6 |
11 | use Sub::Exporter; |
dd5b1dc4 |
12 | use Moose::Util 'find_meta'; |
2a2c99c6 |
13 | use Carp 'croak', 'carp'; |
87cbe5e6 |
14 | |
a0655e3a |
15 | sub _build_request_export { |
16 | my ($self, $args) = @_; |
17 | |
2a2c99c6 |
18 | return sub { _remote_request(@_) } |
a0655e3a |
19 | if $args->{remote}; |
e8d0f69a |
20 | |
87cbe5e6 |
21 | my $class = $args->{class}; |
22 | |
a0655e3a |
23 | # Here we should be failing right away, but for some stupid backcompat thing |
24 | # I don't quite remember we fail lazily here. Needs a proper deprecation and |
25 | # then removal. |
26 | return sub { croak "Must specify a test app: use Catalyst::Test 'TestApp'" } |
27 | unless $class; |
28 | |
e7399d8b |
29 | load_class($class) unless is_class_loaded($class); |
a0655e3a |
30 | $class->import; |
87cbe5e6 |
31 | |
2a2c99c6 |
32 | return sub { _local_request( $class, @_ ) }; |
a0655e3a |
33 | } |
87cbe5e6 |
34 | |
a0655e3a |
35 | sub _build_get_export { |
36 | my ($self, $args) = @_; |
37 | my $request = $args->{request}; |
87cbe5e6 |
38 | |
a0655e3a |
39 | return sub { $request->(@_)->content }; |
40 | } |
41 | sub _build_ctx_request_export { |
42 | my ($self, $args) = @_; |
43 | my ($class, $request) = @{ $args }{qw(class request)}; |
44 | |
45 | return sub { |
702729f5 |
46 | my $me = ref $self || $self; |
269194b4 |
47 | |
eede256e |
48 | # fail if ctx_request is being used against a remote server |
269194b4 |
49 | Catalyst::Exception->throw("$me only works with local requests, not remote") |
50 | if $ENV{CATALYST_SERVER}; |
51 | |
eede256e |
52 | # check explicitly for the class here, or the Cat->meta call will blow |
53 | # up in our face |
ba151d0d |
54 | Catalyst::Exception->throw("Must specify a test app: use Catalyst::Test 'TestApp'") unless $class; |
55 | |
eede256e |
56 | # place holder for $c after the request finishes; reset every time |
57 | # requests are done. |
9c74923d |
58 | my $ctx_closed_over; |
269194b4 |
59 | |
eede256e |
60 | # hook into 'dispatch' -- the function gets called after all plugins |
61 | # have done their work, and it's an easy place to capture $c. |
dd5b1dc4 |
62 | my $meta = find_meta($class); |
ba151d0d |
63 | $meta->make_mutable; |
64 | $meta->add_after_method_modifier( "dispatch", sub { |
9c74923d |
65 | $ctx_closed_over = shift; |
ba151d0d |
66 | }); |
cf1fb734 |
67 | $meta->make_immutable( replace_constructor => 1 ); |
94f74acd |
68 | Class::C3::reinitialize(); # Fixes RT#46459, I've failed to write a test for how/why, but it does. |
eede256e |
69 | |
70 | # do the request; C::T::request will know about the class name, and |
71 | # we've already stopped it from doing remote requests above. |
a0655e3a |
72 | my $res = $args->{request}->( @_ ); |
269194b4 |
73 | |
9c74923d |
74 | # Make sure not to leave a reference $ctx hanging around. |
75 | # This means that the context will go out of scope as soon as the |
76 | # caller disposes of it, rather than waiting till the next time |
77 | # that ctx_request is called. This can be important if your $ctx |
78 | # ends up with a reference to a shared resource or lock (for example) |
79 | # which you want to clean up in test teardown - if the $ctx is still |
80 | # closed over then you're stuffed... |
81 | my $ctx = $ctx_closed_over; |
82 | undef $ctx_closed_over; |
83 | |
9c74923d |
84 | return ( $res, $ctx ); |
269194b4 |
85 | }; |
a0655e3a |
86 | } |
87 | |
88 | my $build_exports = sub { |
89 | my ($self, $meth, $args, $defaults) = @_; |
90 | my $class = $args->{class}; |
91 | |
92 | my $request = $self->_build_request_export({ |
93 | class => $class, |
94 | remote => $ENV{CATALYST_SERVER}, |
95 | }); |
96 | |
97 | my $get = $self->_build_get_export({ request => $request }); |
98 | |
99 | my $ctx_request = $self->_build_ctx_request_export({ |
100 | class => $class, |
101 | request => $request, |
102 | }); |
269194b4 |
103 | |
87cbe5e6 |
104 | return { |
4fbc0e85 |
105 | request => $request, |
106 | get => $get, |
107 | ctx_request => $ctx_request, |
87cbe5e6 |
108 | content_like => sub { |
109 | my $action = shift; |
110 | return Test::More->builder->like($get->($action),@_); |
111 | }, |
112 | action_ok => sub { |
113 | my $action = shift; |
901991e6 |
114 | my $meth = $request->($action)->request->method; |
115 | my @args = @_ ? @_ : ("$meth $action returns successfully"); |
116 | return Test::More->builder->ok($request->($action)->is_success,@args); |
87cbe5e6 |
117 | }, |
118 | action_redirect => sub { |
119 | my $action = shift; |
901991e6 |
120 | my $meth = $request->($action)->request->method; |
121 | my @args = @_ ? @_ : ("$meth $action returns a redirect"); |
122 | return Test::More->builder->ok($request->($action)->is_redirect,@args); |
87cbe5e6 |
123 | }, |
124 | action_notfound => sub { |
125 | my $action = shift; |
901991e6 |
126 | my $meth = $request->($action)->request->method; |
127 | my @args = @_ ? @_ : ("$meth $action returns a 404"); |
128 | return Test::More->builder->is_eq($request->($action)->code,404,@args); |
87cbe5e6 |
129 | }, |
130 | contenttype_is => sub { |
131 | my $action = shift; |
132 | my $res = $request->($action); |
133 | return Test::More->builder->is_eq(scalar($res->content_type),@_); |
134 | }, |
135 | }; |
e0a78010 |
136 | }; |
e8d0f69a |
137 | |
d9d04ded |
138 | our $default_host; |
6e6df63d |
139 | |
140 | { |
141 | my $import = Sub::Exporter::build_exporter({ |
e0a78010 |
142 | groups => [ all => $build_exports ], |
6e6df63d |
143 | into_level => 1, |
144 | }); |
145 | |
d9d04ded |
146 | |
6e6df63d |
147 | sub import { |
d9d04ded |
148 | my ($self, $class, $opts) = @_; |
955d6da6 |
149 | Carp::carp( |
150 | qq{Importing Catalyst::Test without an application name is deprecated:\n |
151 | Instead of saying: use Catalyst::Test; |
152 | say: use Catalyst::Test (); # If you don't want to import a test app right now. |
153 | or say: use Catalyst::Test 'MyApp'; # If you do want to import a test app.\n\n}) |
154 | unless $class; |
6e6df63d |
155 | $import->($self, '-all' => { class => $class }); |
d258fcb2 |
156 | $opts = {} unless ref $opts eq 'HASH'; |
d9d04ded |
157 | $default_host = $opts->{default_host} if exists $opts->{default_host}; |
269194b4 |
158 | return 1; |
6e6df63d |
159 | } |
160 | } |
161 | |
fc7ec1d9 |
162 | =head1 NAME |
163 | |
8d2fa70c |
164 | Catalyst::Test - Test Catalyst Applications |
fc7ec1d9 |
165 | |
166 | =head1 SYNOPSIS |
167 | |
49faa307 |
168 | # Helper |
49faa307 |
169 | script/test.pl |
170 | |
fc7ec1d9 |
171 | # Tests |
172 | use Catalyst::Test 'TestApp'; |
26dd6d9f |
173 | my $content = get('index.html'); # Content as string |
174 | my $response = request('index.html'); # HTTP::Response object |
4fbc0e85 |
175 | my($res, $c) = ctx_request('index.html'); # HTTP::Response & context object |
fc7ec1d9 |
176 | |
2f381252 |
177 | use HTTP::Request::Common; |
178 | my $response = request POST '/foo', [ |
179 | bar => 'baz', |
180 | something => 'else' |
181 | ]; |
182 | |
45374ac6 |
183 | # Run tests against a remote server |
21465c88 |
184 | CATALYST_SERVER='http://localhost:3000/' prove -r -l lib/ t/ |
45374ac6 |
185 | |
b6898a9f |
186 | use Catalyst::Test 'TestApp'; |
e8d0f69a |
187 | use Test::More tests => 1; |
b6898a9f |
188 | |
189 | ok( get('/foo') =~ /bar/ ); |
190 | |
d9d04ded |
191 | # mock virtual hosts |
192 | use Catalyst::Test 'MyApp', { default_host => 'myapp.com' }; |
193 | like( get('/whichhost'), qr/served by myapp.com/ ); |
194 | like( get( '/whichhost', { host => 'yourapp.com' } ), qr/served by yourapp.com/ ); |
195 | { |
196 | local $Catalyst::Test::default_host = 'otherapp.com'; |
197 | like( get('/whichhost'), qr/served by otherapp.com/ ); |
198 | } |
199 | |
fc7ec1d9 |
200 | =head1 DESCRIPTION |
201 | |
2f381252 |
202 | This module allows you to make requests to a Catalyst application either without |
203 | a server, by simulating the environment of an HTTP request using |
204 | L<HTTP::Request::AsCGI> or remotely if you define the CATALYST_SERVER |
0eb98177 |
205 | environment variable. This module also adds a few Catalyst-specific |
206 | testing methods as displayed in the method section. |
2f381252 |
207 | |
f98f669b |
208 | The L<get|/"$content = get( ... )"> and L<request|/"$res = request( ... );"> |
209 | functions take either a URI or an L<HTTP::Request> object. |
fc7ec1d9 |
210 | |
5f2e949d |
211 | =head1 INLINE TESTS WILL NO LONGER WORK |
212 | |
965f3e35 |
213 | While it used to be possible to inline a whole test app into a C<.t> file for |
214 | a distribution, this will no longer work. |
5f2e949d |
215 | |
216 | The convention is to place your L<Catalyst> test apps into C<t/lib> in your |
217 | distribution. E.g.: C<t/lib/TestApp.pm>, C<t/lib/TestApp/Controller/Root.pm>, |
218 | etc.. Multiple test apps can be used in this way. |
219 | |
220 | Then write your C<.t> files like so: |
221 | |
222 | use strict; |
223 | use warnings; |
224 | use FindBin '$Bin'; |
225 | use lib "$Bin/lib"; |
226 | use Test::More tests => 6; |
227 | use Catalyst::Test 'TestApp'; |
228 | |
03f7a71b |
229 | =head1 METHODS |
fc7ec1d9 |
230 | |
26dd6d9f |
231 | =head2 $content = get( ... ) |
fc7ec1d9 |
232 | |
233 | Returns the content. |
234 | |
235 | my $content = get('foo/bar?test=1'); |
236 | |
f13fc03f |
237 | Note that this method doesn't follow redirects, so to test for a |
238 | correctly redirecting page you'll need to use a combination of this |
f98f669b |
239 | method and the L<request|/"$res = request( ... );"> method below: |
f13fc03f |
240 | |
241 | my $res = request('/'); # redirects to /y |
242 | warn $res->header('location'); |
243 | use URI; |
244 | my $uri = URI->new($res->header('location')); |
245 | is ( $uri->path , '/y'); |
246 | my $content = get($uri->path); |
247 | |
8fa9321c |
248 | Note also that the content is returned as raw bytes, without any attempt |
249 | to decode it into characters. |
250 | |
26dd6d9f |
251 | =head2 $res = request( ... ); |
fc7ec1d9 |
252 | |
0eb98177 |
253 | Returns an L<HTTP::Response> object. Accepts an optional hashref for request |
d9d04ded |
254 | header configuration; currently only supports setting 'host' value. |
fc7ec1d9 |
255 | |
795117cf |
256 | my $res = request('foo/bar?test=1'); |
d9d04ded |
257 | my $virtual_res = request('foo/bar?test=1', {host => 'virtualhost.com'}); |
fc7ec1d9 |
258 | |
f2e13bbd |
259 | =head2 ($res, $c) = ctx_request( ... ); |
26dd6d9f |
260 | |
f98f669b |
261 | Works exactly like L<request|/"$res = request( ... );">, except it also returns the Catalyst context object, |
51a75afc |
262 | C<$c>. Note that this only works for local requests. |
26dd6d9f |
263 | |
0f895006 |
264 | =cut |
265 | |
aa3f9f53 |
266 | sub _request { |
267 | my $args = shift; |
0f895006 |
268 | |
5203d720 |
269 | my $request = Catalyst::Utils::request(shift); |
aa3f9f53 |
270 | |
65791fc5 |
271 | my %extra_env; |
272 | _customize_request($request, \%extra_env, @_); |
aa3f9f53 |
273 | $args->{mangle_request}->($request) if $args->{mangle_request}; |
5203d720 |
274 | |
275 | my $ret; |
65791fc5 |
276 | test_psgi |
aa3f9f53 |
277 | %{ $args }, |
278 | app => sub { $args->{app}->({ %{ $_[0] }, %extra_env }) }, |
9c74923d |
279 | client => sub { |
aa3f9f53 |
280 | my ($psgi_app) = @_; |
de1a65a7 |
281 | my $resp = $psgi_app->($request); |
aa3f9f53 |
282 | $args->{mangle_response}->($resp) if $args->{mangle_response}; |
283 | $ret = $resp; |
284 | }; |
285 | |
286 | return $ret; |
287 | } |
288 | |
289 | sub _local_request { |
290 | my $class = shift; |
291 | |
292 | return _request({ |
293 | app => ref($class) eq "CODE" ? $class : $class->_finalized_psgi_app, |
294 | mangle_response => sub { |
295 | my ($resp) = @_; |
9c74923d |
296 | |
297 | # HTML head parsing based on LWP::UserAgent |
298 | # |
6664017d |
299 | # This is because if you make a remote request with LWP, then the |
300 | # <BASE HREF="..."> from the returned HTML document will be used |
301 | # to fill in $res->base, as documented in HTTP::Response. We need |
302 | # to support this in local test requests so that they work 'the same'. |
303 | # |
9c74923d |
304 | # This is not just horrible and possibly broken, but also really |
305 | # doesn't belong here. Whoever wants this should be working on |
306 | # getting it into Plack::Test, or make a middleware out of it, or |
307 | # whatever. Seriously - horrible. |
308 | |
d0cacee7 |
309 | if (!$resp->content_type || $resp->content_is_html) { |
310 | require HTML::HeadParser; |
311 | |
312 | my $parser = HTML::HeadParser->new(); |
313 | $parser->xml_mode(1) if $resp->content_is_xhtml; |
314 | $parser->utf8_mode(1) if $] >= 5.008 && $HTML::Parser::VERSION >= 3.40; |
315 | |
316 | $parser->parse( $resp->content ); |
317 | my $h = $parser->header; |
318 | for my $f ( $h->header_field_names ) { |
319 | $resp->init_header( $f, [ $h->header($f) ] ); |
320 | } |
9c74923d |
321 | } |
89222c2a |
322 | # Another horrible hack to make the response headers have a |
323 | # 'status' field. This is for back-compat, but you should |
324 | # call $resp->code instead! |
325 | $resp->init_header('status', [ $resp->code ]); |
aa3f9f53 |
326 | }, |
327 | }, @_); |
0f895006 |
328 | } |
329 | |
523d44ec |
330 | my $agent; |
331 | |
2a2c99c6 |
332 | sub _remote_request { |
68eb5874 |
333 | require LWP::UserAgent; |
555c9ff7 |
334 | local $Plack::Test::Impl = 'ExternalServer'; |
68eb5874 |
335 | |
68eb5874 |
336 | unless ($agent) { |
d837e1a7 |
337 | $agent = LWP::UserAgent->new( |
523d44ec |
338 | keep_alive => 1, |
339 | max_redirect => 0, |
340 | timeout => 60, |
0eb98177 |
341 | |
d11e0c1d |
342 | # work around newer LWP max_redirect 0 bug |
343 | # http://rt.cpan.org/Ticket/Display.html?id=40260 |
344 | requests_redirectable => [], |
523d44ec |
345 | ); |
d837e1a7 |
346 | |
523d44ec |
347 | $agent->env_proxy; |
348 | } |
45374ac6 |
349 | |
555c9ff7 |
350 | |
aa3f9f53 |
351 | my $server = URI->new($ENV{CATALYST_SERVER}); |
352 | if ( $server->path =~ m|^(.+)?/$| ) { |
353 | my $path = $1; |
354 | $server->path("$path") if $path; # need to be quoted |
355 | } |
356 | |
357 | return _request({ |
358 | ua => $agent, |
359 | uri => $server, |
360 | mangle_request => sub { |
361 | my ($request) = @_; |
362 | |
363 | # the request path needs to be sanitised if $server is using a |
364 | # non-root path due to potential overlap between request path and |
365 | # response path. |
366 | if ($server->path) { |
367 | # If request path is '/', we have to add a trailing slash to the |
368 | # final request URI |
369 | my $add_trailing = ($request->uri->path eq '/' || $request->uri->path eq '') ? 1 : 0; |
370 | |
371 | my @sp = split '/', $server->path; |
372 | my @rp = split '/', $request->uri->path; |
373 | shift @sp; shift @rp; # leading / |
374 | if (@rp) { |
375 | foreach my $sp (@sp) { |
376 | $sp eq $rp[0] ? shift @rp : last |
377 | } |
378 | } |
379 | $request->uri->path(join '/', @rp); |
380 | |
381 | if ( $add_trailing ) { |
382 | $request->uri->path( $request->uri->path . '/' ); |
383 | } |
384 | } |
385 | }, |
386 | }, @_); |
fc7ec1d9 |
387 | } |
388 | |
2a2c99c6 |
389 | for my $name (qw(local_request remote_request)) { |
390 | my $fun = sub { |
391 | carp <<"EOW"; |
392 | Calling Catalyst::Test::${name}() directly is deprecated. |
393 | |
394 | Please import Catalyst::Test into your namespace and use the provided request() |
395 | function instead. |
396 | EOW |
397 | return __PACKAGE__->can("_${name}")->(@_); |
398 | }; |
399 | |
400 | no strict 'refs'; |
401 | *$name = $fun; |
402 | } |
403 | |
d9d04ded |
404 | sub _customize_request { |
405 | my $request = shift; |
65791fc5 |
406 | my $extra_env = shift; |
d9d04ded |
407 | my $opts = pop(@_) || {}; |
4348c28b |
408 | $opts = {} unless ref($opts) eq 'HASH'; |
d9d04ded |
409 | if ( my $host = exists $opts->{host} ? $opts->{host} : $default_host ) { |
410 | $request->header( 'Host' => $host ); |
411 | } |
65791fc5 |
412 | |
413 | if (my $extra = $opts->{extra_env}) { |
414 | @{ $extra_env }{keys %{ $extra }} = values %{ $extra }; |
415 | } |
d9d04ded |
416 | } |
417 | |
0bf3b41c |
418 | =head2 action_ok($url [, $test_name ]) |
e8d0f69a |
419 | |
0bf3b41c |
420 | Fetches the given URL and checks that the request was successful. An optional |
421 | second argument can be given to specify the name of the test. |
e8d0f69a |
422 | |
0bf3b41c |
423 | =head2 action_redirect($url [, $test_name ]) |
e8d0f69a |
424 | |
0bf3b41c |
425 | Fetches the given URL and checks that the request was a redirect. An optional |
426 | second argument can be given to specify the name of the test. |
e8d0f69a |
427 | |
0bf3b41c |
428 | =head2 action_notfound($url [, $test_name ]) |
e8d0f69a |
429 | |
0bf3b41c |
430 | Fetches the given URL and checks that the request was not found. An optional |
431 | second argument can be given to specify the name of the test. |
0eb98177 |
432 | |
0bf3b41c |
433 | =head2 content_like( $url, $regexp [, $test_name ] ) |
e8d0f69a |
434 | |
0bf3b41c |
435 | Fetches the given URL and returns whether the content matches the regexp. An |
436 | optional third argument can be given to specify the name of the test. |
e8d0f69a |
437 | |
0bf3b41c |
438 | =head2 contenttype_is($url, $type [, $test_name ]) |
e8d0f69a |
439 | |
0bf3b41c |
440 | Verify the given URL has a content type of $type and optionally specify a test name. |
e8d0f69a |
441 | |
fc7ec1d9 |
442 | =head1 SEE ALSO |
443 | |
2f381252 |
444 | L<Catalyst>, L<Test::WWW::Mechanize::Catalyst>, |
445 | L<Test::WWW::Selenium::Catalyst>, L<Test::More>, L<HTTP::Request::Common> |
fc7ec1d9 |
446 | |
2f381252 |
447 | =head1 AUTHORS |
fc7ec1d9 |
448 | |
2f381252 |
449 | Catalyst Contributors, see Catalyst.pm |
fc7ec1d9 |
450 | |
451 | =head1 COPYRIGHT |
452 | |
536bee89 |
453 | This library is free software. You can redistribute it and/or modify it under |
fc7ec1d9 |
454 | the same terms as Perl itself. |
455 | |
2a2c99c6 |
456 | =begin Pod::Coverage |
457 | |
458 | local_request |
459 | |
460 | remote_request |
461 | |
462 | =end Pod::Coverage |
463 | |
fc7ec1d9 |
464 | =cut |
465 | |
466 | 1; |