Commit | Line | Data |
fc7ec1d9 |
1 | package Catalyst::Engine::CGI; |
2 | |
3 | use strict; |
fbcc39ad |
4 | use base 'Catalyst::Engine'; |
5 | use NEXT; |
6 | use URI; |
e2fd5b5f |
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 | |
23f9d934 |
31 | =head1 OVERLOADED METHODS |
fc7ec1d9 |
32 | |
fbcc39ad |
33 | This class overloads some methods from C<Catalyst::Engine>. |
fc7ec1d9 |
34 | |
23f9d934 |
35 | =over 4 |
36 | |
fbcc39ad |
37 | =item $self->finalize_headers($c) |
fc7ec1d9 |
38 | |
39 | =cut |
40 | |
fbcc39ad |
41 | sub finalize_headers { |
42 | my ( $self, $c ) = @_; |
06e1b616 |
43 | |
fbcc39ad |
44 | $c->response->header( Status => $c->response->status ); |
06e1b616 |
45 | |
fbcc39ad |
46 | print $c->response->headers->as_string("\015\012"); |
47 | print "\015\012"; |
fc7ec1d9 |
48 | } |
49 | |
fbcc39ad |
50 | =item $self->prepare_connection($c) |
fc7ec1d9 |
51 | |
52 | =cut |
53 | |
fbcc39ad |
54 | sub prepare_connection { |
55 | my ( $self, $c ) = @_; |
4f5ebacd |
56 | |
fbcc39ad |
57 | $c->request->address( $ENV{REMOTE_ADDR} ); |
4f5ebacd |
58 | |
59 | PROXY_CHECK: |
fbcc39ad |
60 | { |
61 | unless ( $c->config->{using_frontend_proxy} ) { |
62 | last PROXY_CHECK if $ENV{REMOTE_ADDR} ne '127.0.0.1'; |
63 | last PROXY_CHECK if $c->config->{ignore_frontend_proxy}; |
5b387dfc |
64 | } |
fbcc39ad |
65 | last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_FOR}; |
4f5ebacd |
66 | |
fbcc39ad |
67 | # If we are running as a backend server, the user will always appear |
68 | # as 127.0.0.1. Select the most recent upstream IP (last in the list) |
69 | my ($ip) = $ENV{HTTP_X_FORWARDED_FOR} =~ /([^,\s]+)$/; |
4f5ebacd |
70 | $c->request->address($ip); |
fc7ec1d9 |
71 | } |
08cf3dd6 |
72 | |
fbcc39ad |
73 | $c->request->hostname( $ENV{REMOTE_HOST} ); |
74 | $c->request->protocol( $ENV{SERVER_PROTOCOL} ); |
75 | $c->request->user( $ENV{REMOTE_USER} ); |
76 | $c->request->method( $ENV{REQUEST_METHOD} ); |
77 | |
78 | if ( $ENV{HTTPS} && uc( $ENV{HTTPS} ) eq 'ON' ) { |
79 | $c->request->secure(1); |
5b387dfc |
80 | } |
bfde09a2 |
81 | |
fbcc39ad |
82 | if ( $ENV{SERVER_PORT} == 443 ) { |
83 | $c->request->secure(1); |
84 | } |
fc7ec1d9 |
85 | } |
86 | |
fbcc39ad |
87 | =item $self->prepare_headers($c) |
fc7ec1d9 |
88 | |
89 | =cut |
90 | |
fbcc39ad |
91 | sub prepare_headers { |
92 | my ( $self, $c ) = @_; |
316bf0f0 |
93 | |
fbcc39ad |
94 | # Read headers from %ENV |
95 | while ( my ( $header, $value ) = each %ENV ) { |
96 | next unless $header =~ /^(?:HTTP|CONTENT|COOKIE)/i; |
97 | ( my $field = $header ) =~ s/^HTTPS?_//; |
98 | $c->req->headers->header( $field => $value ); |
99 | } |
100 | } |
316bf0f0 |
101 | |
fbcc39ad |
102 | =item $self->prepare_path($c) |
316bf0f0 |
103 | |
fbcc39ad |
104 | =cut |
316bf0f0 |
105 | |
fbcc39ad |
106 | sub prepare_path { |
107 | my ( $self, $c ) = @_; |
108 | |
4f5ebacd |
109 | my $scheme = $c->request->secure ? 'https' : 'http'; |
fbcc39ad |
110 | my $host = $ENV{HTTP_HOST} || $ENV{SERVER_NAME}; |
111 | my $port = $ENV{SERVER_PORT} || 80; |
112 | my $base_path = $ENV{SCRIPT_NAME} || '/'; |
4f5ebacd |
113 | |
fbcc39ad |
114 | # If we are running as a backend proxy, get the true hostname |
4f5ebacd |
115 | PROXY_CHECK: |
fbcc39ad |
116 | { |
117 | unless ( $c->config->{using_frontend_proxy} ) { |
118 | last PROXY_CHECK if $host !~ /localhost|127.0.0.1/; |
119 | last PROXY_CHECK if $c->config->{ignore_frontend_proxy}; |
316bf0f0 |
120 | } |
fbcc39ad |
121 | last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_HOST}; |
316bf0f0 |
122 | |
fbcc39ad |
123 | $host = $ENV{HTTP_X_FORWARDED_HOST}; |
4f5ebacd |
124 | |
125 | # backend could be on any port, so |
fbcc39ad |
126 | # assume frontend is on the default port |
127 | $port = $c->request->secure ? 443 : 80; |
316bf0f0 |
128 | } |
129 | |
fbcc39ad |
130 | my $path = $base_path . $ENV{PATH_INFO}; |
131 | $path =~ s{^/+}{}; |
4f5ebacd |
132 | |
fbcc39ad |
133 | my $uri = URI->new; |
4f5ebacd |
134 | $uri->scheme($scheme); |
135 | $uri->host($host); |
136 | $uri->port($port); |
137 | $uri->path($path); |
fbcc39ad |
138 | $uri->query( $ENV{QUERY_STRING} ) if $ENV{QUERY_STRING}; |
4f5ebacd |
139 | |
fbcc39ad |
140 | # sanitize the URI |
141 | $uri = $uri->canonical; |
4f5ebacd |
142 | $c->request->uri($uri); |
fbcc39ad |
143 | |
144 | # set the base URI |
145 | # base must end in a slash |
4f5ebacd |
146 | $base_path .= '/' unless ( $base_path =~ /\/$/ ); |
fbcc39ad |
147 | my $base = $uri->clone; |
4f5ebacd |
148 | $base->path_query($base_path); |
149 | $c->request->base($base); |
e7c0c583 |
150 | } |
fc7ec1d9 |
151 | |
fbcc39ad |
152 | =item $self->prepare_query_parameters($c) |
fc7ec1d9 |
153 | |
154 | =cut |
155 | |
fbcc39ad |
156 | sub prepare_query_parameters { |
157 | my ( $self, $c ) = @_; |
e0616220 |
158 | |
f8109766 |
159 | if ( $ENV{QUERY_STRING} ) { |
160 | $self->SUPER::prepare_query_parameters( $c, $ENV{QUERY_STRING} ); |
161 | } |
fbcc39ad |
162 | } |
e7c0c583 |
163 | |
fbcc39ad |
164 | =item $self->prepare_write($c) |
bfde09a2 |
165 | |
fbcc39ad |
166 | Enable autoflush on the output handle for CGI-based engines. |
bfde09a2 |
167 | |
fbcc39ad |
168 | =cut |
e7c0c583 |
169 | |
fbcc39ad |
170 | sub prepare_write { |
171 | my ( $self, $c ) = @_; |
4f5ebacd |
172 | |
fbcc39ad |
173 | # Set the output handle to autoflush |
4f5ebacd |
174 | *STDOUT->autoflush(1); |
175 | |
176 | $self->NEXT::prepare_write($c); |
fbcc39ad |
177 | } |
e7c0c583 |
178 | |
fbcc39ad |
179 | =item $self->read_chunk($c, $buffer, $length) |
e7c0c583 |
180 | |
fbcc39ad |
181 | =cut |
e7c0c583 |
182 | |
4f5ebacd |
183 | sub read_chunk { shift; shift; *STDIN->sysread(@_); } |
e7c0c583 |
184 | |
fbcc39ad |
185 | =item $self->run |
bfde09a2 |
186 | |
fbcc39ad |
187 | =cut |
bfde09a2 |
188 | |
fbcc39ad |
189 | sub run { shift; shift->handle_request(@_) } |
fc7ec1d9 |
190 | |
23f9d934 |
191 | =back |
192 | |
fc7ec1d9 |
193 | =head1 SEE ALSO |
194 | |
fbcc39ad |
195 | L<Catalyst> L<Catalyst::Engine>. |
196 | |
197 | =head1 AUTHORS |
198 | |
199 | Sebastian Riedel, <sri@cpan.org> |
fc7ec1d9 |
200 | |
fbcc39ad |
201 | Christian Hansen, <ch@ngmedia.com> |
fc7ec1d9 |
202 | |
fbcc39ad |
203 | Andy Grundman, <andy@hybridized.org> |
fc7ec1d9 |
204 | |
205 | =head1 COPYRIGHT |
206 | |
207 | This program is free software, you can redistribute it and/or modify it under |
208 | the same terms as Perl itself. |
209 | |
210 | =cut |
211 | |
212 | 1; |