Commit | Line | Data |
3fea05b9 |
1 | package Catalyst::Engine::CGI; |
2 | |
3 | use Moose; |
4 | extends 'Catalyst::Engine'; |
5 | |
6 | has _header_buf => (is => 'rw', clearer => '_clear_header_buf', predicate => '_has_header_buf'); |
7 | |
8 | =head1 NAME |
9 | |
10 | Catalyst::Engine::CGI - The CGI Engine |
11 | |
12 | =head1 SYNOPSIS |
13 | |
14 | A script using the Catalyst::Engine::CGI module might look like: |
15 | |
16 | #!/usr/bin/perl -w |
17 | |
18 | use strict; |
19 | use lib '/path/to/MyApp/lib'; |
20 | use MyApp; |
21 | |
22 | MyApp->run; |
23 | |
24 | The application module (C<MyApp>) would use C<Catalyst>, which loads the |
25 | appropriate engine module. |
26 | |
27 | =head1 DESCRIPTION |
28 | |
29 | This is the Catalyst engine specialized for the CGI environment. |
30 | |
31 | =head1 OVERLOADED METHODS |
32 | |
33 | This class overloads some methods from C<Catalyst::Engine>. |
34 | |
35 | =head2 $self->finalize_headers($c) |
36 | |
37 | =cut |
38 | |
39 | sub finalize_headers { |
40 | my ( $self, $c ) = @_; |
41 | |
42 | $c->response->header( Status => $c->response->status ); |
43 | |
44 | $self->_header_buf($c->response->headers->as_string("\015\012") . "\015\012"); |
45 | } |
46 | |
47 | =head2 $self->prepare_connection($c) |
48 | |
49 | =cut |
50 | |
51 | sub prepare_connection { |
52 | my ( $self, $c ) = @_; |
53 | local (*ENV) = $self->env || \%ENV; |
54 | |
55 | my $request = $c->request; |
56 | $request->address( $ENV{REMOTE_ADDR} ); |
57 | |
58 | PROXY_CHECK: |
59 | { |
60 | unless ( ref($c)->config->{using_frontend_proxy} ) { |
61 | last PROXY_CHECK if $ENV{REMOTE_ADDR} ne '127.0.0.1'; |
62 | last PROXY_CHECK if ref($c)->config->{ignore_frontend_proxy}; |
63 | } |
64 | last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_FOR}; |
65 | |
66 | # If we are running as a backend server, the user will always appear |
67 | # as 127.0.0.1. Select the most recent upstream IP (last in the list) |
68 | my ($ip) = $ENV{HTTP_X_FORWARDED_FOR} =~ /([^,\s]+)$/; |
69 | $request->address($ip); |
70 | if ( defined $ENV{HTTP_X_FORWARDED_PORT} ) { |
71 | $ENV{SERVER_PORT} = $ENV{HTTP_X_FORWARDED_PORT}; |
72 | } |
73 | } |
74 | |
75 | $request->hostname( $ENV{REMOTE_HOST} ) if exists $ENV{REMOTE_HOST}; |
76 | $request->protocol( $ENV{SERVER_PROTOCOL} ); |
77 | $request->user( $ENV{REMOTE_USER} ); # XXX: Deprecated. See Catalyst::Request for removal information |
78 | $request->remote_user( $ENV{REMOTE_USER} ); |
79 | $request->method( $ENV{REQUEST_METHOD} ); |
80 | |
81 | if ( $ENV{HTTPS} && uc( $ENV{HTTPS} ) eq 'ON' ) { |
82 | $request->secure(1); |
83 | } |
84 | |
85 | if ( $ENV{SERVER_PORT} == 443 ) { |
86 | $request->secure(1); |
87 | } |
88 | binmode(STDOUT); # Ensure we are sending bytes. |
89 | } |
90 | |
91 | =head2 $self->prepare_headers($c) |
92 | |
93 | =cut |
94 | |
95 | sub prepare_headers { |
96 | my ( $self, $c ) = @_; |
97 | local (*ENV) = $self->env || \%ENV; |
98 | my $headers = $c->request->headers; |
99 | # Read headers from %ENV |
100 | foreach my $header ( keys %ENV ) { |
101 | next unless $header =~ /^(?:HTTP|CONTENT|COOKIE)/i; |
102 | ( my $field = $header ) =~ s/^HTTPS?_//; |
103 | $headers->header( $field => $ENV{$header} ); |
104 | } |
105 | } |
106 | |
107 | =head2 $self->prepare_path($c) |
108 | |
109 | =cut |
110 | |
111 | sub prepare_path { |
112 | my ( $self, $c ) = @_; |
113 | local (*ENV) = $self->env || \%ENV; |
114 | |
115 | my $scheme = $c->request->secure ? 'https' : 'http'; |
116 | my $host = $ENV{HTTP_HOST} || $ENV{SERVER_NAME}; |
117 | my $port = $ENV{SERVER_PORT} || 80; |
118 | my $script_name = $ENV{SCRIPT_NAME}; |
119 | $script_name =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go if $script_name; |
120 | |
121 | my $base_path; |
122 | if ( exists $ENV{REDIRECT_URL} ) { |
123 | $base_path = $ENV{REDIRECT_URL}; |
124 | $base_path =~ s/$ENV{PATH_INFO}$//; |
125 | } |
126 | else { |
127 | $base_path = $script_name || '/'; |
128 | } |
129 | |
130 | # If we are running as a backend proxy, get the true hostname |
131 | PROXY_CHECK: |
132 | { |
133 | unless ( ref($c)->config->{using_frontend_proxy} ) { |
134 | last PROXY_CHECK if $host !~ /localhost|127.0.0.1/; |
135 | last PROXY_CHECK if ref($c)->config->{ignore_frontend_proxy}; |
136 | } |
137 | last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_HOST}; |
138 | |
139 | $host = $ENV{HTTP_X_FORWARDED_HOST}; |
140 | |
141 | # backend could be on any port, so |
142 | # assume frontend is on the default port |
143 | $port = $c->request->secure ? 443 : 80; |
144 | if ( $ENV{HTTP_X_FORWARDED_PORT} ) { |
145 | $port = $ENV{HTTP_X_FORWARDED_PORT}; |
146 | } |
147 | } |
148 | |
149 | # RFC 3875: "Unlike a URI path, the PATH_INFO is not URL-encoded, |
150 | # and cannot contain path-segment parameters." This means PATH_INFO |
151 | # is always decoded, and the script can't distinguish / vs %2F. |
152 | # See https://issues.apache.org/bugzilla/show_bug.cgi?id=35256 |
153 | # Here we try to resurrect the original encoded URI from REQUEST_URI. |
154 | my $path_info = $ENV{PATH_INFO}; |
155 | if (my $req_uri = $ENV{REQUEST_URI}) { |
156 | if (defined $script_name) { |
157 | $req_uri =~ s/^\Q$script_name\E//; |
158 | } |
159 | $req_uri =~ s/\?.*$//; |
160 | $path_info = $req_uri if $req_uri; |
161 | } |
162 | |
163 | # set the request URI |
164 | my $path = $base_path . ( $path_info || '' ); |
165 | $path =~ s{^/+}{}; |
166 | |
167 | # Using URI directly is way too slow, so we construct the URLs manually |
168 | my $uri_class = "URI::$scheme"; |
169 | |
170 | # HTTP_HOST will include the port even if it's 80/443 |
171 | $host =~ s/:(?:80|443)$//; |
172 | |
173 | if ( $port !~ /^(?:80|443)$/ && $host !~ /:/ ) { |
174 | $host .= ":$port"; |
175 | } |
176 | |
177 | # Escape the path |
178 | $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go; |
179 | $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE |
180 | |
181 | my $query = $ENV{QUERY_STRING} ? '?' . $ENV{QUERY_STRING} : ''; |
182 | my $uri = $scheme . '://' . $host . '/' . $path . $query; |
183 | |
184 | $c->request->uri( bless \$uri, $uri_class ); |
185 | |
186 | # set the base URI |
187 | # base must end in a slash |
188 | $base_path .= '/' unless $base_path =~ m{/$}; |
189 | |
190 | my $base_uri = $scheme . '://' . $host . $base_path; |
191 | |
192 | $c->request->base( bless \$base_uri, $uri_class ); |
193 | } |
194 | |
195 | =head2 $self->prepare_query_parameters($c) |
196 | |
197 | =cut |
198 | |
199 | around prepare_query_parameters => sub { |
200 | my $orig = shift; |
201 | my ( $self, $c ) = @_; |
202 | local (*ENV) = $self->env || \%ENV; |
203 | |
204 | if ( $ENV{QUERY_STRING} ) { |
205 | $self->$orig( $c, $ENV{QUERY_STRING} ); |
206 | } |
207 | }; |
208 | |
209 | =head2 $self->prepare_request($c, (env => \%env)) |
210 | |
211 | =cut |
212 | |
213 | sub prepare_request { |
214 | my ( $self, $c, %args ) = @_; |
215 | |
216 | if ( $args{env} ) { |
217 | $self->env( $args{env} ); |
218 | } |
219 | } |
220 | |
221 | =head2 $self->prepare_write($c) |
222 | |
223 | Enable autoflush on the output handle for CGI-based engines. |
224 | |
225 | =cut |
226 | |
227 | around prepare_write => sub { |
228 | *STDOUT->autoflush(1); |
229 | return shift->(@_); |
230 | }; |
231 | |
232 | =head2 $self->write($c, $buffer) |
233 | |
234 | Writes the buffer to the client. |
235 | |
236 | =cut |
237 | |
238 | around write => sub { |
239 | my $orig = shift; |
240 | my ( $self, $c, $buffer ) = @_; |
241 | |
242 | # Prepend the headers if they have not yet been sent |
243 | if ( $self->_has_header_buf ) { |
244 | $buffer = $self->_clear_header_buf . $buffer; |
245 | } |
246 | |
247 | return $self->$orig( $c, $buffer ); |
248 | }; |
249 | |
250 | =head2 $self->read_chunk($c, $buffer, $length) |
251 | |
252 | =cut |
253 | |
254 | sub read_chunk { shift; shift; *STDIN->sysread(@_); } |
255 | |
256 | =head2 $self->run |
257 | |
258 | =cut |
259 | |
260 | sub run { shift; shift->handle_request( env => \%ENV ) } |
261 | |
262 | =head1 SEE ALSO |
263 | |
264 | L<Catalyst>, L<Catalyst::Engine> |
265 | |
266 | =head1 AUTHORS |
267 | |
268 | Catalyst Contributors, see Catalyst.pm |
269 | |
270 | =head1 COPYRIGHT |
271 | |
272 | This library is free software. You can redistribute it and/or modify it under |
273 | the same terms as Perl itself. |
274 | |
275 | =cut |
276 | no Moose; |
277 | |
278 | 1; |