X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCatalyst%2FEngine%2FCGI.pm;h=29b8421a2383c3117d4fb82fb50dd82518cdbda9;hb=6dc87a0f8301391acfe25ee5bcaad0fe48dad559;hp=67ec08c39db49694bb0ed6a122fa53a86555ebb8;hpb=8495c1decb1fab254162f713255ece0372c2697d;p=catagits%2FCatalyst-Runtime.git

diff --git a/lib/Catalyst/Engine/CGI.pm b/lib/Catalyst/Engine/CGI.pm
index 67ec08c..29b8421 100644
--- a/lib/Catalyst/Engine/CGI.pm
+++ b/lib/Catalyst/Engine/CGI.pm
@@ -5,7 +5,6 @@ use base 'Catalyst::Engine';
 use URI;
 
 require CGI::Simple;
-require CGI::Cookie;
 
 $CGI::Simple::POST_MAX        = 1048576;
 $CGI::Simple::DISABLE_UPLOADS = 0;
@@ -18,53 +17,68 @@ Catalyst::Engine::CGI - The CGI Engine
 
 =head1 SYNOPSIS
 
-See L<Catalyst>.
+A script using the Catalyst::Engine::CGI module might look like:
+
+    #!/usr/bin/perl -w
+
+    use strict;
+    use lib '/path/to/MyApp/lib';
+    use MyApp;
+
+    MyApp->run;
+
+The application module (C<MyApp>) would use C<Catalyst>, which loads the
+appropriate engine module.
 
 =head1 DESCRIPTION
 
-This is the CGI engine for Catalyst.
+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
+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:
+
+    use Catalyst qw(-Engine=CGI);
 
-=head2 METHODS
+The performance of this way of using Catalyst is not expected to be
+useful in production applications, but it may be helpful for development.
 
-=head3 run
+=head1 METHODS
 
-To be called from a CGI script to start the Catalyst application.
+=over 4
 
-=head3 cgi
+=item $c->cgi
 
 This config parameter contains the C<CGI::Simple> object.
 
-=head2 OVERLOADED METHODS
+=back
+
+=head1 OVERLOADED METHODS
 
-This class overloads some methods from C<Catalyst>.
+This class overloads some methods from C<Catalyst::Engine>.
 
-=head3 finalize_headers
+=over 4
+
+=item $c->finalize_headers
 
 =cut
 
 sub finalize_headers {
     my $c = shift;
-    my %headers = ( -nph => 1 );
+    my %headers;
+
     $headers{-status} = $c->response->status if $c->response->status;
+
     for my $name ( $c->response->headers->header_field_names ) {
-        $headers{"-$name"} = $c->response->headers->header($name);
+        $headers{"-$name"} = $c->response->header($name);
     }
-    my @cookies;
-    while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
-        push @cookies, $c->cgi->cookie(
-            -name    => $name,
-            -value   => $cookie->{value},
-            -expires => $cookie->{expires},
-            -domain  => $cookie->{domain},
-            -path    => $cookie->{path},
-            -secure  => $cookie->{secure} || 0
-        );
-    }
-    $headers{-cookie} = \@cookies if @cookies;
+
     print $c->cgi->header(%headers);
 }
 
-=head3 finalize_output
+=item $c->finalize_output
+
+Prints the response output to STDOUT.
 
 =cut
 
@@ -73,13 +87,17 @@ sub finalize_output {
     print $c->response->output;
 }
 
-=head3 prepare_cookies
+=item $c->prepare_connection
 
 =cut
 
-sub prepare_cookies { shift->req->cookies( { CGI::Cookie->fetch } ) }
+sub prepare_connection {
+    my $c = shift;
+    $c->req->hostname( $c->cgi->remote_host );
+    $c->req->address( $c->cgi->remote_addr );
+}
 
-=head3 prepare_headers
+=item $c->prepare_headers
 
 =cut
 
@@ -90,14 +108,19 @@ sub prepare_headers {
         ( my $field = $header ) =~ s/^HTTPS?_//;
         $c->req->headers->header( $field => $c->cgi->http($header) );
     }
+    $c->req->headers->header( 'Content-Type'   => $c->cgi->content_type );
+    $c->req->headers->header( 'Content-Length' => $c->cgi->content_length );
 }
 
-=head3 prepare_parameters
+=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;
@@ -106,41 +129,51 @@ sub prepare_parameters {
     $c->req->parameters( {%vars} );
 }
 
-=head3 prepare_path
+=item $c->prepare_path
 
 =cut
 
 sub prepare_path {
     my $c = shift;
-    $c->req->path( $c->cgi->url( -absolute => 1, -path_info => 1 ) );
-    my $loc = $c->cgi->url( -absolute => 1 );
-    no warnings 'uninitialized';
-    $c->req->{path} =~ s/^($loc)?\///;
-    $c->req->{path} .= '/' if $c->req->path eq $loc;
-    my $base = $c->cgi->url;
-    if ( $ENV{CATALYST_TEST} ) {
-        my $script = $c->cgi->script_name;
-        $base =~ s/$script$//i;
+
+    my $base;
+    {
+        my $scheme = $ENV{HTTPS} ? 'https' : 'http';
+        my $host   = $ENV{HTTP_HOST} || $ENV{SERVER_NAME};
+        my $port   = $ENV{SERVER_PORT} || 80;
+        my $path   = $ENV{SCRIPT_NAME} || '/';
+
+        $base = URI->new;
+        $base->scheme($scheme);
+        $base->host($host);
+        $base->port($port);
+        $base->path($path);
+
+        $base = $base->canonical->as_string;
     }
-    $base = URI->new($base);
-    $base->path('/') if ( $ENV{CATALYST_TEST} || !$base->path );
-    $c->req->base( $base->as_string );
-    $c->req->server_base( $base->scheme . '://' . $base->authority );
+
+    my $path = $ENV{PATH_INFO} || '/';
+    $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
+    $path =~  s/^\///;
+
+    $c->req->base($base);
+    $c->req->path($path);
 }
 
-=head3 prepare_request
+=item $c->prepare_request
 
 =cut
 
 sub prepare_request { shift->cgi( CGI::Simple->new ) }
 
-=head3 prepare_uploads
+=item $c->prepare_uploads
 
 =cut
 
 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' ),
@@ -149,8 +182,14 @@ sub prepare_uploads {
     }
 }
 
+=item $c->run
+
+=cut
+
 sub run { shift->handler }
 
+=back
+
 =head1 SEE ALSO
 
 L<Catalyst>.