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; |
65791fc5 |
8 | use Plack::Middleware::OverrideEnv; |
a2f2cde9 |
9 | use Catalyst::Exception; |
d837e1a7 |
10 | use Catalyst::Utils; |
7dd4f037 |
11 | use Class::MOP; |
87cbe5e6 |
12 | use Sub::Exporter; |
5203d720 |
13 | use Carp; |
87cbe5e6 |
14 | |
e0a78010 |
15 | my $build_exports = sub { |
87cbe5e6 |
16 | my ($self, $meth, $args, $defaults) = @_; |
e8d0f69a |
17 | |
87cbe5e6 |
18 | my $request; |
19 | my $class = $args->{class}; |
20 | |
21 | if ( $ENV{CATALYST_SERVER} ) { |
22 | $request = sub { remote_request(@_) }; |
f4b9686b |
23 | } elsif (!$class) { |
24 | $request = sub { croak "Must specify a test app: use Catalyst::Test 'TestApp'"; } |
87cbe5e6 |
25 | } else { |
7dd4f037 |
26 | unless (Class::MOP::is_class_loaded($class)) { |
27 | Class::MOP::load_class($class); |
87cbe5e6 |
28 | } |
29 | $class->import; |
30 | |
a1791811 |
31 | my $app = $class->engine->_build_psgi_app($class); |
5203d720 |
32 | |
33 | $request = sub { local_request( $app, @_ ) }; |
87cbe5e6 |
34 | } |
35 | |
36 | my $get = sub { $request->(@_)->content }; |
37 | |
4fbc0e85 |
38 | my $ctx_request = sub { |
702729f5 |
39 | my $me = ref $self || $self; |
269194b4 |
40 | |
4fbc0e85 |
41 | ### throw an exception if ctx_request is being used against a remote |
269194b4 |
42 | ### server |
43 | Catalyst::Exception->throw("$me only works with local requests, not remote") |
44 | if $ENV{CATALYST_SERVER}; |
45 | |
ba151d0d |
46 | ### check explicitly for the class here, or the Cat->meta call will blow |
47 | ### up in our face |
48 | Catalyst::Exception->throw("Must specify a test app: use Catalyst::Test 'TestApp'") unless $class; |
49 | |
269194b4 |
50 | ### place holder for $c after the request finishes; reset every time |
51 | ### requests are done. |
52 | my $c; |
53 | |
54 | ### hook into 'dispatch' -- the function gets called after all plugins |
55 | ### have done their work, and it's an easy place to capture $c. |
269194b4 |
56 | |
cf1fb734 |
57 | my $meta = Class::MOP::get_metaclass_by_name($class); |
ba151d0d |
58 | $meta->make_mutable; |
59 | $meta->add_after_method_modifier( "dispatch", sub { |
60 | $c = shift; |
61 | }); |
cf1fb734 |
62 | $meta->make_immutable( replace_constructor => 1 ); |
94f74acd |
63 | Class::C3::reinitialize(); # Fixes RT#46459, I've failed to write a test for how/why, but it does. |
269194b4 |
64 | ### do the request; C::T::request will know about the class name, and |
65 | ### we've already stopped it from doing remote requests above. |
66 | my $res = $request->( @_ ); |
67 | |
68 | ### return both values |
69 | return ( $res, $c ); |
70 | }; |
71 | |
87cbe5e6 |
72 | return { |
4fbc0e85 |
73 | request => $request, |
74 | get => $get, |
75 | ctx_request => $ctx_request, |
87cbe5e6 |
76 | content_like => sub { |
77 | my $action = shift; |
78 | return Test::More->builder->like($get->($action),@_); |
79 | }, |
80 | action_ok => sub { |
81 | my $action = shift; |
82 | return Test::More->builder->ok($request->($action)->is_success, @_); |
83 | }, |
84 | action_redirect => sub { |
85 | my $action = shift; |
86 | return Test::More->builder->ok($request->($action)->is_redirect,@_); |
87 | }, |
88 | action_notfound => sub { |
89 | my $action = shift; |
90 | return Test::More->builder->is_eq($request->($action)->code,404,@_); |
91 | }, |
92 | contenttype_is => sub { |
93 | my $action = shift; |
94 | my $res = $request->($action); |
95 | return Test::More->builder->is_eq(scalar($res->content_type),@_); |
96 | }, |
97 | }; |
e0a78010 |
98 | }; |
e8d0f69a |
99 | |
d9d04ded |
100 | our $default_host; |
6e6df63d |
101 | |
102 | { |
103 | my $import = Sub::Exporter::build_exporter({ |
e0a78010 |
104 | groups => [ all => $build_exports ], |
6e6df63d |
105 | into_level => 1, |
106 | }); |
107 | |
d9d04ded |
108 | |
6e6df63d |
109 | sub import { |
d9d04ded |
110 | my ($self, $class, $opts) = @_; |
6e6df63d |
111 | $import->($self, '-all' => { class => $class }); |
d258fcb2 |
112 | $opts = {} unless ref $opts eq 'HASH'; |
d9d04ded |
113 | $default_host = $opts->{default_host} if exists $opts->{default_host}; |
269194b4 |
114 | return 1; |
6e6df63d |
115 | } |
116 | } |
117 | |
fc7ec1d9 |
118 | =head1 NAME |
119 | |
8d2fa70c |
120 | Catalyst::Test - Test Catalyst Applications |
fc7ec1d9 |
121 | |
122 | =head1 SYNOPSIS |
123 | |
49faa307 |
124 | # Helper |
49faa307 |
125 | script/test.pl |
126 | |
fc7ec1d9 |
127 | # Tests |
128 | use Catalyst::Test 'TestApp'; |
26dd6d9f |
129 | my $content = get('index.html'); # Content as string |
130 | my $response = request('index.html'); # HTTP::Response object |
4fbc0e85 |
131 | my($res, $c) = ctx_request('index.html'); # HTTP::Response & context object |
fc7ec1d9 |
132 | |
2f381252 |
133 | use HTTP::Request::Common; |
134 | my $response = request POST '/foo', [ |
135 | bar => 'baz', |
136 | something => 'else' |
137 | ]; |
138 | |
45374ac6 |
139 | # Run tests against a remote server |
21465c88 |
140 | CATALYST_SERVER='http://localhost:3000/' prove -r -l lib/ t/ |
45374ac6 |
141 | |
b6898a9f |
142 | use Catalyst::Test 'TestApp'; |
e8d0f69a |
143 | use Test::More tests => 1; |
b6898a9f |
144 | |
145 | ok( get('/foo') =~ /bar/ ); |
146 | |
d9d04ded |
147 | # mock virtual hosts |
148 | use Catalyst::Test 'MyApp', { default_host => 'myapp.com' }; |
149 | like( get('/whichhost'), qr/served by myapp.com/ ); |
150 | like( get( '/whichhost', { host => 'yourapp.com' } ), qr/served by yourapp.com/ ); |
151 | { |
152 | local $Catalyst::Test::default_host = 'otherapp.com'; |
153 | like( get('/whichhost'), qr/served by otherapp.com/ ); |
154 | } |
155 | |
fc7ec1d9 |
156 | =head1 DESCRIPTION |
157 | |
2f381252 |
158 | This module allows you to make requests to a Catalyst application either without |
159 | a server, by simulating the environment of an HTTP request using |
160 | L<HTTP::Request::AsCGI> or remotely if you define the CATALYST_SERVER |
0eb98177 |
161 | environment variable. This module also adds a few Catalyst-specific |
162 | testing methods as displayed in the method section. |
2f381252 |
163 | |
f98f669b |
164 | The L<get|/"$content = get( ... )"> and L<request|/"$res = request( ... );"> |
165 | functions take either a URI or an L<HTTP::Request> object. |
fc7ec1d9 |
166 | |
5f2e949d |
167 | =head1 INLINE TESTS WILL NO LONGER WORK |
168 | |
169 | While it used to be possible to inline a whole testapp into a C<.t> file for a |
170 | distribution, this will no longer work. |
171 | |
172 | The convention is to place your L<Catalyst> test apps into C<t/lib> in your |
173 | distribution. E.g.: C<t/lib/TestApp.pm>, C<t/lib/TestApp/Controller/Root.pm>, |
174 | etc.. Multiple test apps can be used in this way. |
175 | |
176 | Then write your C<.t> files like so: |
177 | |
178 | use strict; |
179 | use warnings; |
180 | use FindBin '$Bin'; |
181 | use lib "$Bin/lib"; |
182 | use Test::More tests => 6; |
183 | use Catalyst::Test 'TestApp'; |
184 | |
03f7a71b |
185 | =head1 METHODS |
fc7ec1d9 |
186 | |
26dd6d9f |
187 | =head2 $content = get( ... ) |
fc7ec1d9 |
188 | |
189 | Returns the content. |
190 | |
191 | my $content = get('foo/bar?test=1'); |
192 | |
f13fc03f |
193 | Note that this method doesn't follow redirects, so to test for a |
194 | correctly redirecting page you'll need to use a combination of this |
f98f669b |
195 | method and the L<request|/"$res = request( ... );"> method below: |
f13fc03f |
196 | |
197 | my $res = request('/'); # redirects to /y |
198 | warn $res->header('location'); |
199 | use URI; |
200 | my $uri = URI->new($res->header('location')); |
201 | is ( $uri->path , '/y'); |
202 | my $content = get($uri->path); |
203 | |
26dd6d9f |
204 | =head2 $res = request( ... ); |
fc7ec1d9 |
205 | |
0eb98177 |
206 | Returns an L<HTTP::Response> object. Accepts an optional hashref for request |
d9d04ded |
207 | header configuration; currently only supports setting 'host' value. |
fc7ec1d9 |
208 | |
795117cf |
209 | my $res = request('foo/bar?test=1'); |
d9d04ded |
210 | my $virtual_res = request('foo/bar?test=1', {host => 'virtualhost.com'}); |
fc7ec1d9 |
211 | |
26dd6d9f |
212 | =head1 FUNCTIONS |
213 | |
f2e13bbd |
214 | =head2 ($res, $c) = ctx_request( ... ); |
26dd6d9f |
215 | |
f98f669b |
216 | Works exactly like L<request|/"$res = request( ... );">, except it also returns the Catalyst context object, |
51a75afc |
217 | C<$c>. Note that this only works for local requests. |
26dd6d9f |
218 | |
26dd6d9f |
219 | =head2 $res = Catalyst::Test::local_request( $AppClass, $url ); |
0f895006 |
220 | |
2f381252 |
221 | Simulate a request using L<HTTP::Request::AsCGI>. |
222 | |
0f895006 |
223 | =cut |
224 | |
225 | sub local_request { |
5203d720 |
226 | my $app = shift; |
0f895006 |
227 | |
5203d720 |
228 | my $request = Catalyst::Utils::request(shift); |
65791fc5 |
229 | my %extra_env; |
230 | _customize_request($request, \%extra_env, @_); |
5203d720 |
231 | |
232 | my $ret; |
65791fc5 |
233 | test_psgi |
234 | app => Plack::Middleware::OverrideEnv->wrap( |
235 | $app, env_override => \%extra_env, |
236 | ), |
237 | client => sub { |
238 | $ret = shift->($request); |
239 | }; |
5203d720 |
240 | |
241 | return $ret; |
0f895006 |
242 | } |
243 | |
523d44ec |
244 | my $agent; |
245 | |
26dd6d9f |
246 | =head2 $res = Catalyst::Test::remote_request( $url ); |
bea4160a |
247 | |
b77e7869 |
248 | Do an actual remote request using LWP. |
bea4160a |
249 | |
250 | =cut |
251 | |
45374ac6 |
252 | sub remote_request { |
45374ac6 |
253 | |
68eb5874 |
254 | require LWP::UserAgent; |
255 | |
d837e1a7 |
256 | my $request = Catalyst::Utils::request( shift(@_) ); |
0f895006 |
257 | my $server = URI->new( $ENV{CATALYST_SERVER} ); |
523d44ec |
258 | |
d9d04ded |
259 | _customize_request($request, @_); |
260 | |
523d44ec |
261 | if ( $server->path =~ m|^(.+)?/$| ) { |
890e8d18 |
262 | my $path = $1; |
263 | $server->path("$path") if $path; # need to be quoted |
f4c0f6f7 |
264 | } |
cdae055a |
265 | |
266 | # the request path needs to be sanitised if $server is using a |
267 | # non-root path due to potential overlap between request path and |
268 | # response path. |
269 | if ($server->path) { |
f4c0f6f7 |
270 | # If request path is '/', we have to add a trailing slash to the |
271 | # final request URI |
272 | my $add_trailing = $request->uri->path eq '/'; |
0eb98177 |
273 | |
cdae055a |
274 | my @sp = split '/', $server->path; |
275 | my @rp = split '/', $request->uri->path; |
276 | shift @sp;shift @rp; # leading / |
277 | if (@rp) { |
278 | foreach my $sp (@sp) { |
a7daf37e |
279 | $sp eq $rp[0] ? shift @rp : last |
cdae055a |
280 | } |
281 | } |
282 | $request->uri->path(join '/', @rp); |
0eb98177 |
283 | |
f4c0f6f7 |
284 | if ( $add_trailing ) { |
285 | $request->uri->path( $request->uri->path . '/' ); |
286 | } |
523d44ec |
287 | } |
288 | |
289 | $request->uri->scheme( $server->scheme ); |
290 | $request->uri->host( $server->host ); |
291 | $request->uri->port( $server->port ); |
292 | $request->uri->path( $server->path . $request->uri->path ); |
293 | |
68eb5874 |
294 | unless ($agent) { |
9ffadf88 |
295 | |
d837e1a7 |
296 | $agent = LWP::UserAgent->new( |
523d44ec |
297 | keep_alive => 1, |
298 | max_redirect => 0, |
299 | timeout => 60, |
0eb98177 |
300 | |
d11e0c1d |
301 | # work around newer LWP max_redirect 0 bug |
302 | # http://rt.cpan.org/Ticket/Display.html?id=40260 |
303 | requests_redirectable => [], |
523d44ec |
304 | ); |
d837e1a7 |
305 | |
523d44ec |
306 | $agent->env_proxy; |
307 | } |
45374ac6 |
308 | |
309 | return $agent->request($request); |
fc7ec1d9 |
310 | } |
311 | |
d9d04ded |
312 | sub _customize_request { |
313 | my $request = shift; |
65791fc5 |
314 | my $extra_env = shift; |
d9d04ded |
315 | my $opts = pop(@_) || {}; |
4348c28b |
316 | $opts = {} unless ref($opts) eq 'HASH'; |
d9d04ded |
317 | if ( my $host = exists $opts->{host} ? $opts->{host} : $default_host ) { |
318 | $request->header( 'Host' => $host ); |
319 | } |
65791fc5 |
320 | |
321 | if (my $extra = $opts->{extra_env}) { |
322 | @{ $extra_env }{keys %{ $extra }} = values %{ $extra }; |
323 | } |
d9d04ded |
324 | } |
325 | |
e8d0f69a |
326 | =head2 action_ok |
327 | |
0eb98177 |
328 | Fetches the given URL and checks that the request was successful. |
e8d0f69a |
329 | |
330 | =head2 action_redirect |
331 | |
0eb98177 |
332 | Fetches the given URL and checks that the request was a redirect. |
e8d0f69a |
333 | |
334 | =head2 action_notfound |
335 | |
0eb98177 |
336 | Fetches the given URL and checks that the request was not found. |
337 | |
338 | =head2 content_like( $url, $regexp [, $test_name] ) |
e8d0f69a |
339 | |
0eb98177 |
340 | Fetches the given URL and returns whether the content matches the regexp. |
e8d0f69a |
341 | |
0eb98177 |
342 | =head2 contenttype_is |
e8d0f69a |
343 | |
0eb98177 |
344 | Check for given MIME type. |
e8d0f69a |
345 | |
fc7ec1d9 |
346 | =head1 SEE ALSO |
347 | |
2f381252 |
348 | L<Catalyst>, L<Test::WWW::Mechanize::Catalyst>, |
349 | L<Test::WWW::Selenium::Catalyst>, L<Test::More>, L<HTTP::Request::Common> |
fc7ec1d9 |
350 | |
2f381252 |
351 | =head1 AUTHORS |
fc7ec1d9 |
352 | |
2f381252 |
353 | Catalyst Contributors, see Catalyst.pm |
fc7ec1d9 |
354 | |
355 | =head1 COPYRIGHT |
356 | |
536bee89 |
357 | This library is free software. You can redistribute it and/or modify it under |
fc7ec1d9 |
358 | the same terms as Perl itself. |
359 | |
360 | =cut |
361 | |
362 | 1; |