Commit | Line | Data |
fc7ec1d9 |
1 | package Catalyst::Engine::CGI; |
2 | |
3 | use strict; |
4 | use base 'Catalyst::Engine'; |
e7c0c583 |
5 | |
6 | use CGI; |
fc7ec1d9 |
7 | use URI; |
399ed680 |
8 | use URI::http; |
fc7ec1d9 |
9 | |
fc7ec1d9 |
10 | __PACKAGE__->mk_accessors('cgi'); |
11 | |
12 | =head1 NAME |
13 | |
14 | Catalyst::Engine::CGI - The CGI Engine |
15 | |
16 | =head1 SYNOPSIS |
17 | |
23f9d934 |
18 | A script using the Catalyst::Engine::CGI module might look like: |
19 | |
9a33da6a |
20 | #!/usr/bin/perl -w |
21 | |
22 | use strict; |
23 | use lib '/path/to/MyApp/lib'; |
24 | use MyApp; |
25 | |
26 | MyApp->run; |
27 | |
23f9d934 |
28 | The application module (C<MyApp>) would use C<Catalyst>, which loads the |
29 | appropriate engine module. |
fc7ec1d9 |
30 | |
31 | =head1 DESCRIPTION |
32 | |
23f9d934 |
33 | This is the Catalyst engine specialized for the CGI environment (using the |
e7c0c583 |
34 | C<CGI> and C<CGI::Cookie> modules). Normally Catalyst will select the |
23f9d934 |
35 | appropriate engine according to the environment that it detects, however you |
36 | can force Catalyst to use the CGI engine by specifying the following in your |
37 | application module: |
38 | |
39 | use Catalyst qw(-Engine=CGI); |
fc7ec1d9 |
40 | |
9a33da6a |
41 | The performance of this way of using Catalyst is not expected to be |
42 | useful in production applications, but it may be helpful for development. |
43 | |
23f9d934 |
44 | =head1 METHODS |
fc7ec1d9 |
45 | |
23f9d934 |
46 | =over 4 |
47 | |
23f9d934 |
48 | =item $c->cgi |
fc7ec1d9 |
49 | |
e7c0c583 |
50 | This config parameter contains the C<CGI> object. |
fc7ec1d9 |
51 | |
23f9d934 |
52 | =back |
53 | |
54 | =head1 OVERLOADED METHODS |
fc7ec1d9 |
55 | |
45374ac6 |
56 | This class overloads some methods from C<Catalyst::Engine>. |
fc7ec1d9 |
57 | |
23f9d934 |
58 | =over 4 |
59 | |
06e1b616 |
60 | =item $c->finalize_body |
61 | |
62 | Prints the response output to STDOUT. |
63 | |
64 | =cut |
65 | |
66 | sub finalize_body { |
67 | my $c = shift; |
68 | print $c->response->output; |
69 | } |
70 | |
23f9d934 |
71 | =item $c->finalize_headers |
fc7ec1d9 |
72 | |
73 | =cut |
74 | |
75 | sub finalize_headers { |
76 | my $c = shift; |
6dc87a0f |
77 | |
e7c0c583 |
78 | $c->response->header( Status => $c->response->status ); |
6dc87a0f |
79 | |
e7c0c583 |
80 | print $c->response->headers->as_string("\015\012"); |
81 | print "\015\012"; |
fc7ec1d9 |
82 | } |
83 | |
06e1b616 |
84 | =item $c->prepare_body |
fc7ec1d9 |
85 | |
86 | =cut |
87 | |
06e1b616 |
88 | sub prepare_body { |
fc7ec1d9 |
89 | my $c = shift; |
06e1b616 |
90 | |
91 | # XXX this is undocumented in CGI.pm. If Content-Type is not |
92 | # application/x-www-form-urlencoded or multipart/form-data |
93 | # CGI.pm will read STDIN into a param, POSTDATA. |
94 | |
e060fe05 |
95 | $c->request->body( $c->cgi->param('POSTDATA') ); |
fc7ec1d9 |
96 | } |
97 | |
0556eb49 |
98 | =item $c->prepare_connection |
99 | |
100 | =cut |
101 | |
102 | sub prepare_connection { |
103 | my $c = shift; |
bfde09a2 |
104 | $c->request->address( $ENV{REMOTE_ADDR} ); |
105 | $c->request->hostname( $ENV{REMOTE_HOST} ); |
106 | $c->request->protocol( $ENV{SERVER_PROTOCOL} ); |
107 | |
108 | if ( $ENV{HTTPS} || $ENV{SERVER_PORT} == 443 ) { |
109 | $c->request->secure(1); |
110 | } |
0556eb49 |
111 | } |
112 | |
23f9d934 |
113 | =item $c->prepare_headers |
fc7ec1d9 |
114 | |
115 | =cut |
116 | |
117 | sub prepare_headers { |
118 | my $c = shift; |
e7c0c583 |
119 | |
120 | while ( my ( $header, $value ) = each %ENV ) { |
121 | |
122 | next unless $header =~ /^(HTTP|CONTENT)/i; |
123 | |
fc7ec1d9 |
124 | ( my $field = $header ) =~ s/^HTTPS?_//; |
e7c0c583 |
125 | |
126 | $c->req->headers->header( $field => $value ); |
fc7ec1d9 |
127 | } |
e7c0c583 |
128 | |
129 | $c->req->method( $ENV{REQUEST_METHOD} || 'GET' ); |
fc7ec1d9 |
130 | } |
131 | |
23f9d934 |
132 | =item $c->prepare_parameters |
fc7ec1d9 |
133 | |
134 | =cut |
135 | |
136 | sub prepare_parameters { |
e7c0c583 |
137 | my $c = shift; |
bfde09a2 |
138 | |
5b387dfc |
139 | my ( @params ); |
bfde09a2 |
140 | |
b9e9fff6 |
141 | if ( $c->request->method eq 'POST' ) { |
b9e9fff6 |
142 | for my $param ( $c->cgi->url_param ) { |
143 | for my $value ( $c->cgi->url_param($param) ) { |
144 | push ( @params, $param, $value ); |
145 | } |
5b387dfc |
146 | } |
fc7ec1d9 |
147 | } |
08cf3dd6 |
148 | |
bfde09a2 |
149 | for my $param ( $c->cgi->param ) { |
08cf3dd6 |
150 | for my $value ( $c->cgi->param($param) ) { |
5b387dfc |
151 | push ( @params, $param, $value ); |
152 | } |
153 | } |
bfde09a2 |
154 | |
155 | $c->request->param(@params); |
fc7ec1d9 |
156 | } |
157 | |
23f9d934 |
158 | =item $c->prepare_path |
fc7ec1d9 |
159 | |
160 | =cut |
161 | |
162 | sub prepare_path { |
163 | my $c = shift; |
8b4483b3 |
164 | |
165 | my $base; |
166 | { |
bfde09a2 |
167 | my $scheme = $c->request->secure ? 'https' : 'http'; |
e7c0c583 |
168 | my $host = $ENV{HTTP_HOST} || $ENV{SERVER_NAME}; |
8b4483b3 |
169 | my $port = $ENV{SERVER_PORT} || 80; |
170 | my $path = $ENV{SCRIPT_NAME} || '/'; |
171 | |
dbf68ff4 |
172 | unless ( $path =~ /\/$/ ) { |
173 | $path .= '/'; |
174 | } |
175 | |
8b4483b3 |
176 | $base = URI->new; |
177 | $base->scheme($scheme); |
178 | $base->host($host); |
179 | $base->port($port); |
180 | $base->path($path); |
181 | |
182 | $base = $base->canonical->as_string; |
7833fdfc |
183 | } |
8b4483b3 |
184 | |
185 | my $path = $ENV{PATH_INFO} || '/'; |
6dc87a0f |
186 | $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; |
e7c0c583 |
187 | $path =~ s/^\///; |
8b4483b3 |
188 | |
189 | $c->req->base($base); |
190 | $c->req->path($path); |
fc7ec1d9 |
191 | } |
192 | |
23f9d934 |
193 | =item $c->prepare_request |
fc7ec1d9 |
194 | |
195 | =cut |
196 | |
bfde09a2 |
197 | sub prepare_request { |
3f822a28 |
198 | my ( $c, $cgi ) = @_; |
199 | $c->cgi( $cgi || CGI->new ); |
e7c0c583 |
200 | $c->cgi->_reset_globals; |
201 | } |
fc7ec1d9 |
202 | |
23f9d934 |
203 | =item $c->prepare_uploads |
fc7ec1d9 |
204 | |
205 | =cut |
206 | |
207 | sub prepare_uploads { |
208 | my $c = shift; |
e7c0c583 |
209 | |
210 | my @uploads; |
bfde09a2 |
211 | |
e7c0c583 |
212 | for my $param ( $c->cgi->param ) { |
bfde09a2 |
213 | |
e7c0c583 |
214 | my @values = $c->cgi->param($param); |
215 | |
216 | next unless ref( $values[0] ); |
217 | |
218 | for my $fh (@values) { |
219 | |
220 | next unless my $size = ( stat $fh )[7]; |
221 | |
222 | my $info = $c->cgi->uploadInfo($fh); |
223 | my $tempname = $c->cgi->tmpFileName($fh); |
224 | my $type = $info->{'Content-Type'}; |
225 | my $disposition = $info->{'Content-Disposition'}; |
226 | my $filename = ( $disposition =~ / filename="([^;]*)"/ )[0]; |
227 | |
146554c5 |
228 | my $upload = Catalyst::Request::Upload->new( |
e7c0c583 |
229 | filename => $filename, |
230 | size => $size, |
231 | tempname => $tempname, |
232 | type => $type |
146554c5 |
233 | ); |
bfde09a2 |
234 | |
e7c0c583 |
235 | push( @uploads, $param, $upload ); |
236 | } |
fc7ec1d9 |
237 | } |
bfde09a2 |
238 | |
239 | $c->request->upload(@uploads); |
fc7ec1d9 |
240 | } |
241 | |
c9afa5fc |
242 | =item $c->run |
243 | |
244 | =cut |
245 | |
fc7ec1d9 |
246 | sub run { shift->handler } |
247 | |
23f9d934 |
248 | =back |
249 | |
fc7ec1d9 |
250 | =head1 SEE ALSO |
251 | |
252 | L<Catalyst>. |
253 | |
254 | =head1 AUTHOR |
255 | |
256 | Sebastian Riedel, C<sri@cpan.org> |
257 | |
258 | =head1 COPYRIGHT |
259 | |
260 | This program is free software, you can redistribute it and/or modify it under |
261 | the same terms as Perl itself. |
262 | |
263 | =cut |
264 | |
265 | 1; |