lib/Catalyst/Engine/CGI.pm

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