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 = Catalyst::Request::Upload->new(
 193                 filename => $filename,
 194                 size     => $size,
 195                 tempname => $tempname,
 196                 type     => $type
 197             );
 198
 199             push( @uploads, $param, $upload );
 200         }
 201     }
 202
 203     $c->req->_assign_values( $c->req->uploads, \@uploads );
 204 }
 205
 206 =item $c->run
 207
 208 =cut
 209
 210 sub run { shift->handler }
 211
 212 =back
 213
 214 =head1 SEE ALSO
 215
 216 L<Catalyst>.
 217
 218 =head1 AUTHOR
 219
 220 Sebastian Riedel, C<sri@cpan.org>
 221
 222 =head1 COPYRIGHT
 223
 224 This program is free software, you can redistribute it and/or modify it under
 225 the same terms as Perl itself.
 226
 227 =cut
 228
 229 1;