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