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