Commit | Line | Data |
fc7ec1d9 |
1 | package Catalyst::Test; |
2 | |
3 | use strict; |
b39840da |
4 | use warnings; |
d837e1a7 |
5 | |
a2f2cde9 |
6 | use Catalyst::Exception; |
d837e1a7 |
7 | use Catalyst::Utils; |
16d306fa |
8 | use Class::Inspector; |
0f895006 |
9 | |
fc7ec1d9 |
10 | =head1 NAME |
11 | |
8d2fa70c |
12 | Catalyst::Test - Test Catalyst Applications |
fc7ec1d9 |
13 | |
14 | =head1 SYNOPSIS |
15 | |
49faa307 |
16 | # Helper |
49faa307 |
17 | script/test.pl |
18 | |
fc7ec1d9 |
19 | # Tests |
20 | use Catalyst::Test 'TestApp'; |
21 | request('index.html'); |
22 | get('index.html'); |
23 | |
45374ac6 |
24 | # Run tests against a remote server |
21465c88 |
25 | CATALYST_SERVER='http://localhost:3000/' prove -r -l lib/ t/ |
45374ac6 |
26 | |
b6898a9f |
27 | # Tests with inline apps need to use Catalyst::Engine::Test |
28 | package TestApp; |
29 | |
8d2fa70c |
30 | use Catalyst; |
b6898a9f |
31 | |
c46c32fa |
32 | sub foo : Global { |
b6898a9f |
33 | my ( $self, $c ) = @_; |
34 | $c->res->output('bar'); |
c46c32fa |
35 | } |
36 | |
37 | __PACKAGE__->setup(); |
b6898a9f |
38 | |
39 | package main; |
40 | |
41 | use Test::More tests => 1; |
42 | use Catalyst::Test 'TestApp'; |
43 | |
44 | ok( get('/foo') =~ /bar/ ); |
45 | |
fc7ec1d9 |
46 | =head1 DESCRIPTION |
47 | |
8d2fa70c |
48 | Test Catalyst Applications. |
fc7ec1d9 |
49 | |
50 | =head2 METHODS |
51 | |
b5ecfcf0 |
52 | =head2 get |
fc7ec1d9 |
53 | |
54 | Returns the content. |
55 | |
56 | my $content = get('foo/bar?test=1'); |
57 | |
f13fc03f |
58 | Note that this method doesn't follow redirects, so to test for a |
59 | correctly redirecting page you'll need to use a combination of this |
60 | method and the L<request> method below: |
61 | |
62 | my $res = request('/'); # redirects to /y |
63 | warn $res->header('location'); |
64 | use URI; |
65 | my $uri = URI->new($res->header('location')); |
66 | is ( $uri->path , '/y'); |
67 | my $content = get($uri->path); |
68 | |
b5ecfcf0 |
69 | =head2 request |
fc7ec1d9 |
70 | |
71 | Returns a C<HTTP::Response> object. |
72 | |
795117cf |
73 | my $res = request('foo/bar?test=1'); |
fc7ec1d9 |
74 | |
75 | =cut |
76 | |
fc7ec1d9 |
77 | sub import { |
66d9e175 |
78 | my $self = shift; |
45374ac6 |
79 | my $class = shift; |
80 | |
81 | my ( $get, $request ); |
82 | |
d96e14c2 |
83 | if ( $ENV{CATALYST_SERVER} ) { |
45374ac6 |
84 | $request = sub { remote_request(@_) }; |
85 | $get = sub { remote_request(@_)->content }; |
fb02aed1 |
86 | } elsif (! $class) { |
87 | $request = sub { Catalyst::Exception->throw("Must specify a test app: use Catalyst::Test 'TestApp'") }; |
88 | $get = $request; |
89 | } else { |
16d306fa |
90 | unless( Class::Inspector->loaded( $class ) ) { |
1e514a51 |
91 | require Class::Inspector->filename( $class ); |
af81c980 |
92 | } |
d96e14c2 |
93 | $class->import; |
94 | |
0f895006 |
95 | $request = sub { local_request( $class, @_ ) }; |
96 | $get = sub { local_request( $class, @_ )->content }; |
49faa307 |
97 | } |
45374ac6 |
98 | |
99 | no strict 'refs'; |
100 | my $caller = caller(0); |
101 | *{"$caller\::request"} = $request; |
102 | *{"$caller\::get"} = $get; |
103 | } |
104 | |
b5ecfcf0 |
105 | =head2 local_request |
0f895006 |
106 | |
107 | =cut |
108 | |
109 | sub local_request { |
110 | my $class = shift; |
111 | |
112 | require HTTP::Request::AsCGI; |
113 | |
114 | my $request = Catalyst::Utils::request( shift(@_) ); |
115 | my $cgi = HTTP::Request::AsCGI->new( $request, %ENV )->setup; |
116 | |
117 | $class->handle_request; |
118 | |
119 | return $cgi->restore->response; |
120 | } |
121 | |
523d44ec |
122 | my $agent; |
123 | |
b5ecfcf0 |
124 | =head2 remote_request |
bea4160a |
125 | |
b77e7869 |
126 | Do an actual remote request using LWP. |
bea4160a |
127 | |
128 | =cut |
129 | |
45374ac6 |
130 | sub remote_request { |
45374ac6 |
131 | |
68eb5874 |
132 | require LWP::UserAgent; |
133 | |
d837e1a7 |
134 | my $request = Catalyst::Utils::request( shift(@_) ); |
0f895006 |
135 | my $server = URI->new( $ENV{CATALYST_SERVER} ); |
523d44ec |
136 | |
137 | if ( $server->path =~ m|^(.+)?/$| ) { |
9ffadf88 |
138 | $server->path("$1"); # need to be quoted |
f4c0f6f7 |
139 | } |
cdae055a |
140 | |
141 | # the request path needs to be sanitised if $server is using a |
142 | # non-root path due to potential overlap between request path and |
143 | # response path. |
144 | if ($server->path) { |
f4c0f6f7 |
145 | # If request path is '/', we have to add a trailing slash to the |
146 | # final request URI |
147 | my $add_trailing = $request->uri->path eq '/'; |
148 | |
cdae055a |
149 | my @sp = split '/', $server->path; |
150 | my @rp = split '/', $request->uri->path; |
151 | shift @sp;shift @rp; # leading / |
152 | if (@rp) { |
153 | foreach my $sp (@sp) { |
a7daf37e |
154 | $sp eq $rp[0] ? shift @rp : last |
cdae055a |
155 | } |
156 | } |
157 | $request->uri->path(join '/', @rp); |
f4c0f6f7 |
158 | |
159 | if ( $add_trailing ) { |
160 | $request->uri->path( $request->uri->path . '/' ); |
161 | } |
523d44ec |
162 | } |
163 | |
164 | $request->uri->scheme( $server->scheme ); |
165 | $request->uri->host( $server->host ); |
166 | $request->uri->port( $server->port ); |
167 | $request->uri->path( $server->path . $request->uri->path ); |
168 | |
68eb5874 |
169 | unless ($agent) { |
9ffadf88 |
170 | |
d837e1a7 |
171 | $agent = LWP::UserAgent->new( |
523d44ec |
172 | keep_alive => 1, |
173 | max_redirect => 0, |
174 | timeout => 60, |
175 | ); |
d837e1a7 |
176 | |
523d44ec |
177 | $agent->env_proxy; |
178 | } |
45374ac6 |
179 | |
180 | return $agent->request($request); |
fc7ec1d9 |
181 | } |
182 | |
fc7ec1d9 |
183 | =head1 SEE ALSO |
184 | |
185 | L<Catalyst>. |
186 | |
187 | =head1 AUTHOR |
188 | |
189 | Sebastian Riedel, C<sri@cpan.org> |
190 | |
191 | =head1 COPYRIGHT |
192 | |
193 | This program is free software, you can redistribute it and/or modify it under |
194 | the same terms as Perl itself. |
195 | |
196 | =cut |
197 | |
198 | 1; |