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     $c->request->user( $ENV{REMOTE_USER} );
  73
  74     if ( $ENV{HTTPS} && uc( $ENV{HTTPS} ) eq 'ON' ) {
  75         $c->request->secure(1);
  76     }
  77
  78     if ( $ENV{SERVER_PORT} == 443 ) {
  79         $c->request->secure(1);
  80     }
  81 }
  82
  83 =item $c->prepare_headers
  84
  85 =cut
  86
  87 sub prepare_headers {
  88     my $c = shift;
  89
  90     while ( my ( $header, $value ) = each %ENV ) {
  91
  92         next unless $header =~ /^(HTTP|CONTENT)/i;
  93
  94         ( my $field = $header ) =~ s/^HTTPS?_//;
  95
  96         $c->req->headers->header( $field => $value );
  97     }
  98
  99     $c->req->method( $ENV{REQUEST_METHOD} || 'GET' );
 100 }
 101
 102 =item $c->prepare_path
 103
 104 =cut
 105
 106 sub prepare_path {
 107     my $c = shift;
 108
 109     my $base;
 110     {
 111         my $scheme = $c->request->secure ? 'https' : 'http';
 112         my $host   = $ENV{HTTP_HOST}   || $ENV{SERVER_NAME};
 113         my $port   = $ENV{SERVER_PORT} || 80;
 114         my $path   = $ENV{SCRIPT_NAME} || '/';
 115
 116         unless ( $path =~ /\/$/ ) {
 117             $path .= '/';
 118         }
 119
 120         $base = URI->new;
 121         $base->scheme($scheme);
 122         $base->host($host);
 123         $base->port($port);
 124         $base->path($path);
 125
 126         $base = $base->canonical->as_string;
 127     }
 128
 129     my $location = $ENV{SCRIPT_NAME} || '/';
 130     my $path = $ENV{PATH_INFO} || '/';
 131     $path =~ s/^($location)?\///;
 132     $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 133     $path =~ s/^\///;
 134
 135     $c->req->base($base);
 136     $c->req->path($path);
 137 }
 138
 139 =item $c->run
 140
 141 =cut
 142
 143 sub run { shift->handler(@_) }
 144
 145 =back
 146
 147 =head1 SEE ALSO
 148
 149 L<Catalyst>.
 150
 151 =head1 AUTHOR
 152
 153 Sebastian Riedel, C<sri@cpan.org>
 154 Christian Hansen, C<ch@ngmedia.com>
 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;