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