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