lib/Catalyst/Engine/CGI.pm

   1 package Catalyst::Engine::CGI;
   2
   3 use strict;
   4 use base 'Catalyst::Engine::CGI::Base';
   5
   6 use CGI;
   7
   8 __PACKAGE__->mk_accessors('cgi');
   9
  10 =head1 NAME
  11
  12 Catalyst::Engine::CGI - The CGI Engine
  13
  14 =head1 SYNOPSIS
  15
  16 A script using the Catalyst::Engine::CGI module might look like:
  17
  18     #!/usr/bin/perl -w
  19
  20     use strict;
  21     use lib '/path/to/MyApp/lib';
  22     use MyApp;
  23
  24     MyApp->run;
  25
  26 The application module (C<MyApp>) would use C<Catalyst>, which loads the
  27 appropriate engine module.
  28
  29 =head1 DESCRIPTION
  30
  31 This is the Catalyst engine specialized for the CGI environment (using the
  32 C<CGI> and C<CGI::Cookie> modules).  Normally Catalyst will select the
  33 appropriate engine according to the environment that it detects, however you
  34 can force Catalyst to use the CGI engine by specifying the following in your
  35 application module:
  36
  37     use Catalyst qw(-Engine=CGI);
  38
  39 The performance of this way of using Catalyst is not expected to be
  40 useful in production applications, but it may be helpful for development.
  41
  42 =head1 METHODS
  43
  44 =over 4
  45
  46 =item $c->cgi
  47
  48 Contains the C<CGI> object.
  49
  50 =back
  51
  52 =head1 OVERLOADED METHODS
  53
  54 This class overloads some methods from C<Catalyst::Engine::CGI::Base>.
  55
  56 =over 4
  57
  58 =item $c->prepare_body
  59
  60 =cut
  61
  62 sub prepare_body {
  63     my $c = shift;
  64
  65     # XXX this is undocumented in CGI.pm. If Content-Type is not
  66     # application/x-www-form-urlencoded or multipart/form-data
  67     # CGI.pm will read STDIN into a param, POSTDATA.
  68
  69     $c->request->body( $c->cgi->param('POSTDATA') );
  70 }
  71
  72 =item $c->prepare_parameters
  73
  74 =cut
  75
  76 sub prepare_parameters {
  77     my $c = shift;
  78
  79     my ( @params );
  80
  81     if ( $c->request->method eq 'POST' ) {
  82         for my $param ( $c->cgi->url_param ) {
  83             for my $value (  $c->cgi->url_param($param) ) {
  84                 push ( @params, $param, $value );
  85             }
  86         }
  87     }
  88
  89     for my $param ( $c->cgi->param ) {
  90         for my $value (  $c->cgi->param($param) ) {
  91             push ( @params, $param, $value );
  92         }
  93     }
  94
  95     $c->request->param(@params);
  96 }
  97
  98 =item $c->prepare_request
  99
 100 =cut
 101
 102 sub prepare_request {
 103     my ( $c, $object ) = @_;
 104
 105     my $cgi;
 106
 107     if ( defined($object) && ref($object) ) {
 108
 109         if ( $object->isa('Apache') ) {                   # MP 1.3
 110             $cgi = CGI->new($object);
 111         }
 112
 113         elsif ( $object->isa('Apache::RequestRec') ) {    # MP 1.99
 114             $cgi = CGI->new($object);
 115         }
 116
 117         elsif ( $object->isa('Apache2::RequestRec') ) {   # MP 2.00
 118             $cgi = CGI->new($object);
 119         }
 120
 121         elsif ( $object->isa('CGI') ) {
 122             $cgi = $object;
 123         }
 124
 125         else {
 126             my $class = ref($object);
 127             die( qq/Invalid argument $object/ );
 128         }
 129     }
 130
 131     $c->cgi( $cgi || CGI->new );
 132 }
 133
 134 =item $c->prepare_uploads
 135
 136 =cut
 137
 138 sub prepare_uploads {
 139     my $c = shift;
 140
 141     my @uploads;
 142
 143     for my $param ( $c->cgi->param ) {
 144
 145         my @values = $c->cgi->param($param);
 146
 147         next unless ref( $values[0] );
 148
 149         for my $fh (@values) {
 150
 151             next unless my $size = ( stat $fh )[7];
 152
 153             my $info        = $c->cgi->uploadInfo($fh);
 154             my $tempname    = $c->cgi->tmpFileName($fh);
 155             my $type        = $info->{'Content-Type'};
 156             my $disposition = $info->{'Content-Disposition'};
 157             my $filename    = ( $disposition =~ / filename="([^;]*)"/ )[0];
 158
 159             my $upload = Catalyst::Request::Upload->new(
 160                 filename => $filename,
 161                 size     => $size,
 162                 tempname => $tempname,
 163                 type     => $type
 164             );
 165
 166             push( @uploads, $param, $upload );
 167         }
 168     }
 169
 170     $c->request->upload(@uploads);
 171 }
 172
 173 =back
 174
 175 =head1 SEE ALSO
 176
 177 L<Catalyst> L<Catalyst::Engine> L<Catalyst::Engine::CGI::Base>.
 178
 179 =head1 AUTHOR
 180
 181 Sebastian Riedel, C<sri@cpan.org>
 182 Christian Hansen, C<ch@ngmedia.com>
 183
 184 =head1 COPYRIGHT
 185
 186 This program is free software, you can redistribute it and/or modify it under
 187 the same terms as Perl itself.
 188
 189 =cut
 190
 191 1;