Commit | Line | Data |
fc7ec1d9 |
1 | package Catalyst::Engine::CGI; |
2 | |
3 | use strict; |
fbcc39ad |
4 | use base 'Catalyst::Engine'; |
5 | use NEXT; |
e2fd5b5f |
6 | |
b5ecfcf0 |
7 | __PACKAGE__->mk_accessors('env'); |
84528885 |
8 | |
fc7ec1d9 |
9 | =head1 NAME |
10 | |
11 | Catalyst::Engine::CGI - The CGI Engine |
12 | |
13 | =head1 SYNOPSIS |
14 | |
23f9d934 |
15 | A script using the Catalyst::Engine::CGI module might look like: |
16 | |
9a33da6a |
17 | #!/usr/bin/perl -w |
18 | |
19 | use strict; |
20 | use lib '/path/to/MyApp/lib'; |
21 | use MyApp; |
22 | |
23 | MyApp->run; |
24 | |
23f9d934 |
25 | The application module (C<MyApp>) would use C<Catalyst>, which loads the |
26 | appropriate engine module. |
fc7ec1d9 |
27 | |
28 | =head1 DESCRIPTION |
29 | |
fbcc39ad |
30 | This is the Catalyst engine specialized for the CGI environment. |
e2fd5b5f |
31 | |
23f9d934 |
32 | =head1 OVERLOADED METHODS |
fc7ec1d9 |
33 | |
fbcc39ad |
34 | This class overloads some methods from C<Catalyst::Engine>. |
fc7ec1d9 |
35 | |
b5ecfcf0 |
36 | =head2 $self->finalize_headers($c) |
fc7ec1d9 |
37 | |
38 | =cut |
39 | |
fbcc39ad |
40 | sub finalize_headers { |
41 | my ( $self, $c ) = @_; |
06e1b616 |
42 | |
fbcc39ad |
43 | $c->response->header( Status => $c->response->status ); |
06e1b616 |
44 | |
e512dd24 |
45 | $self->{_header_buf} |
46 | = $c->response->headers->as_string("\015\012") . "\015\012"; |
fc7ec1d9 |
47 | } |
48 | |
b5ecfcf0 |
49 | =head2 $self->prepare_connection($c) |
fc7ec1d9 |
50 | |
51 | =cut |
52 | |
fbcc39ad |
53 | sub prepare_connection { |
54 | my ( $self, $c ) = @_; |
b5ecfcf0 |
55 | local (*ENV) = $self->env || \%ENV; |
4f5ebacd |
56 | |
1a5d5501 |
57 | my $proxy = $self->_proxy_info($c); |
08cf3dd6 |
58 | |
1a5d5501 |
59 | $c->request->address( $proxy->{address} || $ENV{REMOTE_ADDR} ); |
60 | $c->request->hostname( $proxy->{host} || $ENV{REMOTE_HOST} ); |
61 | $c->request->protocol( $proxy->{scheme} || $ENV{SERVER_PROTOCOL} ); |
fbcc39ad |
62 | $c->request->user( $ENV{REMOTE_USER} ); |
63 | $c->request->method( $ENV{REQUEST_METHOD} ); |
64 | |
65 | if ( $ENV{HTTPS} && uc( $ENV{HTTPS} ) eq 'ON' ) { |
66 | $c->request->secure(1); |
5b387dfc |
67 | } |
bfde09a2 |
68 | |
fbcc39ad |
69 | if ( $ENV{SERVER_PORT} == 443 ) { |
70 | $c->request->secure(1); |
71 | } |
1a5d5501 |
72 | |
73 | if ( $c->request->protocol eq 'https' ) { |
74 | $c->request->secure(1); |
75 | } |
fc7ec1d9 |
76 | } |
77 | |
b5ecfcf0 |
78 | =head2 $self->prepare_headers($c) |
fc7ec1d9 |
79 | |
80 | =cut |
81 | |
fbcc39ad |
82 | sub prepare_headers { |
83 | my ( $self, $c ) = @_; |
b5ecfcf0 |
84 | local (*ENV) = $self->env || \%ENV; |
316bf0f0 |
85 | |
fbcc39ad |
86 | # Read headers from %ENV |
c82ed742 |
87 | foreach my $header ( keys %ENV ) { |
fbcc39ad |
88 | next unless $header =~ /^(?:HTTP|CONTENT|COOKIE)/i; |
89 | ( my $field = $header ) =~ s/^HTTPS?_//; |
c82ed742 |
90 | $c->req->headers->header( $field => $ENV{$header} ); |
fbcc39ad |
91 | } |
92 | } |
316bf0f0 |
93 | |
b5ecfcf0 |
94 | =head2 $self->prepare_path($c) |
316bf0f0 |
95 | |
fbcc39ad |
96 | =cut |
316bf0f0 |
97 | |
fbcc39ad |
98 | sub prepare_path { |
99 | my ( $self, $c ) = @_; |
b5ecfcf0 |
100 | local (*ENV) = $self->env || \%ENV; |
fbcc39ad |
101 | |
1a5d5501 |
102 | my $proxy = $self->_proxy_info($c); |
103 | |
4f5ebacd |
104 | my $scheme = $c->request->secure ? 'https' : 'http'; |
1a5d5501 |
105 | my $host = $proxy->{host} || $ENV{HTTP_HOST} || $ENV{SERVER_NAME}; |
106 | my $port = $proxy->{port} || $ENV{SERVER_PORT} || 80; |
0bcb98c7 |
107 | my $base_path; |
108 | if ( exists $ENV{REDIRECT_URL} ) { |
109 | $base_path = $ENV{REDIRECT_URL}; |
110 | $base_path =~ s/$ENV{PATH_INFO}$//; |
111 | } |
112 | else { |
113 | $base_path = $ENV{SCRIPT_NAME} || '/'; |
114 | } |
4f5ebacd |
115 | |
1a5d5501 |
116 | if ( $proxy->{path} ) { |
117 | $base_path = $proxy->{path} . $base_path; |
118 | $base_path =~ s{/$}{}g; |
316bf0f0 |
119 | } |
120 | |
8d3c800b |
121 | # set the request URI |
e701c5c6 |
122 | my $path = $base_path . ( $ENV{PATH_INFO} || '' ); |
fbcc39ad |
123 | $path =~ s{^/+}{}; |
1a5d5501 |
124 | |
933ba403 |
125 | # Using URI directly is way too slow, so we construct the URLs manually |
126 | my $uri_class = "URI::$scheme"; |
127 | |
de19de2e |
128 | # HTTP_HOST will include the port even if it's 80/443 |
129 | $host =~ s/:(?:80|443)$//; |
933ba403 |
130 | |
de19de2e |
131 | if ( $port !~ /^(?:80|443)$/ && $host !~ /:/ ) { |
933ba403 |
132 | $host .= ":$port"; |
133 | } |
134 | |
135 | # Escape the path |
136 | $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go; |
137 | $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE |
138 | |
139 | my $query = $ENV{QUERY_STRING} ? '?' . $ENV{QUERY_STRING} : ''; |
140 | my $uri = $scheme . '://' . $host . '/' . $path . $query; |
141 | |
142 | $c->request->uri( bless \$uri, $uri_class ); |
143 | |
8d3c800b |
144 | # set the base URI |
145 | # base must end in a slash |
146 | $base_path .= '/' unless $base_path =~ m{/$}; |
147 | |
148 | my $base_uri = $scheme . '://' . $host . $base_path; |
149 | |
150 | $c->request->base( bless \$base_uri, $uri_class ); |
e7c0c583 |
151 | } |
fc7ec1d9 |
152 | |
b5ecfcf0 |
153 | =head2 $self->prepare_query_parameters($c) |
fc7ec1d9 |
154 | |
155 | =cut |
156 | |
fbcc39ad |
157 | sub prepare_query_parameters { |
158 | my ( $self, $c ) = @_; |
b5ecfcf0 |
159 | local (*ENV) = $self->env || \%ENV; |
160 | |
f8109766 |
161 | if ( $ENV{QUERY_STRING} ) { |
162 | $self->SUPER::prepare_query_parameters( $c, $ENV{QUERY_STRING} ); |
163 | } |
fbcc39ad |
164 | } |
e7c0c583 |
165 | |
b5ecfcf0 |
166 | =head2 $self->prepare_request($c, (env => \%env)) |
84528885 |
167 | |
168 | =cut |
169 | |
170 | sub prepare_request { |
171 | my ( $self, $c, %args ) = @_; |
172 | |
173 | if ( $args{env} ) { |
b5ecfcf0 |
174 | $self->env( $args{env} ); |
84528885 |
175 | } |
176 | } |
177 | |
b5ecfcf0 |
178 | =head2 $self->prepare_write($c) |
bfde09a2 |
179 | |
fbcc39ad |
180 | Enable autoflush on the output handle for CGI-based engines. |
bfde09a2 |
181 | |
fbcc39ad |
182 | =cut |
e7c0c583 |
183 | |
fbcc39ad |
184 | sub prepare_write { |
185 | my ( $self, $c ) = @_; |
4f5ebacd |
186 | |
fbcc39ad |
187 | # Set the output handle to autoflush |
4f5ebacd |
188 | *STDOUT->autoflush(1); |
189 | |
190 | $self->NEXT::prepare_write($c); |
fbcc39ad |
191 | } |
e7c0c583 |
192 | |
e512dd24 |
193 | =head2 $self->write($c, $buffer) |
194 | |
195 | Writes the buffer to the client. |
196 | |
197 | =cut |
198 | |
199 | sub write { |
200 | my ( $self, $c, $buffer ) = @_; |
201 | |
202 | # Prepend the headers if they have not yet been sent |
203 | if ( my $headers = delete $self->{_header_buf} ) { |
204 | $buffer = $headers . $buffer; |
205 | } |
206 | |
207 | return $self->NEXT::write( $c, $buffer ); |
208 | } |
209 | |
b5ecfcf0 |
210 | =head2 $self->read_chunk($c, $buffer, $length) |
e7c0c583 |
211 | |
fbcc39ad |
212 | =cut |
e7c0c583 |
213 | |
4f5ebacd |
214 | sub read_chunk { shift; shift; *STDIN->sysread(@_); } |
e7c0c583 |
215 | |
b5ecfcf0 |
216 | =head2 $self->run |
bfde09a2 |
217 | |
fbcc39ad |
218 | =cut |
bfde09a2 |
219 | |
fbcc39ad |
220 | sub run { shift; shift->handle_request(@_) } |
fc7ec1d9 |
221 | |
fc7ec1d9 |
222 | =head1 SEE ALSO |
223 | |
0bf7ab71 |
224 | L<Catalyst>, L<Catalyst::Engine> |
fbcc39ad |
225 | |
226 | =head1 AUTHORS |
227 | |
0bf7ab71 |
228 | Catalyst Contributors, see Catalyst.pm |
fc7ec1d9 |
229 | |
230 | =head1 COPYRIGHT |
231 | |
232 | This program is free software, you can redistribute it and/or modify it under |
233 | the same terms as Perl itself. |
234 | |
235 | =cut |
236 | |
237 | 1; |