lib/Catalyst/Engine/CGI.pm

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