lib/Catalyst/Engine/CGI.pm

   1 package Catalyst::Engine::CGI;
   2
   3 use strict;
   4 use base 'Catalyst::Engine';
   5 use URI;
   6 use URI::http;
   7
   8 require CGI::Simple;
   9
  10 $CGI::Simple::POST_MAX        = 1048576;
  11 $CGI::Simple::DISABLE_UPLOADS = 0;
  12
  13 __PACKAGE__->mk_accessors('cgi');
  14
  15 =head1 NAME
  16
  17 Catalyst::Engine::CGI - The CGI Engine
  18
  19 =head1 SYNOPSIS
  20
  21 A script using the Catalyst::Engine::CGI module might look like:
  22
  23     #!/usr/bin/perl -w
  24
  25     use strict;
  26     use lib '/path/to/MyApp/lib';
  27     use MyApp;
  28
  29     MyApp->run;
  30
  31 The application module (C<MyApp>) would use C<Catalyst>, which loads the
  32 appropriate engine module.
  33
  34 =head1 DESCRIPTION
  35
  36 This is the Catalyst engine specialized for the CGI environment (using the
  37 C<CGI::Simple> and C<CGI::Cookie> modules).  Normally Catalyst will select the
  38 appropriate engine according to the environment that it detects, however you
  39 can force Catalyst to use the CGI engine by specifying the following in your
  40 application module:
  41
  42     use Catalyst qw(-Engine=CGI);
  43
  44 The performance of this way of using Catalyst is not expected to be
  45 useful in production applications, but it may be helpful for development.
  46
  47 =head1 METHODS
  48
  49 =over 4
  50
  51 =item $c->cgi
  52
  53 This config parameter contains the C<CGI::Simple> object.
  54
  55 =back
  56
  57 =head1 OVERLOADED METHODS
  58
  59 This class overloads some methods from C<Catalyst::Engine>.
  60
  61 =over 4
  62
  63 =item $c->finalize_headers
  64
  65 =cut
  66
  67 sub finalize_headers {
  68     my $c = shift;
  69     my %headers;
  70
  71     $headers{-status} = $c->response->status if $c->response->status;
  72
  73     for my $name ( $c->response->headers->header_field_names ) {
  74         $headers{"-$name"} = $c->response->header($name);
  75     }
  76
  77     print $c->cgi->header(%headers);
  78 }
  79
  80 =item $c->finalize_output
  81
  82 Prints the response output to STDOUT.
  83
  84 =cut
  85
  86 sub finalize_output {
  87     my $c = shift;
  88     print $c->response->output;
  89 }
  90
  91 =item $c->prepare_connection
  92
  93 =cut
  94
  95 sub prepare_connection {
  96     my $c = shift;
  97     $c->req->hostname( $c->cgi->remote_host );
  98     $c->req->address( $c->cgi->remote_addr );
  99 }
 100
 101 =item $c->prepare_headers
 102
 103 =cut
 104
 105 sub prepare_headers {
 106     my $c = shift;
 107     $c->req->method( $c->cgi->request_method );
 108     for my $header ( $c->cgi->http ) {
 109         ( my $field = $header ) =~ s/^HTTPS?_//;
 110         $c->req->headers->header( $field => $c->cgi->http($header) );
 111     }
 112     $c->req->headers->header( 'Content-Type'   => $c->cgi->content_type );
 113     $c->req->headers->header( 'Content-Length' => $c->cgi->content_length );
 114 }
 115
 116 =item $c->prepare_parameters
 117
 118 =cut
 119
 120 sub prepare_parameters {
 121     my $c    = shift;
 122
 123     $c->cgi->parse_query_string;
 124
 125     my %vars = $c->cgi->Vars;
 126     while ( my ( $key, $value ) = each %vars ) {
 127         my @values = split "\0", $value;
 128         $vars{$key} = @values <= 1 ? $values[0] : \@values;
 129     }
 130     $c->req->parameters( {%vars} );
 131 }
 132
 133 =item $c->prepare_path
 134
 135 =cut
 136
 137 sub prepare_path {
 138     my $c = shift;
 139
 140     my $base;
 141     {
 142         my $scheme = $ENV{HTTPS} ? 'https' : 'http';
 143         my $host   = $ENV{HTTP_HOST} || $ENV{SERVER_NAME};
 144         my $port   = $ENV{SERVER_PORT} || 80;
 145         my $path   = $ENV{SCRIPT_NAME} || '/';
 146
 147         $base = URI->new;
 148         $base->scheme($scheme);
 149         $base->host($host);
 150         $base->port($port);
 151         $base->path($path);
 152
 153         $base = $base->canonical->as_string;
 154     }
 155
 156     my $path = $ENV{PATH_INFO} || '/';
 157     $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 158     $path =~  s/^\///;
 159
 160     $c->req->base($base);
 161     $c->req->path($path);
 162 }
 163
 164 =item $c->prepare_request
 165
 166 =cut
 167
 168 sub prepare_request { shift->cgi( CGI::Simple->new ) }
 169
 170 =item $c->prepare_uploads
 171
 172 =cut
 173
 174 sub prepare_uploads {
 175     my $c = shift;
 176     for my $name ( $c->cgi->upload ) {
 177         next unless defined $name;
 178         $c->req->uploads->{$name} = {
 179             fh   => $c->cgi->upload($name),
 180             size => $c->cgi->upload_info( $name, 'size' ),
 181             type => $c->cgi->upload_info( $name, 'mime' )
 182         };
 183     }
 184 }
 185
 186 =item $c->run
 187
 188 =cut
 189
 190 sub run { shift->handler }
 191
 192 =back
 193
 194 =head1 SEE ALSO
 195
 196 L<Catalyst>.
 197
 198 =head1 AUTHOR
 199
 200 Sebastian Riedel, C<sri@cpan.org>
 201
 202 =head1 COPYRIGHT
 203
 204 This program is free software, you can redistribute it and/or modify it under
 205 the same terms as Perl itself.
 206
 207 =cut
 208
 209 1;