lib/Catalyst/Engine/CGI.pm

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