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