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     for my $param ( $c->cgi->param ) {
 121         my @values = $c->cgi->param($param);
 122         $c->req->parameters->{$param} = ( @values > 1 ) ? \@values : $values[0];
 123     }
 124 }
 125
 126 =item $c->prepare_path
 127
 128 =cut
 129
 130 sub prepare_path {
 131     my $c = shift;
 132
 133     my $base;
 134     {
 135         my $scheme = $ENV{HTTPS} ? 'https' : 'http';
 136         my $host   = $ENV{HTTP_HOST}   || $ENV{SERVER_NAME};
 137         my $port   = $ENV{SERVER_PORT} || 80;
 138         my $path   = $ENV{SCRIPT_NAME} || '/';
 139
 140         $base = URI->new;
 141         $base->scheme($scheme);
 142         $base->host($host);
 143         $base->port($port);
 144         $base->path($path);
 145
 146         $base = $base->canonical->as_string;
 147     }
 148
 149     my $path = $ENV{PATH_INFO} || '/';
 150     $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 151     $path =~ s/^\///;
 152
 153     $c->req->base($base);
 154     $c->req->path($path);
 155 }
 156
 157 =item $c->prepare_request
 158
 159 =cut
 160
 161 sub prepare_request {
 162     my $c = shift;
 163     $c->cgi( CGI->new );
 164     $c->cgi->_reset_globals;
 165 }
 166
 167 =item $c->prepare_uploads
 168
 169 =cut
 170
 171 sub prepare_uploads {
 172     my $c = shift;
 173
 174     my @uploads;
 175
 176     for my $param ( $c->cgi->param ) {
 177
 178         my @values = $c->cgi->param($param);
 179
 180         next unless ref( $values[0] );
 181
 182         for my $fh (@values) {
 183
 184             next unless my $size = ( stat $fh )[7];
 185
 186             my $info        = $c->cgi->uploadInfo($fh);
 187             my $tempname    = $c->cgi->tmpFileName($fh);
 188             my $type        = $info->{'Content-Type'};
 189             my $disposition = $info->{'Content-Disposition'};
 190             my $filename    = ( $disposition =~ / filename="([^;]*)"/ )[0];
 191
 192             my $upload = {
 193                 fh       => $fh,
 194                 filename => $filename,
 195                 size     => $size,
 196                 tempname => $tempname,
 197                 type     => $type
 198             };
 199
 200             push( @uploads, $param, $upload );
 201         }
 202     }
 203
 204     $c->req->_assign_values( $c->req->uploads, \@uploads );
 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;