use strict;
use base 'Catalyst::Engine';
+
+use CGI;
use URI;
use URI::http;
-require CGI::Simple;
-
-$CGI::Simple::POST_MAX = 1048576;
-$CGI::Simple::DISABLE_UPLOADS = 0;
-
__PACKAGE__->mk_accessors('cgi');
=head1 NAME
=head1 DESCRIPTION
This is the Catalyst engine specialized for the CGI environment (using the
-C<CGI::Simple> and C<CGI::Cookie> modules). Normally Catalyst will select the
+C<CGI> and C<CGI::Cookie> modules). Normally Catalyst will select the
appropriate engine according to the environment that it detects, however you
can force Catalyst to use the CGI engine by specifying the following in your
application module:
=item $c->cgi
-This config parameter contains the C<CGI::Simple> object.
+This config parameter contains the C<CGI> object.
=back
=over 4
+=item $c->finalize_body
+
+Prints the response output to STDOUT.
+
+=cut
+
+sub finalize_body {
+ my $c = shift;
+ print $c->response->output;
+}
+
=item $c->finalize_headers
=cut
sub finalize_headers {
my $c = shift;
- my %headers;
-
- $headers{-status} = $c->response->status if $c->response->status;
- for my $name ( $c->response->headers->header_field_names ) {
- $headers{"-$name"} = $c->response->header($name);
- }
+ $c->response->header( Status => $c->response->status );
- print $c->cgi->header(%headers);
+ print $c->response->headers->as_string("\015\012");
+ print "\015\012";
}
-=item $c->finalize_output
-
-Prints the response output to STDOUT.
+=item $c->prepare_body
=cut
-sub finalize_output {
+sub prepare_body {
my $c = shift;
- print $c->response->output;
+
+ # XXX this is undocumented in CGI.pm. If Content-Type is not
+ # application/x-www-form-urlencoded or multipart/form-data
+ # CGI.pm will read STDIN into a param, POSTDATA.
+
+ $c->request->body( $c->cgi->param('POSTDATA') );
}
=item $c->prepare_connection
sub prepare_connection {
my $c = shift;
- $c->req->hostname( $c->cgi->remote_host );
- $c->req->address( $c->cgi->remote_addr );
+ $c->request->address( $ENV{REMOTE_ADDR} );
+ $c->request->hostname( $ENV{REMOTE_HOST} );
+ $c->request->protocol( $ENV{SERVER_PROTOCOL} );
+
+ if ( $ENV{HTTPS} || $ENV{SERVER_PORT} == 443 ) {
+ $c->request->secure(1);
+ }
}
=item $c->prepare_headers
sub prepare_headers {
my $c = shift;
- $c->req->method( $c->cgi->request_method );
- for my $header ( $c->cgi->http ) {
+
+ while ( my ( $header, $value ) = each %ENV ) {
+
+ next unless $header =~ /^(HTTP|CONTENT)/i;
+
( my $field = $header ) =~ s/^HTTPS?_//;
- $c->req->headers->header( $field => $c->cgi->http($header) );
+
+ $c->req->headers->header( $field => $value );
}
- $c->req->headers->header( 'Content-Type' => $c->cgi->content_type );
- $c->req->headers->header( 'Content-Length' => $c->cgi->content_length );
+
+ $c->req->method( $ENV{REQUEST_METHOD} || 'GET' );
}
=item $c->prepare_parameters
=cut
sub prepare_parameters {
- my $c = shift;
-
- $c->cgi->parse_query_string;
-
- my %vars = $c->cgi->Vars;
- while ( my ( $key, $value ) = each %vars ) {
- my @values = split "\0", $value;
- $vars{$key} = @values <= 1 ? $values[0] : \@values;
+ my $c = shift;
+
+ my ( @params );
+
+ if ( $c->request->method eq 'POST' ) {
+ for my $param ( $c->cgi->url_param ) {
+ for my $value ( $c->cgi->url_param($param) ) {
+ push ( @params, $param, $value );
+ }
+ }
+ }
+
+ for my $param ( $c->cgi->param ) {
+ for my $value ( $c->cgi->param($param) ) {
+ push ( @params, $param, $value );
+ }
}
- $c->req->parameters( {%vars} );
+
+ $c->request->param(@params);
}
=item $c->prepare_path
my $base;
{
- my $scheme = $ENV{HTTPS} ? 'https' : 'http';
- my $host = $ENV{HTTP_HOST} || $ENV{SERVER_NAME};
+ my $scheme = $c->request->secure ? 'https' : 'http';
+ my $host = $ENV{HTTP_HOST} || $ENV{SERVER_NAME};
my $port = $ENV{SERVER_PORT} || 80;
my $path = $ENV{SCRIPT_NAME} || '/';
+ unless ( $path =~ /\/$/ ) {
+ $path .= '/';
+ }
+
$base = URI->new;
$base->scheme($scheme);
$base->host($host);
my $path = $ENV{PATH_INFO} || '/';
$path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
- $path =~ s/^\///;
+ $path =~ s/^\///;
$c->req->base($base);
$c->req->path($path);
=cut
-sub prepare_request { shift->cgi( CGI::Simple->new ) }
+sub prepare_request {
+ my ( $c, $cgi ) = @_;
+ $c->cgi( $cgi || CGI->new );
+ $c->cgi->_reset_globals;
+}
=item $c->prepare_uploads
sub prepare_uploads {
my $c = shift;
- for my $name ( $c->cgi->upload ) {
- next unless defined $name;
- $c->req->uploads->{$name} = {
- fh => $c->cgi->upload($name),
- size => $c->cgi->upload_info( $name, 'size' ),
- type => $c->cgi->upload_info( $name, 'mime' )
- };
+
+ my @uploads;
+
+ for my $param ( $c->cgi->param ) {
+
+ my @values = $c->cgi->param($param);
+
+ next unless ref( $values[0] );
+
+ for my $fh (@values) {
+
+ next unless my $size = ( stat $fh )[7];
+
+ my $info = $c->cgi->uploadInfo($fh);
+ my $tempname = $c->cgi->tmpFileName($fh);
+ my $type = $info->{'Content-Type'};
+ my $disposition = $info->{'Content-Disposition'};
+ my $filename = ( $disposition =~ / filename="([^;]*)"/ )[0];
+
+ my $upload = Catalyst::Request::Upload->new(
+ filename => $filename,
+ size => $size,
+ tempname => $tempname,
+ type => $type
+ );
+
+ push( @uploads, $param, $upload );
+ }
}
+
+ $c->request->upload(@uploads);
}
=item $c->run