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->request->address( $ENV{REMOTE_ADDR} );
 105     $c->request->hostname( $ENV{REMOTE_HOST} );
 106     $c->request->protocol( $ENV{SERVER_PROTOCOL} );
 107
 108     if ( $ENV{HTTPS} || $ENV{SERVER_PORT} == 443 ) {
 109         $c->request->secure(1);
 110     }
 111 }
 112
 113 =item $c->prepare_headers
 114
 115 =cut
 116
 117 sub prepare_headers {
 118     my $c = shift;
 119
 120     while ( my ( $header, $value ) = each %ENV ) {
 121
 122         next unless $header =~ /^(HTTP|CONTENT)/i;
 123
 124         ( my $field = $header ) =~ s/^HTTPS?_//;
 125
 126         $c->req->headers->header( $field => $value );
 127     }
 128
 129     $c->req->method( $ENV{REQUEST_METHOD} || 'GET' );
 130 }
 131
 132 =item $c->prepare_parameters
 133
 134 =cut
 135
 136 sub prepare_parameters {
 137     my $c = shift;
 138
 139     my ( @params );
 140
 141     if ( $c->request->method eq 'POST' ) {
 142         for my $param ( $c->cgi->url_param ) {
 143             for my $value (  $c->cgi->url_param($param) ) {
 144                 push ( @params, $param, $value );
 145             }
 146         }
 147     }
 148
 149     for my $param ( $c->cgi->param ) {
 150         for my $value (  $c->cgi->param($param) ) {
 151             push ( @params, $param, $value );
 152         }
 153     }
 154
 155     $c->request->param(@params);
 156 }
 157
 158 =item $c->prepare_path
 159
 160 =cut
 161
 162 sub prepare_path {
 163     my $c = shift;
 164
 165     my $base;
 166     {
 167         my $scheme = $c->request->secure ? 'https' : 'http';
 168         my $host   = $ENV{HTTP_HOST}   || $ENV{SERVER_NAME};
 169         my $port   = $ENV{SERVER_PORT} || 80;
 170         my $path   = $ENV{SCRIPT_NAME} || '/';
 171
 172         unless ( $path =~ /\/$/ ) {
 173             $path .= '/';
 174         }
 175
 176         $base = URI->new;
 177         $base->scheme($scheme);
 178         $base->host($host);
 179         $base->port($port);
 180         $base->path($path);
 181
 182         $base = $base->canonical->as_string;
 183     }
 184
 185     my $path = $ENV{PATH_INFO} || '/';
 186     $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 187     $path =~ s/^\///;
 188
 189     $c->req->base($base);
 190     $c->req->path($path);
 191 }
 192
 193 =item $c->prepare_request
 194
 195 =cut
 196
 197 sub prepare_request {
 198     my ( $c, $cgi ) = @_;
 199     $c->cgi( $cgi || CGI->new );
 200     $c->cgi->_reset_globals;
 201 }
 202
 203 =item $c->prepare_uploads
 204
 205 =cut
 206
 207 sub prepare_uploads {
 208     my $c = shift;
 209
 210     my @uploads;
 211
 212     for my $param ( $c->cgi->param ) {
 213
 214         my @values = $c->cgi->param($param);
 215
 216         next unless ref( $values[0] );
 217
 218         for my $fh (@values) {
 219
 220             next unless my $size = ( stat $fh )[7];
 221
 222             my $info        = $c->cgi->uploadInfo($fh);
 223             my $tempname    = $c->cgi->tmpFileName($fh);
 224             my $type        = $info->{'Content-Type'};
 225             my $disposition = $info->{'Content-Disposition'};
 226             my $filename    = ( $disposition =~ / filename="([^;]*)"/ )[0];
 227
 228             my $upload = Catalyst::Request::Upload->new(
 229                 filename => $filename,
 230                 size     => $size,
 231                 tempname => $tempname,
 232                 type     => $type
 233             );
 234
 235             push( @uploads, $param, $upload );
 236         }
 237     }
 238
 239     $c->request->upload(@uploads);
 240 }
 241
 242 =item $c->run
 243
 244 =cut
 245
 246 sub run { shift->handler }
 247
 248 =back
 249
 250 =head1 SEE ALSO
 251
 252 L<Catalyst>.
 253
 254 =head1 AUTHOR
 255
 256 Sebastian Riedel, C<sri@cpan.org>
 257
 258 =head1 COPYRIGHT
 259
 260 This program is free software, you can redistribute it and/or modify it under
 261 the same terms as Perl itself.
 262
 263 =cut
 264
 265 1;