lib/Catalyst/Engine/CGI.pm

   1 package Catalyst::Engine::CGI;
   2
   3 use strict;
   4 use base 'Catalyst::Engine';
   5
   6 use CGI;
   7 use URI;
   8 use URI::http;
   9
  10 __PACKAGE__->mk_accessors('cgi');
  11
  12 =head1 NAME
  13
  14 Catalyst::Engine::CGI - The CGI Engine
  15
  16 =head1 SYNOPSIS
  17
  18 A script using the Catalyst::Engine::CGI module might look like:
  19
  20     #!/usr/bin/perl -w
  21
  22     use strict;
  23     use lib '/path/to/MyApp/lib';
  24     use MyApp;
  25
  26     MyApp->run;
  27
  28 The application module (C<MyApp>) would use C<Catalyst>, which loads the
  29 appropriate engine module.
  30
  31 =head1 DESCRIPTION
  32
  33 This is the Catalyst engine specialized for the CGI environment (using the
  34 C<CGI> and C<CGI::Cookie> modules).  Normally Catalyst will select the
  35 appropriate engine according to the environment that it detects, however you
  36 can force Catalyst to use the CGI engine by specifying the following in your
  37 application module:
  38
  39     use Catalyst qw(-Engine=CGI);
  40
  41 The performance of this way of using Catalyst is not expected to be
  42 useful in production applications, but it may be helpful for development.
  43
  44 =head1 METHODS
  45
  46 =over 4
  47
  48 =item $c->cgi
  49
  50 This config parameter contains the C<CGI> object.
  51
  52 =back
  53
  54 =head1 OVERLOADED METHODS
  55
  56 This class overloads some methods from C<Catalyst::Engine>.
  57
  58 =over 4
  59
  60 =item $c->finalize_body
  61
  62 Prints the response output to STDOUT.
  63
  64 =cut
  65
  66 sub finalize_body {
  67     my $c = shift;
  68     print $c->response->output;
  69 }
  70
  71 =item $c->finalize_headers
  72
  73 =cut
  74
  75 sub finalize_headers {
  76     my $c = shift;
  77
  78     $c->response->header( Status => $c->response->status );
  79
  80     print $c->response->headers->as_string("\015\012");
  81     print "\015\012";
  82 }
  83
  84 =item $c->prepare_body
  85
  86 =cut
  87
  88 sub prepare_body {
  89     my $c = shift;
  90
  91     # XXX this is undocumented in CGI.pm. If Content-Type is not
  92     # application/x-www-form-urlencoded or multipart/form-data
  93     # CGI.pm will read STDIN into a param, POSTDATA.
  94
  95     $c->request->body( $c->cgi->param('POSTDATA') );
  96 }
  97
  98 =item $c->prepare_connection
  99
 100 =cut
 101
 102 sub prepare_connection {
 103     my $c = shift;
 104     $c->req->hostname( $ENV{REMOTE_HOST} );
 105     $c->req->address( $ENV{REMOTE_ADDR} );
 106 }
 107
 108 =item $c->prepare_headers
 109
 110 =cut
 111
 112 sub prepare_headers {
 113     my $c = shift;
 114
 115     while ( my ( $header, $value ) = each %ENV ) {
 116
 117         next unless $header =~ /^(HTTP|CONTENT)/i;
 118
 119         ( my $field = $header ) =~ s/^HTTPS?_//;
 120
 121         $c->req->headers->header( $field => $value );
 122     }
 123
 124     $c->req->method( $ENV{REQUEST_METHOD} || 'GET' );
 125 }
 126
 127 =item $c->prepare_parameters
 128
 129 =cut
 130
 131 sub prepare_parameters {
 132     my $c = shift;
 133
 134     my ( @params );
 135
 136
 137     if ( $c->request->method eq 'POST' ) {
 138
 139         for my $param ( $c->cgi->url_param ) {
 140             for my $value (  $c->cgi->url_param($param) ) {
 141                 push ( @params, $param, $value );
 142             }
 143         }
 144     }
 145
 146     for my $param ( $c->cgi->param ) {
 147         for my $value (  $c->cgi->param($param) ) {
 148             push ( @params, $param, $value );
 149         }
 150     }
 151
 152     $c->req->_assign_values( $c->req->parameters, \@params );
 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/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 180     $path =~ s/^\///;
 181
 182     $c->req->base($base);
 183     $c->req->path($path);
 184 }
 185
 186 =item $c->prepare_request
 187
 188 =cut
 189
 190 sub prepare_request {
 191     my ( $c, $cgi ) = @_;
 192     $c->cgi( $cgi || CGI->new );
 193     $c->cgi->_reset_globals;
 194 }
 195
 196 =item $c->prepare_uploads
 197
 198 =cut
 199
 200 sub prepare_uploads {
 201     my $c = shift;
 202
 203     my @uploads;
 204
 205     for my $param ( $c->cgi->param ) {
 206
 207         my @values = $c->cgi->param($param);
 208
 209         next unless ref( $values[0] );
 210
 211         for my $fh (@values) {
 212
 213             next unless my $size = ( stat $fh )[7];
 214
 215             my $info        = $c->cgi->uploadInfo($fh);
 216             my $tempname    = $c->cgi->tmpFileName($fh);
 217             my $type        = $info->{'Content-Type'};
 218             my $disposition = $info->{'Content-Disposition'};
 219             my $filename    = ( $disposition =~ / filename="([^;]*)"/ )[0];
 220
 221             my $upload = Catalyst::Request::Upload->new(
 222                 filename => $filename,
 223                 size     => $size,
 224                 tempname => $tempname,
 225                 type     => $type
 226             );
 227
 228             push( @uploads, $param, $upload );
 229         }
 230     }
 231
 232     $c->req->_assign_values( $c->req->uploads, \@uploads );
 233 }
 234
 235 =item $c->run
 236
 237 =cut
 238
 239 sub run { shift->handler }
 240
 241 =back
 242
 243 =head1 SEE ALSO
 244
 245 L<Catalyst>.
 246
 247 =head1 AUTHOR
 248
 249 Sebastian Riedel, C<sri@cpan.org>
 250
 251 =head1 COPYRIGHT
 252
 253 This program is free software, you can redistribute it and/or modify it under
 254 the same terms as Perl itself.
 255
 256 =cut
 257
 258 1;