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::Engine>.
  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
 145     $c->cgi->parse_query_string;
 146
 147     my %vars = $c->cgi->Vars;
 148     while ( my ( $key, $value ) = each %vars ) {
 149         my @values = split "\0", $value;
 150         $vars{$key} = @values <= 1 ? $values[0] : \@values;
 151     }
 152     $c->req->parameters( {%vars} );
 153 }
 154
 155 =item $c->prepare_path
 156
 157 =cut
 158
 159 sub prepare_path {
 160     my $c = shift;
 161
 162     my $base;
 163     {
 164         my $scheme = $ENV{HTTPS} ? 'https' : 'http';
 165         my $host   = $ENV{HTTP_HOST} || $ENV{SERVER_NAME};
 166         my $port   = $ENV{SERVER_PORT} || 80;
 167         my $path   = $ENV{SCRIPT_NAME} || '/';
 168
 169         $base = URI->new;
 170         $base->scheme($scheme);
 171         $base->host($host);
 172         $base->port($port);
 173         $base->path($path);
 174
 175         $base = $base->canonical->as_string;
 176     }
 177
 178     my $path = $ENV{PATH_INFO} || '/';
 179     $path =~  s/^\///;
 180
 181     $c->req->base($base);
 182     $c->req->path($path);
 183 }
 184
 185 =item $c->prepare_request
 186
 187 =cut
 188
 189 sub prepare_request { shift->cgi( CGI::Simple->new ) }
 190
 191 =item $c->prepare_uploads
 192
 193 =cut
 194
 195 sub prepare_uploads {
 196     my $c = shift;
 197     for my $name ( $c->cgi->upload ) {
 198         next unless defined $name;
 199         $c->req->uploads->{$name} = {
 200             fh   => $c->cgi->upload($name),
 201             size => $c->cgi->upload_info( $name, 'size' ),
 202             type => $c->cgi->upload_info( $name, 'mime' )
 203         };
 204     }
 205 }
 206
 207 =item $c->run
 208
 209 =cut
 210
 211 sub run { shift->handler }
 212
 213 =back
 214
 215 =head1 SEE ALSO
 216
 217 L<Catalyst>.
 218
 219 =head1 AUTHOR
 220
 221 Sebastian Riedel, C<sri@cpan.org>
 222
 223 =head1 COPYRIGHT
 224
 225 This program is free software, you can redistribute it and/or modify it under
 226 the same terms as Perl itself.
 227
 228 =cut
 229
 230 1;