lib/Catalyst/Engine/CGI/Base.pm

   1 package Catalyst::Engine::CGI::Base;
   2
   3 use strict;
   4 use base 'Catalyst::Engine';
   5
   6 use URI;
   7 use URI::http;
   8
   9 __PACKAGE__->mk_accessors('cgi');
  10
  11 =head1 NAME
  12
  13 Catalyst::Engine::CGI::Base - Base class for CGI Engines
  14
  15 =head1 DESCRIPTION
  16
  17 This is a base class for CGI engines.
  18
  19 =head1 METHODS
  20
  21 =over 4
  22
  23 =item $c->cgi
  24
  25 This config parameter contains the C<CGI> object.
  26
  27 =back
  28
  29 =head1 OVERLOADED METHODS
  30
  31 This class overloads some methods from C<Catalyst::Engine>.
  32
  33 =over 4
  34
  35 =item $c->finalize_body
  36
  37 Prints the response output to STDOUT.
  38
  39 =cut
  40
  41 sub finalize_body {
  42     my $c = shift;
  43     print $c->response->output;
  44 }
  45
  46 =item $c->finalize_headers
  47
  48 =cut
  49
  50 sub finalize_headers {
  51     my $c = shift;
  52
  53     $c->response->header( Status => $c->response->status );
  54
  55     print $c->response->headers->as_string("\015\012");
  56     print "\015\012";
  57 }
  58
  59 =item $c->prepare_connection
  60
  61 =cut
  62
  63 sub prepare_connection {
  64     my $c = shift;
  65     $c->request->address( $ENV{REMOTE_ADDR} );
  66     $c->request->hostname( $ENV{REMOTE_HOST} );
  67     $c->request->protocol( $ENV{SERVER_PROTOCOL} );
  68
  69     if ( $ENV{HTTPS} || $ENV{SERVER_PORT} == 443 ) {
  70         $c->request->secure(1);
  71     }
  72 }
  73
  74 =item $c->prepare_headers
  75
  76 =cut
  77
  78 sub prepare_headers {
  79     my $c = shift;
  80
  81     while ( my ( $header, $value ) = each %ENV ) {
  82
  83         next unless $header =~ /^(HTTP|CONTENT)/i;
  84
  85         ( my $field = $header ) =~ s/^HTTPS?_//;
  86
  87         $c->req->headers->header( $field => $value );
  88     }
  89
  90     $c->req->method( $ENV{REQUEST_METHOD} || 'GET' );
  91 }
  92
  93 =item $c->prepare_path
  94
  95 =cut
  96
  97 sub prepare_path {
  98     my $c = shift;
  99
 100     my $base;
 101     {
 102         my $scheme = $c->request->secure ? 'https' : 'http';
 103         my $host   = $ENV{HTTP_HOST}   || $ENV{SERVER_NAME};
 104         my $port   = $ENV{SERVER_PORT} || 80;
 105         my $path   = $ENV{SCRIPT_NAME} || '/';
 106
 107         unless ( $path =~ /\/$/ ) {
 108             $path .= '/';
 109         }
 110
 111         $base = URI->new;
 112         $base->scheme($scheme);
 113         $base->host($host);
 114         $base->port($port);
 115         $base->path($path);
 116
 117         $base = $base->canonical->as_string;
 118     }
 119
 120     my $path = $ENV{PATH_INFO} || '/';
 121     $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 122     $path =~ s/^\///;
 123
 124     $c->req->base($base);
 125     $c->req->path($path);
 126 }
 127
 128 =item $c->run
 129
 130 =cut
 131
 132 sub run { shift->handler }
 133
 134 =back
 135
 136 =head1 SEE ALSO
 137
 138 L<Catalyst>.
 139
 140 =head1 AUTHOR
 141
 142 Sebastian Riedel, C<sri@cpan.org>
 143 Christian Hansen, C<ch@ngmedia.com>
 144
 145 =head1 COPYRIGHT
 146
 147 This program is free software, you can redistribute it and/or modify it under
 148 the same terms as Perl itself.
 149
 150 =cut
 151
 152 1;