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->cgi
  57
  58 This config parameter contains the C<CGI::Simple> object.
  59
  60 =back
  61
  62 =head1 OVERLOADED METHODS
  63
  64 This class overloads some methods from C<Catalyst>.
  65
  66 =over 4
  67
  68 =item $c->finalize_headers
  69
  70 =cut
  71
  72 sub finalize_headers {
  73     my $c = shift;
  74     my %headers;
  75     $headers{-status} = $c->response->status if $c->response->status;
  76     for my $name ( $c->response->headers->header_field_names ) {
  77         $headers{"-$name"} = $c->response->headers->header($name);
  78     }
  79     my @cookies;
  80     while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
  81         push @cookies, $c->cgi->cookie(
  82             -name    => $name,
  83             -value   => $cookie->{value},
  84             -expires => $cookie->{expires},
  85             -domain  => $cookie->{domain},
  86             -path    => $cookie->{path},
  87             -secure  => $cookie->{secure} || 0
  88         );
  89     }
  90     $headers{-cookie} = \@cookies if @cookies;
  91     print $c->cgi->header(%headers);
  92 }
  93
  94 =item $c->finalize_output
  95
  96 Prints the response output to STDOUT.
  97
  98 =cut
  99
 100 sub finalize_output {
 101     my $c = shift;
 102     print $c->response->output;
 103 }
 104
 105 =item $c->prepare_connection
 106
 107 =cut
 108
 109 sub prepare_connection {
 110     my $c = shift;
 111     $c->req->hostname( $c->cgi->remote_host );
 112     $c->req->address( $c->cgi->remote_addr );
 113 }
 114
 115 =item $c->prepare_cookies
 116
 117 Sets up cookies.
 118
 119 =cut
 120
 121 sub prepare_cookies { shift->req->cookies( { CGI::Cookie->fetch } ) }
 122
 123 =item $c->prepare_headers
 124
 125 =cut
 126
 127 sub prepare_headers {
 128     my $c = shift;
 129     $c->req->method( $c->cgi->request_method );
 130     for my $header ( $c->cgi->http ) {
 131         ( my $field = $header ) =~ s/^HTTPS?_//;
 132         $c->req->headers->header( $field => $c->cgi->http($header) );
 133     }
 134     $c->req->headers->header( 'Content-Type'   => $c->cgi->content_type );
 135     $c->req->headers->header( 'Content-Length' => $c->cgi->content_length );
 136 }
 137
 138 =item $c->prepare_parameters
 139
 140 =cut
 141
 142 sub prepare_parameters {
 143     my $c    = shift;
 144     my %vars = $c->cgi->Vars;
 145     while ( my ( $key, $value ) = each %vars ) {
 146         my @values = split "\0", $value;
 147         $vars{$key} = @values <= 1 ? $values[0] : \@values;
 148     }
 149     $c->req->parameters( {%vars} );
 150 }
 151
 152 =item $c->prepare_path
 153
 154 =cut
 155
 156 sub prepare_path {
 157     my $c = shift;
 158
 159     my $base;
 160     {
 161         my $scheme = $ENV{HTTPS} ? 'https' : 'http';
 162         my $host   = $ENV{HTTP_HOST} || $ENV{SERVER_NAME};
 163         my $port   = $ENV{SERVER_PORT} || 80;
 164         my $path   = $ENV{SCRIPT_NAME} || '/';
 165
 166         $base = URI->new;
 167         $base->scheme($scheme);
 168         $base->host($host);
 169         $base->port($port);
 170         $base->path($path);
 171
 172         $base = $base->canonical->as_string;
 173     }
 174
 175     my $path = $ENV{PATH_INFO} || '/';
 176     $path =~  s/^\///;
 177
 178     $c->req->base($base);
 179     $c->req->path($path);
 180 }
 181
 182 =item $c->prepare_request
 183
 184 =cut
 185
 186 sub prepare_request { shift->cgi( CGI::Simple->new ) }
 187
 188 =item $c->prepare_uploads
 189
 190 =cut
 191
 192 sub prepare_uploads {
 193     my $c = shift;
 194     for my $name ( $c->cgi->upload ) {
 195         next unless defined $name;
 196         $c->req->uploads->{$name} = {
 197             fh   => $c->cgi->upload($name),
 198             size => $c->cgi->upload_info( $name, 'size' ),
 199             type => $c->cgi->upload_info( $name, 'mime' )
 200         };
 201     }
 202 }
 203
 204 =item $c->run
 205
 206 =cut
 207
 208 sub run { shift->handler }
 209
 210 =back
 211
 212 =head1 SEE ALSO
 213
 214 L<Catalyst>.
 215
 216 =head1 AUTHOR
 217
 218 Sebastian Riedel, C<sri@cpan.org>
 219
 220 =head1 COPYRIGHT
 221
 222 This program is free software, you can redistribute it and/or modify it under
 223 the same terms as Perl itself.
 224
 225 =cut
 226
 227 1;