Commit | Line | Data |
fc7ec1d9 |
1 | package Catalyst::Engine::CGI; |
2 | |
3 | use strict; |
4 | use base 'Catalyst::Engine'; |
5 | use URI; |
6 | |
7 | require CGI::Simple; |
fc7ec1d9 |
8 | |
7833fdfc |
9 | $CGI::Simple::POST_MAX = 1048576; |
10 | $CGI::Simple::DISABLE_UPLOADS = 0; |
11 | |
fc7ec1d9 |
12 | __PACKAGE__->mk_accessors('cgi'); |
13 | |
14 | =head1 NAME |
15 | |
16 | Catalyst::Engine::CGI - The CGI Engine |
17 | |
18 | =head1 SYNOPSIS |
19 | |
23f9d934 |
20 | A script using the Catalyst::Engine::CGI module might look like: |
21 | |
9a33da6a |
22 | #!/usr/bin/perl -w |
23 | |
24 | use strict; |
25 | use lib '/path/to/MyApp/lib'; |
26 | use MyApp; |
27 | |
28 | MyApp->run; |
29 | |
23f9d934 |
30 | The application module (C<MyApp>) would use C<Catalyst>, which loads the |
31 | appropriate engine module. |
fc7ec1d9 |
32 | |
33 | =head1 DESCRIPTION |
34 | |
23f9d934 |
35 | This is the Catalyst engine specialized for the CGI environment (using the |
36 | C<CGI::Simple> and C<CGI::Cookie> modules). Normally Catalyst will select the |
37 | appropriate engine according to the environment that it detects, however you |
38 | can force Catalyst to use the CGI engine by specifying the following in your |
39 | application module: |
40 | |
41 | use Catalyst qw(-Engine=CGI); |
fc7ec1d9 |
42 | |
9a33da6a |
43 | The performance of this way of using Catalyst is not expected to be |
44 | useful in production applications, but it may be helpful for development. |
45 | |
23f9d934 |
46 | =head1 METHODS |
fc7ec1d9 |
47 | |
23f9d934 |
48 | =over 4 |
49 | |
23f9d934 |
50 | =item $c->cgi |
fc7ec1d9 |
51 | |
52 | This config parameter contains the C<CGI::Simple> object. |
53 | |
23f9d934 |
54 | =back |
55 | |
56 | =head1 OVERLOADED METHODS |
fc7ec1d9 |
57 | |
45374ac6 |
58 | This class overloads some methods from C<Catalyst::Engine>. |
fc7ec1d9 |
59 | |
23f9d934 |
60 | =over 4 |
61 | |
62 | =item $c->finalize_headers |
fc7ec1d9 |
63 | |
64 | =cut |
65 | |
66 | sub finalize_headers { |
67 | my $c = shift; |
e646f111 |
68 | my %headers; |
6dc87a0f |
69 | |
fc7ec1d9 |
70 | $headers{-status} = $c->response->status if $c->response->status; |
6dc87a0f |
71 | |
fc7ec1d9 |
72 | for my $name ( $c->response->headers->header_field_names ) { |
6dc87a0f |
73 | $headers{"-$name"} = $c->response->header($name); |
fc7ec1d9 |
74 | } |
6dc87a0f |
75 | |
fc7ec1d9 |
76 | print $c->cgi->header(%headers); |
77 | } |
78 | |
23f9d934 |
79 | =item $c->finalize_output |
80 | |
81 | Prints the response output to STDOUT. |
fc7ec1d9 |
82 | |
83 | =cut |
84 | |
85 | sub finalize_output { |
86 | my $c = shift; |
87 | print $c->response->output; |
88 | } |
89 | |
0556eb49 |
90 | =item $c->prepare_connection |
91 | |
92 | =cut |
93 | |
94 | sub prepare_connection { |
95 | my $c = shift; |
96 | $c->req->hostname( $c->cgi->remote_host ); |
97 | $c->req->address( $c->cgi->remote_addr ); |
98 | } |
99 | |
23f9d934 |
100 | =item $c->prepare_headers |
fc7ec1d9 |
101 | |
102 | =cut |
103 | |
104 | sub prepare_headers { |
105 | my $c = shift; |
106 | $c->req->method( $c->cgi->request_method ); |
107 | for my $header ( $c->cgi->http ) { |
108 | ( my $field = $header ) =~ s/^HTTPS?_//; |
109 | $c->req->headers->header( $field => $c->cgi->http($header) ); |
110 | } |
49faa307 |
111 | $c->req->headers->header( 'Content-Type' => $c->cgi->content_type ); |
112 | $c->req->headers->header( 'Content-Length' => $c->cgi->content_length ); |
fc7ec1d9 |
113 | } |
114 | |
23f9d934 |
115 | =item $c->prepare_parameters |
fc7ec1d9 |
116 | |
117 | =cut |
118 | |
119 | sub prepare_parameters { |
120 | my $c = shift; |
523d44ec |
121 | |
122 | $c->cgi->parse_query_string; |
123 | |
fc7ec1d9 |
124 | my %vars = $c->cgi->Vars; |
125 | while ( my ( $key, $value ) = each %vars ) { |
126 | my @values = split "\0", $value; |
127 | $vars{$key} = @values <= 1 ? $values[0] : \@values; |
128 | } |
129 | $c->req->parameters( {%vars} ); |
130 | } |
131 | |
23f9d934 |
132 | =item $c->prepare_path |
fc7ec1d9 |
133 | |
134 | =cut |
135 | |
136 | sub prepare_path { |
137 | my $c = shift; |
8b4483b3 |
138 | |
139 | my $base; |
140 | { |
141 | my $scheme = $ENV{HTTPS} ? 'https' : 'http'; |
142 | my $host = $ENV{HTTP_HOST} || $ENV{SERVER_NAME}; |
143 | my $port = $ENV{SERVER_PORT} || 80; |
144 | my $path = $ENV{SCRIPT_NAME} || '/'; |
145 | |
146 | $base = URI->new; |
147 | $base->scheme($scheme); |
148 | $base->host($host); |
149 | $base->port($port); |
150 | $base->path($path); |
151 | |
152 | $base = $base->canonical->as_string; |
7833fdfc |
153 | } |
8b4483b3 |
154 | |
155 | my $path = $ENV{PATH_INFO} || '/'; |
6dc87a0f |
156 | $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; |
8b4483b3 |
157 | $path =~ s/^\///; |
158 | |
159 | $c->req->base($base); |
160 | $c->req->path($path); |
fc7ec1d9 |
161 | } |
162 | |
23f9d934 |
163 | =item $c->prepare_request |
fc7ec1d9 |
164 | |
165 | =cut |
166 | |
167 | sub prepare_request { shift->cgi( CGI::Simple->new ) } |
168 | |
23f9d934 |
169 | =item $c->prepare_uploads |
fc7ec1d9 |
170 | |
171 | =cut |
172 | |
173 | sub prepare_uploads { |
174 | my $c = shift; |
175 | for my $name ( $c->cgi->upload ) { |
b0b7c5e0 |
176 | next unless defined $name; |
fc7ec1d9 |
177 | $c->req->uploads->{$name} = { |
7833fdfc |
178 | fh => $c->cgi->upload($name), |
179 | size => $c->cgi->upload_info( $name, 'size' ), |
180 | type => $c->cgi->upload_info( $name, 'mime' ) |
fc7ec1d9 |
181 | }; |
182 | } |
183 | } |
184 | |
c9afa5fc |
185 | =item $c->run |
186 | |
187 | =cut |
188 | |
fc7ec1d9 |
189 | sub run { shift->handler } |
190 | |
23f9d934 |
191 | =back |
192 | |
fc7ec1d9 |
193 | =head1 SEE ALSO |
194 | |
195 | L<Catalyst>. |
196 | |
197 | =head1 AUTHOR |
198 | |
199 | Sebastian Riedel, C<sri@cpan.org> |
200 | |
201 | =head1 COPYRIGHT |
202 | |
203 | This program is free software, you can redistribute it and/or modify it under |
204 | the same terms as Perl itself. |
205 | |
206 | =cut |
207 | |
208 | 1; |