lib/Catalyst/Engine/CGI/Base.pm

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