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 | |
06e1b616 |
52 | =item $c->finalize_body |
53 | |
54 | =cut |
55 | |
56 | sub finalize_body { |
57 | my $c = shift; |
d7945f32 |
58 | $c->http->response->content( $c->response->body ); |
06e1b616 |
59 | } |
60 | |
75fd617a |
61 | =item $c->finalize_headers |
62 | |
63 | =cut |
64 | |
65 | sub finalize_headers { |
66 | my $c = shift; |
67 | |
6dc87a0f |
68 | $c->http->response->code( $c->response->status ); |
1a80619d |
69 | |
70 | for my $name ( $c->response->headers->header_field_names ) { |
6dc87a0f |
71 | $c->http->response->push_header( $name => [ $c->response->header($name) ] ); |
75fd617a |
72 | } |
75fd617a |
73 | } |
74 | |
06e1b616 |
75 | =item $c->prepare_body |
75fd617a |
76 | |
77 | =cut |
78 | |
06e1b616 |
79 | sub prepare_body { |
75fd617a |
80 | my $c = shift; |
e060fe05 |
81 | $c->request->body( $c->http->request->content ); |
75fd617a |
82 | } |
83 | |
84 | =item $c->prepare_connection |
85 | |
86 | =cut |
87 | |
88 | sub prepare_connection { |
89 | my $c = shift; |
bfde09a2 |
90 | $c->request->address( $c->http->address ); |
91 | $c->request->hostname( $c->http->hostname ); |
92 | $c->request->protocol( $c->http->request->protocol ); |
75fd617a |
93 | } |
94 | |
95 | =item $c->prepare_headers |
96 | |
97 | =cut |
98 | |
99 | sub prepare_headers { |
100 | my $c = shift; |
bfde09a2 |
101 | $c->request->method( $c->http->request->method ); |
102 | $c->request->headers( $c->http->request->headers ); |
75fd617a |
103 | } |
104 | |
105 | =item $c->prepare_parameters |
106 | |
107 | =cut |
108 | |
109 | sub prepare_parameters { |
110 | my $c = shift; |
111 | |
e7c0c583 |
112 | my ( @params, @uploads ); |
113 | |
6dc87a0f |
114 | my $request = $c->http->request; |
75fd617a |
115 | |
116 | push( @params, $request->uri->query_form ); |
117 | |
118 | if ( $request->content_type eq 'application/x-www-form-urlencoded' ) { |
119 | my $uri = URI->new('http:'); |
120 | $uri->query( $request->content ); |
121 | push( @params, $uri->query_form ); |
122 | } |
123 | |
124 | if ( $request->content_type eq 'multipart/form-data' ) { |
125 | |
126 | for my $part ( $request->parts ) { |
127 | |
128 | my $disposition = $part->header('Content-Disposition'); |
129 | my %parameters = @{ ( split_header_words($disposition) )[0] }; |
130 | |
131 | if ( $parameters{filename} ) { |
132 | |
146554c5 |
133 | my $fh = File::Temp->new( UNLINK => 0 ); |
75fd617a |
134 | $fh->write( $part->content ) or die $!; |
d3fced79 |
135 | $fh->flush or die $!; |
e7c0c583 |
136 | |
146554c5 |
137 | my $upload = Catalyst::Request::Upload->new( |
e7c0c583 |
138 | filename => $parameters{filename}, |
c462faf0 |
139 | size => ( $fh->stat )[7], |
e7c0c583 |
140 | tempname => $fh->filename, |
141 | type => $part->content_type |
146554c5 |
142 | ); |
61bacdcc |
143 | |
146554c5 |
144 | $fh->close; |
75fd617a |
145 | |
e7c0c583 |
146 | push( @uploads, $parameters{name}, $upload ); |
d3fced79 |
147 | push( @params, $parameters{name}, $parameters{filename} ); |
75fd617a |
148 | } |
149 | else { |
150 | push( @params, $parameters{name}, $part->content ); |
151 | } |
152 | } |
153 | } |
61bacdcc |
154 | |
bfde09a2 |
155 | $c->request->param(@params); |
156 | $c->request->upload(@uploads); |
75fd617a |
157 | } |
158 | |
159 | =item $c->prepare_path |
160 | |
161 | =cut |
162 | |
163 | sub prepare_path { |
164 | my $c = shift; |
165 | |
166 | my $base; |
167 | { |
6dc87a0f |
168 | my $scheme = $c->http->request->uri->scheme; |
169 | my $host = $c->http->request->uri->host; |
170 | my $port = $c->http->request->uri->port; |
75fd617a |
171 | |
172 | $base = URI->new; |
173 | $base->scheme($scheme); |
174 | $base->host($host); |
175 | $base->port($port); |
176 | |
177 | $base = $base->canonical->as_string; |
178 | } |
179 | |
6dc87a0f |
180 | my $path = $c->http->request->uri->path || '/'; |
4b19b4f3 |
181 | $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; |
75fd617a |
182 | $path =~ s/^\///; |
183 | |
184 | $c->req->base($base); |
185 | $c->req->path($path); |
186 | } |
187 | |
188 | =item $c->prepare_request($r) |
189 | |
190 | =cut |
191 | |
192 | sub prepare_request { |
6dc87a0f |
193 | my ( $c, $http ) = @_; |
194 | $c->http($http); |
75fd617a |
195 | } |
196 | |
197 | =item $c->prepare_uploads |
198 | |
199 | =cut |
200 | |
201 | sub prepare_uploads { |
202 | my $c = shift; |
203 | } |
204 | |
e646f111 |
205 | =item $c->run |
206 | |
207 | =cut |
208 | |
209 | sub run { |
210 | my $class = shift; |
211 | my $request = shift || '/'; |
212 | |
213 | unless ( ref $request ) { |
45374ac6 |
214 | |
e7c0c583 |
215 | my $uri = |
216 | ( $request =~ m/http/i ) |
45374ac6 |
217 | ? URI->new($request) |
218 | : URI->new( 'http://localhost' . $request ); |
219 | |
220 | $request = $uri->canonical; |
e646f111 |
221 | } |
45374ac6 |
222 | |
e646f111 |
223 | unless ( ref $request eq 'HTTP::Request' ) { |
224 | $request = HTTP::Request->new( 'GET', $request ); |
225 | } |
226 | |
4716267f |
227 | my $host = sprintf( '%s:%d', $request->uri->host, $request->uri->port ); |
228 | $request->header( 'Host' => $host ); |
229 | |
6dc87a0f |
230 | my $http = Catalyst::Engine::Test::HTTP->new( |
45374ac6 |
231 | address => '127.0.0.1', |
1a80619d |
232 | hostname => 'localhost', |
233 | request => $request, |
234 | response => HTTP::Response->new |
45374ac6 |
235 | ); |
e646f111 |
236 | |
6dc87a0f |
237 | $http->response->date(time); |
b26df351 |
238 | |
6dc87a0f |
239 | $class->handler($http); |
e646f111 |
240 | |
6dc87a0f |
241 | return $http->response; |
e646f111 |
242 | } |
243 | |
244 | =back |
245 | |
246 | =head1 SEE ALSO |
247 | |
248 | L<Catalyst>. |
249 | |
250 | =head1 AUTHOR |
251 | |
252 | Sebastian Riedel, C<sri@cpan.org> |
253 | Christian Hansen, C<ch@ngmedia.com> |
254 | |
255 | =head1 COPYRIGHT |
256 | |
257 | This program is free software, you can redistribute it and/or modify it under |
258 | the same terms as Perl itself. |
259 | |
260 | =cut |
261 | |
262 | 1; |