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 require CGI::Cookie;
   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     #!/usr/bin/perl -w
  22
  23     use strict;
  24     use lib '/path/to/MyApp/lib';
  25     use MyApp;
  26
  27     MyApp->run;
  28
  29 See L<Catalyst>.
  30
  31 =head1 DESCRIPTION
  32
  33 This is the CGI engine for Catalyst.
  34
  35 The script shown above must be designated as a "Non-parsed Headers"
  36 script to function properly.
  37 To do this in Apache name the script starting with C<nph->.
  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 =head2 METHODS
  43
  44 =head3 run
  45
  46 To be called from a CGI script to start the Catalyst application.
  47
  48 =head3 cgi
  49
  50 This config parameter contains the C<CGI::Simple> object.
  51
  52 =head2 OVERLOADED METHODS
  53
  54 This class overloads some methods from C<Catalyst>.
  55
  56 =head3 finalize_headers
  57
  58 =cut
  59
  60 sub finalize_headers {
  61     my $c = shift;
  62     my %headers = ( -nph => 1 );
  63     $headers{-status} = $c->response->status if $c->response->status;
  64     for my $name ( $c->response->headers->header_field_names ) {
  65         $headers{"-$name"} = $c->response->headers->header($name);
  66     }
  67     my @cookies;
  68     while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
  69         push @cookies, $c->cgi->cookie(
  70             -name    => $name,
  71             -value   => $cookie->{value},
  72             -expires => $cookie->{expires},
  73             -domain  => $cookie->{domain},
  74             -path    => $cookie->{path},
  75             -secure  => $cookie->{secure} || 0
  76         );
  77     }
  78     $headers{-cookie} = \@cookies if @cookies;
  79     print $c->cgi->header(%headers);
  80 }
  81
  82 =head3 finalize_output
  83
  84 =cut
  85
  86 sub finalize_output {
  87     my $c = shift;
  88     print $c->response->output;
  89 }
  90
  91 =head3 prepare_cookies
  92
  93 =cut
  94
  95 sub prepare_cookies { shift->req->cookies( { CGI::Cookie->fetch } ) }
  96
  97 =head3 prepare_headers
  98
  99 =cut
 100
 101 sub prepare_headers {
 102     my $c = shift;
 103     $c->req->method( $c->cgi->request_method );
 104     for my $header ( $c->cgi->http ) {
 105         ( my $field = $header ) =~ s/^HTTPS?_//;
 106         $c->req->headers->header( $field => $c->cgi->http($header) );
 107     }
 108 }
 109
 110 =head3 prepare_parameters
 111
 112 =cut
 113
 114 sub prepare_parameters {
 115     my $c    = shift;
 116     my %vars = $c->cgi->Vars;
 117     while ( my ( $key, $value ) = each %vars ) {
 118         my @values = split "\0", $value;
 119         $vars{$key} = @values <= 1 ? $values[0] : \@values;
 120     }
 121     $c->req->parameters( {%vars} );
 122 }
 123
 124 =head3 prepare_path
 125
 126 =cut
 127
 128 sub prepare_path {
 129     my $c = shift;
 130     $c->req->path( $c->cgi->url( -absolute => 1, -path_info => 1 ) );
 131     my $loc = $c->cgi->url( -absolute => 1 );
 132     no warnings 'uninitialized';
 133     $c->req->{path} =~ s/^($loc)?\///;
 134     $c->req->{path} .= '/' if $c->req->path eq $loc;
 135     my $base = $c->cgi->url;
 136     if ( $ENV{CATALYST_TEST} ) {
 137         my $script = $c->cgi->script_name;
 138         $base =~ s/$script$//i;
 139     }
 140     $base = URI->new($base);
 141     $base->path('/') if ( $ENV{CATALYST_TEST} || !$base->path );
 142     $c->req->base( $base->as_string );
 143 }
 144
 145 =head3 prepare_request
 146
 147 =cut
 148
 149 sub prepare_request { shift->cgi( CGI::Simple->new ) }
 150
 151 =head3 prepare_uploads
 152
 153 =cut
 154
 155 sub prepare_uploads {
 156     my $c = shift;
 157     for my $name ( $c->cgi->upload ) {
 158         $c->req->uploads->{$name} = {
 159             fh   => $c->cgi->upload($name),
 160             size => $c->cgi->upload_info( $name, 'size' ),
 161             type => $c->cgi->upload_info( $name, 'mime' )
 162         };
 163     }
 164 }
 165
 166 sub run { shift->handler }
 167
 168 =head1 SEE ALSO
 169
 170 L<Catalyst>.
 171
 172 =head1 AUTHOR
 173
 174 Sebastian Riedel, C<sri@cpan.org>
 175
 176 =head1 COPYRIGHT
 177
 178 This program is free software, you can redistribute it and/or modify it under
 179 the same terms as Perl itself.
 180
 181 =cut
 182
 183 1;