Commit | Line | Data |
e646f111 |
1 | package Catalyst::Engine::Test; |
2 | |
3 | use strict; |
75fd617a |
4 | use base 'Catalyst::Engine'; |
5 | |
523d44ec |
6 | use CGI::Cookie; |
75fd617a |
7 | use Class::Struct (); |
8 | use HTTP::Headers::Util 'split_header_words'; |
9 | use HTTP::Request; |
10 | use HTTP::Response; |
11 | use IO::File; |
12 | use URI; |
13 | |
14 | __PACKAGE__->mk_accessors(qw/lwp/); |
15 | |
16 | Class::Struct::struct 'Catalyst::Engine::Test::LWP' => { |
17 | request => 'HTTP::Request', |
18 | response => 'HTTP::Response', |
19 | hostname => '$', |
20 | address => '$' |
21 | }; |
e646f111 |
22 | |
23 | =head1 NAME |
24 | |
25 | Catalyst::Engine::Test - Catalyst Test Engine |
26 | |
27 | =head1 SYNOPSIS |
28 | |
c9afa5fc |
29 | A script using the Catalyst::Engine::Test module might look like: |
30 | |
31 | #!/usr/bin/perl -w |
32 | |
33 | BEGIN { |
34 | $ENV{CATALYST_ENGINE} = 'Test'; |
35 | } |
36 | |
37 | use strict; |
38 | use lib '/path/to/MyApp/lib'; |
39 | use MyApp; |
40 | |
41 | MyApp->run('/a/path'); |
e646f111 |
42 | |
43 | =head1 DESCRIPTION |
44 | |
45 | This is the Catalyst engine specialized for testing. |
46 | |
47 | =head1 OVERLOADED METHODS |
48 | |
75fd617a |
49 | This class overloads some methods from C<Catalyst::Engine>. |
e646f111 |
50 | |
51 | =over 4 |
52 | |
75fd617a |
53 | =item $c->finalize_headers |
54 | |
55 | =cut |
56 | |
57 | sub finalize_headers { |
58 | my $c = shift; |
59 | |
1a80619d |
60 | $c->lwp->response->code( $c->response->status || 200 ); |
61 | |
62 | for my $name ( $c->response->headers->header_field_names ) { |
4b19b4f3 |
63 | $c->lwp->response->push_header( $name => [ $c->response->header($name) ] ); |
1a80619d |
64 | } |
75fd617a |
65 | |
66 | while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) { |
523d44ec |
67 | my $cookie = CGI::Cookie->new( |
75fd617a |
68 | -name => $name, |
69 | -value => $cookie->{value}, |
70 | -expires => $cookie->{expires}, |
71 | -domain => $cookie->{domain}, |
72 | -path => $cookie->{path}, |
73 | -secure => $cookie->{secure} || 0 |
74 | ); |
75 | |
1a80619d |
76 | $c->lwp->response->header( 'Set-Cookie' => $cookie->as_string ); |
75fd617a |
77 | } |
75fd617a |
78 | } |
79 | |
80 | =item $c->finalize_output |
81 | |
82 | =cut |
83 | |
84 | sub finalize_output { |
85 | my $c = shift; |
86 | $c->lwp->response->content_ref( \$c->response->{output} ); |
87 | } |
88 | |
89 | =item $c->prepare_connection |
90 | |
91 | =cut |
92 | |
93 | sub prepare_connection { |
94 | my $c = shift; |
95 | $c->req->hostname( $c->lwp->hostname ); |
96 | $c->req->address( $c->lwp->address ); |
97 | } |
98 | |
99 | =item $c->prepare_cookies |
100 | |
101 | =cut |
102 | |
103 | sub prepare_cookies { |
104 | my $c = shift; |
105 | |
1a80619d |
106 | if ( my $header = $c->request->header('Cookie') ) { |
523d44ec |
107 | $c->req->cookies( { CGI::Cookie->parse($header) } ); |
75fd617a |
108 | } |
109 | } |
110 | |
111 | =item $c->prepare_headers |
112 | |
113 | =cut |
114 | |
115 | sub prepare_headers { |
116 | my $c = shift; |
117 | $c->req->method( $c->lwp->request->method ); |
118 | $c->req->headers( $c->lwp->request->headers ); |
119 | } |
120 | |
121 | =item $c->prepare_parameters |
122 | |
123 | =cut |
124 | |
125 | sub prepare_parameters { |
126 | my $c = shift; |
127 | |
128 | my @params = (); |
129 | my $request = $c->lwp->request; |
130 | |
131 | push( @params, $request->uri->query_form ); |
132 | |
133 | if ( $request->content_type eq 'application/x-www-form-urlencoded' ) { |
134 | my $uri = URI->new('http:'); |
135 | $uri->query( $request->content ); |
136 | push( @params, $uri->query_form ); |
137 | } |
138 | |
139 | if ( $request->content_type eq 'multipart/form-data' ) { |
140 | |
141 | for my $part ( $request->parts ) { |
142 | |
143 | my $disposition = $part->header('Content-Disposition'); |
144 | my %parameters = @{ ( split_header_words($disposition) )[0] }; |
145 | |
146 | if ( $parameters{filename} ) { |
147 | |
148 | my $fh = IO::File->new_tmpfile; |
149 | $fh->write( $part->content ) or die $!; |
150 | $fh->seek( SEEK_SET, 0 ) or die $!; |
151 | |
152 | $c->req->uploads->{ $parameters{filename} } = { |
153 | fh => $fh, |
154 | size => ( stat $fh )[7], |
155 | type => $part->content_type |
156 | }; |
157 | |
158 | push( @params, $parameters{filename}, $fh ); |
159 | } |
160 | else { |
161 | push( @params, $parameters{name}, $part->content ); |
162 | } |
163 | } |
164 | } |
165 | |
166 | my $parameters = $c->req->parameters; |
167 | |
168 | while ( my ( $name, $value ) = splice( @params, 0, 2 ) ) { |
169 | |
170 | if ( exists $parameters->{$name} ) { |
171 | for ( $parameters->{$name} ) { |
172 | $_ = [$_] unless ref($_) eq "ARRAY"; |
173 | push( @$_, $value ); |
174 | } |
175 | } |
176 | else { |
177 | $parameters->{$name} = $value; |
178 | } |
179 | } |
180 | } |
181 | |
182 | =item $c->prepare_path |
183 | |
184 | =cut |
185 | |
186 | sub prepare_path { |
187 | my $c = shift; |
188 | |
189 | my $base; |
190 | { |
191 | my $scheme = $c->lwp->request->uri->scheme; |
192 | my $host = $c->lwp->request->uri->host; |
193 | my $port = $c->lwp->request->uri->port; |
194 | |
195 | $base = URI->new; |
196 | $base->scheme($scheme); |
197 | $base->host($host); |
198 | $base->port($port); |
199 | |
200 | $base = $base->canonical->as_string; |
201 | } |
202 | |
203 | my $path = $c->lwp->request->uri->path || '/'; |
4b19b4f3 |
204 | $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; |
75fd617a |
205 | $path =~ s/^\///; |
206 | |
207 | $c->req->base($base); |
208 | $c->req->path($path); |
209 | } |
210 | |
211 | =item $c->prepare_request($r) |
212 | |
213 | =cut |
214 | |
215 | sub prepare_request { |
216 | my ( $c, $lwp ) = @_; |
217 | $c->lwp($lwp); |
218 | } |
219 | |
220 | =item $c->prepare_uploads |
221 | |
222 | =cut |
223 | |
224 | sub prepare_uploads { |
225 | my $c = shift; |
226 | } |
227 | |
e646f111 |
228 | =item $c->run |
229 | |
230 | =cut |
231 | |
232 | sub run { |
233 | my $class = shift; |
234 | my $request = shift || '/'; |
235 | |
236 | unless ( ref $request ) { |
45374ac6 |
237 | |
238 | my $uri = ( $request =~ m/http/i ) |
239 | ? URI->new($request) |
240 | : URI->new( 'http://localhost' . $request ); |
241 | |
242 | $request = $uri->canonical; |
e646f111 |
243 | } |
45374ac6 |
244 | |
e646f111 |
245 | unless ( ref $request eq 'HTTP::Request' ) { |
246 | $request = HTTP::Request->new( 'GET', $request ); |
247 | } |
248 | |
75fd617a |
249 | my $lwp = Catalyst::Engine::Test::LWP->new( |
45374ac6 |
250 | address => '127.0.0.1', |
1a80619d |
251 | hostname => 'localhost', |
252 | request => $request, |
253 | response => HTTP::Response->new |
45374ac6 |
254 | ); |
e646f111 |
255 | |
6f4e1683 |
256 | $class->handler($lwp); |
e646f111 |
257 | |
6f4e1683 |
258 | return $lwp->response; |
e646f111 |
259 | } |
260 | |
261 | =back |
262 | |
263 | =head1 SEE ALSO |
264 | |
265 | L<Catalyst>. |
266 | |
267 | =head1 AUTHOR |
268 | |
269 | Sebastian Riedel, C<sri@cpan.org> |
270 | Christian Hansen, C<ch@ngmedia.com> |
271 | |
272 | =head1 COPYRIGHT |
273 | |
274 | This program is free software, you can redistribute it and/or modify it under |
275 | the same terms as Perl itself. |
276 | |
277 | =cut |
278 | |
279 | 1; |