Commit | Line | Data |
fc7ec1d9 |
1 | package Catalyst::Engine::CGI; |
2 | |
7fa2c9c1 |
3 | use Moose; |
4 | extends 'Catalyst::Engine'; |
e2fd5b5f |
5 | |
02570318 |
6 | has _header_buf => (is => 'rw', clearer => '_clear_header_buf', predicate => '_has_header_buf'); |
84528885 |
7 | |
fc7ec1d9 |
8 | =head1 NAME |
9 | |
10 | Catalyst::Engine::CGI - The CGI Engine |
11 | |
12 | =head1 SYNOPSIS |
13 | |
23f9d934 |
14 | A script using the Catalyst::Engine::CGI module might look like: |
15 | |
9a33da6a |
16 | #!/usr/bin/perl -w |
17 | |
18 | use strict; |
19 | use lib '/path/to/MyApp/lib'; |
20 | use MyApp; |
21 | |
22 | MyApp->run; |
23 | |
23f9d934 |
24 | The application module (C<MyApp>) would use C<Catalyst>, which loads the |
25 | appropriate engine module. |
fc7ec1d9 |
26 | |
27 | =head1 DESCRIPTION |
28 | |
fbcc39ad |
29 | This is the Catalyst engine specialized for the CGI environment. |
e2fd5b5f |
30 | |
a48f9753 |
31 | =head1 PATH DECODING |
32 | |
33 | Most web server environments pass the requested path to the application using environment variables, |
34 | from which Catalyst has to reconstruct the request base (i.e. the top level path to / in the application, |
35 | exposed as C<< $c->request->base >>) and the request path below that base. |
36 | |
37 | There are two methods of doing this, both of which have advantages and disadvantages. Which method is used |
38 | is determined by the C<< $c->config(use_request_uri_for_path) >> setting (which can either be true or false). |
39 | |
40 | =head2 use_request_uri_for_path => 0 |
41 | |
42 | This is the default (and the) traditional method that Catalyst has used for determining the path information. |
43 | The path is synthesised from a combination of the C<PATH_INFO> and C<SCRIPT_NAME> environment variables. |
44 | The allows the application to behave correctly when C<mod_rewrite> is being used to redirect requests |
45 | into the application, as these variables are adjusted by mod_rewrite to take account for the redirect. |
46 | |
47 | However this method has the major disadvantage that it is impossible to correctly decode some elements |
48 | of the path, as RFC 3875 says: "C<< Unlike a URI path, the PATH_INFO is not URL-encoded, and cannot |
49 | contain path-segment parameters. >>" This means PATH_INFO is B<always> decoded, and therefore Catalyst |
ff341e2c |
50 | can't distinguish / vs %2F in paths (in addition to other encoded values). |
a48f9753 |
51 | |
52 | =head2 use_request_uri_for_path => 1 |
53 | |
54 | This method uses the C<REQUEST_URI> and C<SCRIPT_NAME> environment variables. As C<REQUEST_URI> is never |
55 | decoded, this means that applications using this mode can correctly handle URIs including the %2F character |
56 | (i.e. with C<AllowEncodedSlashes> set to C<On> in Apache). |
57 | |
ff341e2c |
58 | Given that this method of path resolution is provably more correct, it is recommended that you use |
59 | this unless you have a specific need to deploy your application in a non-standard environment, and you are |
60 | aware of the implications of not being able to handle encoded URI paths correctly. |
61 | |
a48f9753 |
62 | However it also means that in a number of cases when the app isn't installed directly at a path, but instead |
63 | is having paths rewritten into it (e.g. as a .cgi/fcgi in a public_html directory, with mod_rewrite in a |
64 | .htaccess file, or when SSI is used to rewrite pages into the app, or when sub-paths of the app are exposed |
65 | at other URIs than that which the app is 'normally' based at with C<mod_rewrite>), the resolution of |
66 | C<< $c->request->base >> will be incorrect. |
67 | |
23f9d934 |
68 | =head1 OVERLOADED METHODS |
fc7ec1d9 |
69 | |
fbcc39ad |
70 | This class overloads some methods from C<Catalyst::Engine>. |
fc7ec1d9 |
71 | |
b5ecfcf0 |
72 | =head2 $self->finalize_headers($c) |
fc7ec1d9 |
73 | |
74 | =cut |
75 | |
fbcc39ad |
76 | sub finalize_headers { |
77 | my ( $self, $c ) = @_; |
06e1b616 |
78 | |
fbcc39ad |
79 | $c->response->header( Status => $c->response->status ); |
06e1b616 |
80 | |
02570318 |
81 | $self->_header_buf($c->response->headers->as_string("\015\012") . "\015\012"); |
fc7ec1d9 |
82 | } |
83 | |
b5ecfcf0 |
84 | =head2 $self->prepare_connection($c) |
fc7ec1d9 |
85 | |
86 | =cut |
87 | |
fbcc39ad |
88 | sub prepare_connection { |
89 | my ( $self, $c ) = @_; |
b5ecfcf0 |
90 | local (*ENV) = $self->env || \%ENV; |
4f5ebacd |
91 | |
7fa2c9c1 |
92 | my $request = $c->request; |
93 | $request->address( $ENV{REMOTE_ADDR} ); |
4f5ebacd |
94 | |
95 | PROXY_CHECK: |
fbcc39ad |
96 | { |
df960201 |
97 | unless ( ref($c)->config->{using_frontend_proxy} ) { |
fbcc39ad |
98 | last PROXY_CHECK if $ENV{REMOTE_ADDR} ne '127.0.0.1'; |
df960201 |
99 | last PROXY_CHECK if ref($c)->config->{ignore_frontend_proxy}; |
5b387dfc |
100 | } |
fbcc39ad |
101 | last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_FOR}; |
4f5ebacd |
102 | |
fbcc39ad |
103 | # If we are running as a backend server, the user will always appear |
104 | # as 127.0.0.1. Select the most recent upstream IP (last in the list) |
105 | my ($ip) = $ENV{HTTP_X_FORWARDED_FOR} =~ /([^,\s]+)$/; |
7fa2c9c1 |
106 | $request->address($ip); |
64d1c3cd |
107 | if ( defined $ENV{HTTP_X_FORWARDED_PORT} ) { |
108 | $ENV{SERVER_PORT} = $ENV{HTTP_X_FORWARDED_PORT}; |
109 | } |
fc7ec1d9 |
110 | } |
08cf3dd6 |
111 | |
8fc0d39e |
112 | $request->hostname( $ENV{REMOTE_HOST} ) if exists $ENV{REMOTE_HOST}; |
7fa2c9c1 |
113 | $request->protocol( $ENV{SERVER_PROTOCOL} ); |
8026359e |
114 | $request->user( $ENV{REMOTE_USER} ); # XXX: Deprecated. See Catalyst::Request for removal information |
115 | $request->remote_user( $ENV{REMOTE_USER} ); |
7fa2c9c1 |
116 | $request->method( $ENV{REQUEST_METHOD} ); |
fbcc39ad |
117 | |
118 | if ( $ENV{HTTPS} && uc( $ENV{HTTPS} ) eq 'ON' ) { |
7fa2c9c1 |
119 | $request->secure(1); |
5b387dfc |
120 | } |
bfde09a2 |
121 | |
fbcc39ad |
122 | if ( $ENV{SERVER_PORT} == 443 ) { |
7fa2c9c1 |
123 | $request->secure(1); |
fbcc39ad |
124 | } |
afdffc63 |
125 | binmode(STDOUT); # Ensure we are sending bytes. |
fc7ec1d9 |
126 | } |
127 | |
b5ecfcf0 |
128 | =head2 $self->prepare_headers($c) |
fc7ec1d9 |
129 | |
130 | =cut |
131 | |
fbcc39ad |
132 | sub prepare_headers { |
133 | my ( $self, $c ) = @_; |
b5ecfcf0 |
134 | local (*ENV) = $self->env || \%ENV; |
7fa2c9c1 |
135 | my $headers = $c->request->headers; |
fbcc39ad |
136 | # Read headers from %ENV |
c82ed742 |
137 | foreach my $header ( keys %ENV ) { |
fbcc39ad |
138 | next unless $header =~ /^(?:HTTP|CONTENT|COOKIE)/i; |
139 | ( my $field = $header ) =~ s/^HTTPS?_//; |
7fa2c9c1 |
140 | $headers->header( $field => $ENV{$header} ); |
fbcc39ad |
141 | } |
142 | } |
316bf0f0 |
143 | |
b5ecfcf0 |
144 | =head2 $self->prepare_path($c) |
316bf0f0 |
145 | |
fbcc39ad |
146 | =cut |
316bf0f0 |
147 | |
eb3abf96 |
148 | # Please don't touch this method without adding tests in |
149 | # t/aggregate/unit_core_engine_cgi-prepare_path.t |
fbcc39ad |
150 | sub prepare_path { |
151 | my ( $self, $c ) = @_; |
b5ecfcf0 |
152 | local (*ENV) = $self->env || \%ENV; |
fbcc39ad |
153 | |
4f5ebacd |
154 | my $scheme = $c->request->secure ? 'https' : 'http'; |
294f78ca |
155 | my $host = $ENV{HTTP_HOST} || $ENV{SERVER_NAME}; |
156 | my $port = $ENV{SERVER_PORT} || 80; |
a4900102 |
157 | |
158 | # fix up for IIS |
159 | if ($ENV{SERVER_SOFTWARE} && $ENV{SERVER_SOFTWARE} =~ m{IIS/[6-9]\.\d}) { |
160 | $ENV{PATH_INFO} =~ s/^\Q$ENV{SCRIPT_NAME}\E//; |
161 | } |
162 | |
8bf285ed |
163 | my $script_name = $ENV{SCRIPT_NAME}; |
164 | $script_name =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go if $script_name; |
165 | |
0bcb98c7 |
166 | my $base_path; |
167 | if ( exists $ENV{REDIRECT_URL} ) { |
168 | $base_path = $ENV{REDIRECT_URL}; |
4dfe7bde |
169 | $base_path =~ s/\Q$ENV{PATH_INFO}\E$//; |
0bcb98c7 |
170 | } |
171 | else { |
8bf285ed |
172 | $base_path = $script_name || '/'; |
0bcb98c7 |
173 | } |
4f5ebacd |
174 | |
fbcc39ad |
175 | # If we are running as a backend proxy, get the true hostname |
4f5ebacd |
176 | PROXY_CHECK: |
fbcc39ad |
177 | { |
df960201 |
178 | unless ( ref($c)->config->{using_frontend_proxy} ) { |
fbcc39ad |
179 | last PROXY_CHECK if $host !~ /localhost|127.0.0.1/; |
df960201 |
180 | last PROXY_CHECK if ref($c)->config->{ignore_frontend_proxy}; |
316bf0f0 |
181 | } |
fbcc39ad |
182 | last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_HOST}; |
316bf0f0 |
183 | |
fbcc39ad |
184 | $host = $ENV{HTTP_X_FORWARDED_HOST}; |
4f5ebacd |
185 | |
186 | # backend could be on any port, so |
fbcc39ad |
187 | # assume frontend is on the default port |
188 | $port = $c->request->secure ? 443 : 80; |
64d1c3cd |
189 | if ( $ENV{HTTP_X_FORWARDED_PORT} ) { |
190 | $port = $ENV{HTTP_X_FORWARDED_PORT}; |
191 | } |
316bf0f0 |
192 | } |
193 | |
8bf285ed |
194 | my $path_info = $ENV{PATH_INFO}; |
17affec1 |
195 | if ($c->config->{use_request_uri_for_path}) { |
f238bbd9 |
196 | # RFC 3875: "Unlike a URI path, the PATH_INFO is not URL-encoded, |
197 | # and cannot contain path-segment parameters." This means PATH_INFO |
198 | # is always decoded, and the script can't distinguish / vs %2F. |
199 | # See https://issues.apache.org/bugzilla/show_bug.cgi?id=35256 |
200 | # Here we try to resurrect the original encoded URI from REQUEST_URI. |
081ea922 |
201 | if (my $req_uri = $ENV{REQUEST_URI}) { |
f238bbd9 |
202 | if (defined $script_name) { |
203 | $req_uri =~ s/^\Q$script_name\E//; |
b760ac3d |
204 | } |
f238bbd9 |
205 | $req_uri =~ s/\?.*$//; |
206 | $path_info = $req_uri if $req_uri; |
b760ac3d |
207 | } |
8bf285ed |
208 | } |
209 | |
8d3c800b |
210 | # set the request URI |
8bf285ed |
211 | my $path = $base_path . ( $path_info || '' ); |
fbcc39ad |
212 | $path =~ s{^/+}{}; |
b0ad47c1 |
213 | |
933ba403 |
214 | # Using URI directly is way too slow, so we construct the URLs manually |
215 | my $uri_class = "URI::$scheme"; |
b0ad47c1 |
216 | |
de19de2e |
217 | # HTTP_HOST will include the port even if it's 80/443 |
218 | $host =~ s/:(?:80|443)$//; |
b0ad47c1 |
219 | |
de19de2e |
220 | if ( $port !~ /^(?:80|443)$/ && $host !~ /:/ ) { |
933ba403 |
221 | $host .= ":$port"; |
222 | } |
b0ad47c1 |
223 | |
933ba403 |
224 | # Escape the path |
225 | $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go; |
226 | $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE |
b0ad47c1 |
227 | |
933ba403 |
228 | my $query = $ENV{QUERY_STRING} ? '?' . $ENV{QUERY_STRING} : ''; |
229 | my $uri = $scheme . '://' . $host . '/' . $path . $query; |
230 | |
ca78941c |
231 | $c->request->uri( bless(\$uri, $uri_class)->canonical ); |
933ba403 |
232 | |
8d3c800b |
233 | # set the base URI |
234 | # base must end in a slash |
235 | $base_path .= '/' unless $base_path =~ m{/$}; |
b0ad47c1 |
236 | |
8d3c800b |
237 | my $base_uri = $scheme . '://' . $host . $base_path; |
238 | |
67936fd7 |
239 | $c->request->base( bless \$base_uri, $uri_class ); |
e7c0c583 |
240 | } |
fc7ec1d9 |
241 | |
b5ecfcf0 |
242 | =head2 $self->prepare_query_parameters($c) |
fc7ec1d9 |
243 | |
244 | =cut |
245 | |
4090e3bb |
246 | around prepare_query_parameters => sub { |
247 | my $orig = shift; |
fbcc39ad |
248 | my ( $self, $c ) = @_; |
b5ecfcf0 |
249 | local (*ENV) = $self->env || \%ENV; |
250 | |
f8109766 |
251 | if ( $ENV{QUERY_STRING} ) { |
4090e3bb |
252 | $self->$orig( $c, $ENV{QUERY_STRING} ); |
f8109766 |
253 | } |
4090e3bb |
254 | }; |
e7c0c583 |
255 | |
b5ecfcf0 |
256 | =head2 $self->prepare_request($c, (env => \%env)) |
84528885 |
257 | |
258 | =cut |
259 | |
260 | sub prepare_request { |
261 | my ( $self, $c, %args ) = @_; |
262 | |
263 | if ( $args{env} ) { |
13985c0a |
264 | $self->_set_env( $args{env} ); |
84528885 |
265 | } |
266 | } |
267 | |
b5ecfcf0 |
268 | =head2 $self->prepare_write($c) |
bfde09a2 |
269 | |
fbcc39ad |
270 | Enable autoflush on the output handle for CGI-based engines. |
bfde09a2 |
271 | |
fbcc39ad |
272 | =cut |
e7c0c583 |
273 | |
4090e3bb |
274 | around prepare_write => sub { |
4f5ebacd |
275 | *STDOUT->autoflush(1); |
4090e3bb |
276 | return shift->(@_); |
277 | }; |
e7c0c583 |
278 | |
e512dd24 |
279 | =head2 $self->write($c, $buffer) |
280 | |
281 | Writes the buffer to the client. |
282 | |
283 | =cut |
284 | |
4090e3bb |
285 | around write => sub { |
286 | my $orig = shift; |
e512dd24 |
287 | my ( $self, $c, $buffer ) = @_; |
288 | |
289 | # Prepend the headers if they have not yet been sent |
02570318 |
290 | if ( $self->_has_header_buf ) { |
83fe4706 |
291 | my $headers = $self->_clear_header_buf; |
292 | |
293 | $buffer = defined $buffer |
294 | ? $headers . $buffer : $headers; |
e512dd24 |
295 | } |
7fa2c9c1 |
296 | |
4090e3bb |
297 | return $self->$orig( $c, $buffer ); |
298 | }; |
e512dd24 |
299 | |
b5ecfcf0 |
300 | =head2 $self->read_chunk($c, $buffer, $length) |
e7c0c583 |
301 | |
fbcc39ad |
302 | =cut |
e7c0c583 |
303 | |
4f5ebacd |
304 | sub read_chunk { shift; shift; *STDIN->sysread(@_); } |
e7c0c583 |
305 | |
b5ecfcf0 |
306 | =head2 $self->run |
bfde09a2 |
307 | |
fbcc39ad |
308 | =cut |
bfde09a2 |
309 | |
0c913601 |
310 | sub run { shift; shift->handle_request( env => \%ENV ) } |
fc7ec1d9 |
311 | |
fc7ec1d9 |
312 | =head1 SEE ALSO |
313 | |
2f381252 |
314 | L<Catalyst>, L<Catalyst::Engine> |
fbcc39ad |
315 | |
316 | =head1 AUTHORS |
317 | |
2f381252 |
318 | Catalyst Contributors, see Catalyst.pm |
fc7ec1d9 |
319 | |
320 | =head1 COPYRIGHT |
321 | |
536bee89 |
322 | This library is free software. You can redistribute it and/or modify it under |
fc7ec1d9 |
323 | the same terms as Perl itself. |
324 | |
325 | =cut |
4090e3bb |
326 | no Moose; |
fc7ec1d9 |
327 | |
328 | 1; |