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_headers
  61
  62 =cut
  63
  64 sub finalize_headers {
  65     my $c = shift;
  66
  67     $c->response->header( Status => $c->response->status );
  68
  69     print $c->response->headers->as_string("\015\012");
  70     print "\015\012";
  71 }
  72
  73 =item $c->finalize_output
  74
  75 Prints the response output to STDOUT.
  76
  77 =cut
  78
  79 sub finalize_output {
  80     my $c = shift;
  81     print $c->response->output;
  82 }
  83
  84 =item $c->prepare_connection
  85
  86 =cut
  87
  88 sub prepare_connection {
  89     my $c = shift;
  90     $c->req->hostname( $ENV{REMOTE_HOST} );
  91     $c->req->address( $ENV{REMOTE_ADDR} );
  92 }
  93
  94 =item $c->prepare_headers
  95
  96 =cut
  97
  98 sub prepare_headers {
  99     my $c = shift;
 100
 101     while ( my ( $header, $value ) = each %ENV ) {
 102
 103         next unless $header =~ /^(HTTP|CONTENT)/i;
 104
 105         ( my $field = $header ) =~ s/^HTTPS?_//;
 106
 107         $c->req->headers->header( $field => $value );
 108     }
 109
 110     $c->req->method( $ENV{REQUEST_METHOD} || 'GET' );
 111 }
 112
 113 =item $c->prepare_parameters
 114
 115 =cut
 116
 117 sub prepare_parameters {
 118     my $c = shift;
 119
 120     my ( @params );
 121
 122     for my $param ( $c->cgi->url_param ) {
 123         for my $value (  $c->cgi->url_param($param) ) {
 124             push ( @params, $param, $value );
 125         }
 126     }
 127
 128     for my $param ( $c->cgi->param ) {
 129         for my $value (  $c->cgi->param($param) ) {
 130             push ( @params, $param, $value );
 131         }
 132     }
 133
 134     $c->req->_assign_values( $c->req->parameters, \@params );
 135 }
 136
 137 =item $c->prepare_path
 138
 139 =cut
 140
 141 sub prepare_path {
 142     my $c = shift;
 143
 144     my $base;
 145     {
 146         my $scheme = $ENV{HTTPS} ? 'https' : 'http';
 147         my $host   = $ENV{HTTP_HOST}   || $ENV{SERVER_NAME};
 148         my $port   = $ENV{SERVER_PORT} || 80;
 149         my $path   = $ENV{SCRIPT_NAME} || '/';
 150
 151         $base = URI->new;
 152         $base->scheme($scheme);
 153         $base->host($host);
 154         $base->port($port);
 155         $base->path($path);
 156
 157         $base = $base->canonical->as_string;
 158     }
 159
 160     my $path = $ENV{PATH_INFO} || '/';
 161     $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 162     $path =~ s/^\///;
 163
 164     $c->req->base($base);
 165     $c->req->path($path);
 166 }
 167
 168 =item $c->prepare_request
 169
 170 =cut
 171
 172 sub prepare_request {
 173     my $c = shift;
 174     $c->cgi( CGI->new );
 175     $c->cgi->_reset_globals;
 176 }
 177
 178 =item $c->prepare_uploads
 179
 180 =cut
 181
 182 sub prepare_uploads {
 183     my $c = shift;
 184
 185     my @uploads;
 186
 187     for my $param ( $c->cgi->param ) {
 188
 189         my @values = $c->cgi->param($param);
 190
 191         next unless ref( $values[0] );
 192
 193         for my $fh (@values) {
 194
 195             next unless my $size = ( stat $fh )[7];
 196
 197             my $info        = $c->cgi->uploadInfo($fh);
 198             my $tempname    = $c->cgi->tmpFileName($fh);
 199             my $type        = $info->{'Content-Type'};
 200             my $disposition = $info->{'Content-Disposition'};
 201             my $filename    = ( $disposition =~ / filename="([^;]*)"/ )[0];
 202
 203             my $upload = Catalyst::Request::Upload->new(
 204                 filename => $filename,
 205                 size     => $size,
 206                 tempname => $tempname,
 207                 type     => $type
 208             );
 209
 210             push( @uploads, $param, $upload );
 211         }
 212     }
 213
 214     $c->req->_assign_values( $c->req->uploads, \@uploads );
 215 }
 216
 217 =item $c->run
 218
 219 =cut
 220
 221 sub run { shift->handler }
 222
 223 =back
 224
 225 =head1 SEE ALSO
 226
 227 L<Catalyst>.
 228
 229 =head1 AUTHOR
 230
 231 Sebastian Riedel, C<sri@cpan.org>
 232
 233 =head1 COPYRIGHT
 234
 235 This program is free software, you can redistribute it and/or modify it under
 236 the same terms as Perl itself.
 237
 238 =cut
 239
 240 1;