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