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