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         $base = URI->new;
 173         $base->scheme($scheme);
 174         $base->host($host);
 175         $base->port($port);
 176         $base->path($path);
 177
 178         $base = $base->canonical->as_string;
 179     }
 180
 181     my $path = $ENV{PATH_INFO} || '/';
 182     $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 183     $path =~ s/^\///;
 184
 185     $c->req->base($base);
 186     $c->req->path($path);
 187 }
 188
 189 =item $c->prepare_request
 190
 191 =cut
 192
 193 sub prepare_request {
 194     my ( $c, $cgi ) = @_;
 195     $c->cgi( $cgi || CGI->new );
 196     $c->cgi->_reset_globals;
 197 }
 198
 199 =item $c->prepare_uploads
 200
 201 =cut
 202
 203 sub prepare_uploads {
 204     my $c = shift;
 205
 206     my @uploads;
 207
 208     for my $param ( $c->cgi->param ) {
 209
 210         my @values = $c->cgi->param($param);
 211
 212         next unless ref( $values[0] );
 213
 214         for my $fh (@values) {
 215
 216             next unless my $size = ( stat $fh )[7];
 217
 218             my $info        = $c->cgi->uploadInfo($fh);
 219             my $tempname    = $c->cgi->tmpFileName($fh);
 220             my $type        = $info->{'Content-Type'};
 221             my $disposition = $info->{'Content-Disposition'};
 222             my $filename    = ( $disposition =~ / filename="([^;]*)"/ )[0];
 223
 224             my $upload = Catalyst::Request::Upload->new(
 225                 filename => $filename,
 226                 size     => $size,
 227                 tempname => $tempname,
 228                 type     => $type
 229             );
 230
 231             push( @uploads, $param, $upload );
 232         }
 233     }
 234
 235     $c->request->upload(@uploads);
 236 }
 237
 238 =item $c->run
 239
 240 =cut
 241
 242 sub run { shift->handler }
 243
 244 =back
 245
 246 =head1 SEE ALSO
 247
 248 L<Catalyst>.
 249
 250 =head1 AUTHOR
 251
 252 Sebastian Riedel, C<sri@cpan.org>
 253
 254 =head1 COPYRIGHT
 255
 256 This program is free software, you can redistribute it and/or modify it under
 257 the same terms as Perl itself.
 258
 259 =cut
 260
 261 1;