Commit | Line | Data |
fc7ec1d9 |
1 | package Catalyst::Engine::CGI; |
2 | |
6f1f968a |
3 | use MRO::Compat; |
4 | use mro 'c3'; |
7fa2c9c1 |
5 | use Moose; |
6 | extends 'Catalyst::Engine'; |
e2fd5b5f |
7 | |
7fa2c9c1 |
8 | has env => (is => 'rw'); |
84528885 |
9 | |
0fc2d522 |
10 | no Moose; |
11 | |
fc7ec1d9 |
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 | |
fbcc39ad |
33 | This is the Catalyst engine specialized for the CGI environment. |
e2fd5b5f |
34 | |
23f9d934 |
35 | =head1 OVERLOADED METHODS |
fc7ec1d9 |
36 | |
fbcc39ad |
37 | This class overloads some methods from C<Catalyst::Engine>. |
fc7ec1d9 |
38 | |
b5ecfcf0 |
39 | =head2 $self->finalize_headers($c) |
fc7ec1d9 |
40 | |
41 | =cut |
42 | |
fbcc39ad |
43 | sub finalize_headers { |
44 | my ( $self, $c ) = @_; |
06e1b616 |
45 | |
fbcc39ad |
46 | $c->response->header( Status => $c->response->status ); |
06e1b616 |
47 | |
ac5c933b |
48 | $self->{_header_buf} |
e512dd24 |
49 | = $c->response->headers->as_string("\015\012") . "\015\012"; |
fc7ec1d9 |
50 | } |
51 | |
b5ecfcf0 |
52 | =head2 $self->prepare_connection($c) |
fc7ec1d9 |
53 | |
54 | =cut |
55 | |
fbcc39ad |
56 | sub prepare_connection { |
57 | my ( $self, $c ) = @_; |
b5ecfcf0 |
58 | local (*ENV) = $self->env || \%ENV; |
4f5ebacd |
59 | |
7fa2c9c1 |
60 | my $request = $c->request; |
61 | $request->address( $ENV{REMOTE_ADDR} ); |
4f5ebacd |
62 | |
63 | PROXY_CHECK: |
fbcc39ad |
64 | { |
65 | unless ( $c->config->{using_frontend_proxy} ) { |
66 | last PROXY_CHECK if $ENV{REMOTE_ADDR} ne '127.0.0.1'; |
67 | last PROXY_CHECK if $c->config->{ignore_frontend_proxy}; |
5b387dfc |
68 | } |
fbcc39ad |
69 | last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_FOR}; |
4f5ebacd |
70 | |
fbcc39ad |
71 | # If we are running as a backend server, the user will always appear |
72 | # as 127.0.0.1. Select the most recent upstream IP (last in the list) |
73 | my ($ip) = $ENV{HTTP_X_FORWARDED_FOR} =~ /([^,\s]+)$/; |
7fa2c9c1 |
74 | $request->address($ip); |
fc7ec1d9 |
75 | } |
08cf3dd6 |
76 | |
7fa2c9c1 |
77 | $request->hostname( $ENV{REMOTE_HOST} ); |
78 | $request->protocol( $ENV{SERVER_PROTOCOL} ); |
79 | $request->user( $ENV{REMOTE_USER} ); |
80 | $request->method( $ENV{REQUEST_METHOD} ); |
fbcc39ad |
81 | |
82 | if ( $ENV{HTTPS} && uc( $ENV{HTTPS} ) eq 'ON' ) { |
7fa2c9c1 |
83 | $request->secure(1); |
5b387dfc |
84 | } |
bfde09a2 |
85 | |
fbcc39ad |
86 | if ( $ENV{SERVER_PORT} == 443 ) { |
7fa2c9c1 |
87 | $request->secure(1); |
fbcc39ad |
88 | } |
fc7ec1d9 |
89 | } |
90 | |
b5ecfcf0 |
91 | =head2 $self->prepare_headers($c) |
fc7ec1d9 |
92 | |
93 | =cut |
94 | |
fbcc39ad |
95 | sub prepare_headers { |
96 | my ( $self, $c ) = @_; |
b5ecfcf0 |
97 | local (*ENV) = $self->env || \%ENV; |
7fa2c9c1 |
98 | my $headers = $c->request->headers; |
fbcc39ad |
99 | # Read headers from %ENV |
c82ed742 |
100 | foreach my $header ( keys %ENV ) { |
fbcc39ad |
101 | next unless $header =~ /^(?:HTTP|CONTENT|COOKIE)/i; |
102 | ( my $field = $header ) =~ s/^HTTPS?_//; |
7fa2c9c1 |
103 | $headers->header( $field => $ENV{$header} ); |
fbcc39ad |
104 | } |
105 | } |
316bf0f0 |
106 | |
b5ecfcf0 |
107 | =head2 $self->prepare_path($c) |
316bf0f0 |
108 | |
fbcc39ad |
109 | =cut |
316bf0f0 |
110 | |
fbcc39ad |
111 | sub prepare_path { |
112 | my ( $self, $c ) = @_; |
b5ecfcf0 |
113 | local (*ENV) = $self->env || \%ENV; |
fbcc39ad |
114 | |
4f5ebacd |
115 | my $scheme = $c->request->secure ? 'https' : 'http'; |
294f78ca |
116 | my $host = $ENV{HTTP_HOST} || $ENV{SERVER_NAME}; |
117 | my $port = $ENV{SERVER_PORT} || 80; |
0bcb98c7 |
118 | my $base_path; |
119 | if ( exists $ENV{REDIRECT_URL} ) { |
120 | $base_path = $ENV{REDIRECT_URL}; |
121 | $base_path =~ s/$ENV{PATH_INFO}$//; |
122 | } |
123 | else { |
124 | $base_path = $ENV{SCRIPT_NAME} || '/'; |
125 | } |
4f5ebacd |
126 | |
fbcc39ad |
127 | # If we are running as a backend proxy, get the true hostname |
4f5ebacd |
128 | PROXY_CHECK: |
fbcc39ad |
129 | { |
130 | unless ( $c->config->{using_frontend_proxy} ) { |
131 | last PROXY_CHECK if $host !~ /localhost|127.0.0.1/; |
132 | last PROXY_CHECK if $c->config->{ignore_frontend_proxy}; |
316bf0f0 |
133 | } |
fbcc39ad |
134 | last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_HOST}; |
316bf0f0 |
135 | |
fbcc39ad |
136 | $host = $ENV{HTTP_X_FORWARDED_HOST}; |
4f5ebacd |
137 | |
138 | # backend could be on any port, so |
fbcc39ad |
139 | # assume frontend is on the default port |
140 | $port = $c->request->secure ? 443 : 80; |
316bf0f0 |
141 | } |
142 | |
8d3c800b |
143 | # set the request URI |
e701c5c6 |
144 | my $path = $base_path . ( $ENV{PATH_INFO} || '' ); |
fbcc39ad |
145 | $path =~ s{^/+}{}; |
ac5c933b |
146 | |
933ba403 |
147 | # Using URI directly is way too slow, so we construct the URLs manually |
148 | my $uri_class = "URI::$scheme"; |
ac5c933b |
149 | |
de19de2e |
150 | # HTTP_HOST will include the port even if it's 80/443 |
151 | $host =~ s/:(?:80|443)$//; |
ac5c933b |
152 | |
de19de2e |
153 | if ( $port !~ /^(?:80|443)$/ && $host !~ /:/ ) { |
933ba403 |
154 | $host .= ":$port"; |
155 | } |
ac5c933b |
156 | |
933ba403 |
157 | # Escape the path |
158 | $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go; |
159 | $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE |
ac5c933b |
160 | |
933ba403 |
161 | my $query = $ENV{QUERY_STRING} ? '?' . $ENV{QUERY_STRING} : ''; |
162 | my $uri = $scheme . '://' . $host . '/' . $path . $query; |
163 | |
164 | $c->request->uri( bless \$uri, $uri_class ); |
165 | |
8d3c800b |
166 | # set the base URI |
167 | # base must end in a slash |
168 | $base_path .= '/' unless $base_path =~ m{/$}; |
ac5c933b |
169 | |
8d3c800b |
170 | my $base_uri = $scheme . '://' . $host . $base_path; |
171 | |
172 | $c->request->base( bless \$base_uri, $uri_class ); |
e7c0c583 |
173 | } |
fc7ec1d9 |
174 | |
b5ecfcf0 |
175 | =head2 $self->prepare_query_parameters($c) |
fc7ec1d9 |
176 | |
177 | =cut |
178 | |
0fc2d522 |
179 | sub prepare_query_parameters { |
fbcc39ad |
180 | my ( $self, $c ) = @_; |
b5ecfcf0 |
181 | local (*ENV) = $self->env || \%ENV; |
182 | |
f8109766 |
183 | if ( $ENV{QUERY_STRING} ) { |
0fc2d522 |
184 | $self->next::method( $c, $ENV{QUERY_STRING} ); |
f8109766 |
185 | } |
0fc2d522 |
186 | } |
e7c0c583 |
187 | |
b5ecfcf0 |
188 | =head2 $self->prepare_request($c, (env => \%env)) |
84528885 |
189 | |
190 | =cut |
191 | |
192 | sub prepare_request { |
193 | my ( $self, $c, %args ) = @_; |
194 | |
195 | if ( $args{env} ) { |
b5ecfcf0 |
196 | $self->env( $args{env} ); |
84528885 |
197 | } |
198 | } |
199 | |
b5ecfcf0 |
200 | =head2 $self->prepare_write($c) |
bfde09a2 |
201 | |
fbcc39ad |
202 | Enable autoflush on the output handle for CGI-based engines. |
bfde09a2 |
203 | |
fbcc39ad |
204 | =cut |
e7c0c583 |
205 | |
0fc2d522 |
206 | sub prepare_write { |
4f5ebacd |
207 | *STDOUT->autoflush(1); |
0fc2d522 |
208 | return shift->next::method(@_); |
209 | } |
e7c0c583 |
210 | |
e512dd24 |
211 | =head2 $self->write($c, $buffer) |
212 | |
213 | Writes the buffer to the client. |
214 | |
215 | =cut |
216 | |
0fc2d522 |
217 | sub write { |
e512dd24 |
218 | my ( $self, $c, $buffer ) = @_; |
219 | |
220 | # Prepend the headers if they have not yet been sent |
221 | if ( my $headers = delete $self->{_header_buf} ) { |
222 | $buffer = $headers . $buffer; |
223 | } |
7fa2c9c1 |
224 | |
0fc2d522 |
225 | return $self->next::method( $c, $buffer ); |
226 | } |
e512dd24 |
227 | |
b5ecfcf0 |
228 | =head2 $self->read_chunk($c, $buffer, $length) |
e7c0c583 |
229 | |
fbcc39ad |
230 | =cut |
e7c0c583 |
231 | |
4f5ebacd |
232 | sub read_chunk { shift; shift; *STDIN->sysread(@_); } |
e7c0c583 |
233 | |
b5ecfcf0 |
234 | =head2 $self->run |
bfde09a2 |
235 | |
fbcc39ad |
236 | =cut |
bfde09a2 |
237 | |
fbcc39ad |
238 | sub run { shift; shift->handle_request(@_) } |
fc7ec1d9 |
239 | |
fc7ec1d9 |
240 | =head1 SEE ALSO |
241 | |
fbcc39ad |
242 | L<Catalyst> L<Catalyst::Engine>. |
243 | |
244 | =head1 AUTHORS |
245 | |
246 | Sebastian Riedel, <sri@cpan.org> |
fc7ec1d9 |
247 | |
fbcc39ad |
248 | Christian Hansen, <ch@ngmedia.com> |
fc7ec1d9 |
249 | |
fbcc39ad |
250 | Andy Grundman, <andy@hybridized.org> |
fc7ec1d9 |
251 | |
252 | =head1 COPYRIGHT |
253 | |
254 | This program is free software, you can redistribute it and/or modify it under |
255 | the same terms as Perl itself. |
256 | |
257 | =cut |
258 | |
259 | 1; |