lib/Catalyst/Engine/CGI.pm

   1 package Catalyst::Engine::CGI;
   2
   3 use Moose;
   4 extends 'Catalyst::Engine';
   5
   6 has _header_buf => (is => 'rw', clearer => '_clear_header_buf', predicate => '_has_header_buf');
   7
   8 =head1 NAME
   9
  10 Catalyst::Engine::CGI - The CGI Engine
  11
  12 =head1 SYNOPSIS
  13
  14 A script using the Catalyst::Engine::CGI module might look like:
  15
  16     #!/usr/bin/perl -w
  17
  18     use strict;
  19     use lib '/path/to/MyApp/lib';
  20     use MyApp;
  21
  22     MyApp->run;
  23
  24 The application module (C<MyApp>) would use C<Catalyst>, which loads the
  25 appropriate engine module.
  26
  27 =head1 DESCRIPTION
  28
  29 This is the Catalyst engine specialized for the CGI environment.
  30
  31 =head1 PATH DECODING
  32
  33 Most web server environments pass the requested path to the application using environment variables,
  34 from which Catalyst has to reconstruct the request base (i.e. the top level path to / in the application,
  35 exposed as C<< $c->request->base >>) and the request path below that base.
  36
  37 There are two methods of doing this, both of which have advantages and disadvantages. Which method is used
  38 is determined by the C<< $c->config(use_request_uri_for_path) >> setting (which can either be true or false).
  39
  40 =head2 use_request_uri_for_path => 0
  41
  42 This is the default (and the) traditional method that Catalyst has used for determining the path information.
  43 The path is synthesised from a combination of the C<PATH_INFO> and C<SCRIPT_NAME> environment variables.
  44 The allows the application to behave correctly when C<mod_rewrite> is being used to redirect requests
  45 into the application, as these variables are adjusted by mod_rewrite to take account for the redirect.
  46
  47 However this method has the major disadvantage that it is impossible to correctly decode some elements
  48 of the path, as RFC 3875 says: "C<< Unlike a URI path, the PATH_INFO is not URL-encoded, and cannot
  49 contain path-segment parameters. >>" This means PATH_INFO is B<always> decoded, and therefore Catalyst
  50 can't distinguish / vs %2F in paths (in addition to other encoded values).
  51
  52 =head2 use_request_uri_for_path => 1
  53
  54 This method uses the C<REQUEST_URI> and C<SCRIPT_NAME> environment variables. As C<REQUEST_URI> is never
  55 decoded, this means that applications using this mode can correctly handle URIs including the %2F character
  56 (i.e. with C<AllowEncodedSlashes> set to C<On> in Apache).
  57
  58 Given that this method of path resolution is provably more correct, it is recommended that you use
  59 this unless you have a specific need to deploy your application in a non-standard environment, and you are
  60 aware of the implications of not being able to handle encoded URI paths correctly.
  61
  62 However it also means that in a number of cases when the app isn't installed directly at a path, but instead
  63 is having paths rewritten into it (e.g. as a .cgi/fcgi in a public_html directory, with mod_rewrite in a
  64 .htaccess file, or when SSI is used to rewrite pages into the app, or when sub-paths of the app are exposed
  65 at other URIs than that which the app is 'normally' based at with C<mod_rewrite>), the resolution of
  66 C<< $c->request->base >> will be incorrect.
  67
  68 =head1 OVERLOADED METHODS
  69
  70 This class overloads some methods from C<Catalyst::Engine>.
  71
  72 =head2 $self->finalize_headers($c)
  73
  74 =cut
  75
  76 sub finalize_headers {
  77     my ( $self, $c ) = @_;
  78
  79     $c->response->header( Status => $c->response->status );
  80
  81     $self->_header_buf($c->response->headers->as_string("\015\012") . "\015\012");
  82 }
  83
  84 =head2 $self->prepare_connection($c)
  85
  86 =cut
  87
  88 sub prepare_connection {
  89     my ( $self, $c ) = @_;
  90     local (*ENV) = $self->env || \%ENV;
  91
  92     my $request = $c->request;
  93     $request->address( $ENV{REMOTE_ADDR} );
  94
  95   PROXY_CHECK:
  96     {
  97         unless ( ref($c)->config->{using_frontend_proxy} ) {
  98             last PROXY_CHECK if $ENV{REMOTE_ADDR} ne '127.0.0.1';
  99             last PROXY_CHECK if ref($c)->config->{ignore_frontend_proxy};
 100         }
 101         last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_FOR};
 102
 103         # If we are running as a backend server, the user will always appear
 104         # as 127.0.0.1. Select the most recent upstream IP (last in the list)
 105         my ($ip) = $ENV{HTTP_X_FORWARDED_FOR} =~ /([^,\s]+)$/;
 106         $request->address($ip);
 107         if ( defined $ENV{HTTP_X_FORWARDED_PORT} ) {
 108             $ENV{SERVER_PORT} = $ENV{HTTP_X_FORWARDED_PORT};
 109         }
 110     }
 111
 112     $request->hostname( $ENV{REMOTE_HOST} ) if exists $ENV{REMOTE_HOST};
 113     $request->protocol( $ENV{SERVER_PROTOCOL} );
 114     $request->user( $ENV{REMOTE_USER} );  # XXX: Deprecated. See Catalyst::Request for removal information
 115     $request->remote_user( $ENV{REMOTE_USER} );
 116     $request->method( $ENV{REQUEST_METHOD} );
 117
 118     if ( $ENV{HTTPS} && uc( $ENV{HTTPS} ) eq 'ON' ) {
 119         $request->secure(1);
 120     }
 121
 122     if ( $ENV{SERVER_PORT} == 443 ) {
 123         $request->secure(1);
 124     }
 125     binmode(STDOUT); # Ensure we are sending bytes.
 126 }
 127
 128 =head2 $self->prepare_headers($c)
 129
 130 =cut
 131
 132 sub prepare_headers {
 133     my ( $self, $c ) = @_;
 134     local (*ENV) = $self->env || \%ENV;
 135     my $headers = $c->request->headers;
 136     # Read headers from %ENV
 137     foreach my $header ( keys %ENV ) {
 138         next unless $header =~ /^(?:HTTP|CONTENT|COOKIE)/i;
 139         ( my $field = $header ) =~ s/^HTTPS?_//;
 140         $headers->header( $field => $ENV{$header} );
 141     }
 142 }
 143
 144 =head2 $self->prepare_path($c)
 145
 146 =cut
 147
 148 # Please don't touch this method without adding tests in
 149 # t/aggregate/unit_core_engine_cgi-prepare_path.t
 150 sub prepare_path {
 151     my ( $self, $c ) = @_;
 152     local (*ENV) = $self->env || \%ENV;
 153
 154     my $scheme = $c->request->secure ? 'https' : 'http';
 155     my $host      = $ENV{HTTP_HOST}   || $ENV{SERVER_NAME};
 156     my $port      = $ENV{SERVER_PORT} || 80;
 157     my $script_name = $ENV{SCRIPT_NAME};
 158     $script_name =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go if $script_name;
 159
 160     my $base_path;
 161     if ( exists $ENV{REDIRECT_URL} ) {
 162         $base_path = $ENV{REDIRECT_URL};
 163         $base_path =~ s/\Q$ENV{PATH_INFO}\E$//;
 164     }
 165     else {
 166         $base_path = $script_name || '/';
 167     }
 168
 169     # If we are running as a backend proxy, get the true hostname
 170   PROXY_CHECK:
 171     {
 172         unless ( ref($c)->config->{using_frontend_proxy} ) {
 173             last PROXY_CHECK if $host !~ /localhost|127.0.0.1/;
 174             last PROXY_CHECK if ref($c)->config->{ignore_frontend_proxy};
 175         }
 176         last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_HOST};
 177
 178         $host = $ENV{HTTP_X_FORWARDED_HOST};
 179
 180         # backend could be on any port, so
 181         # assume frontend is on the default port
 182         $port = $c->request->secure ? 443 : 80;
 183         if ( $ENV{HTTP_X_FORWARDED_PORT} ) {
 184             $port = $ENV{HTTP_X_FORWARDED_PORT};
 185         }
 186     }
 187
 188     my $path_info   = $ENV{PATH_INFO};
 189     if ($c->config->{use_request_uri_for_path}) {
 190         # RFC 3875: "Unlike a URI path, the PATH_INFO is not URL-encoded,
 191         # and cannot contain path-segment parameters." This means PATH_INFO
 192         # is always decoded, and the script can't distinguish / vs %2F.
 193         # See https://issues.apache.org/bugzilla/show_bug.cgi?id=35256
 194         # Here we try to resurrect the original encoded URI from REQUEST_URI.
 195         if (my $req_uri = $ENV{REQUEST_URI}) {
 196             if (defined $script_name) {
 197                 $req_uri =~ s/^\Q$script_name\E//;
 198             }
 199             $req_uri =~ s/\?.*$//;
 200             $path_info = $req_uri if $req_uri;
 201         }
 202     }
 203
 204     # set the request URI
 205     my $path = $base_path . ( $path_info || '' );
 206     $path =~ s{^/+}{};
 207
 208     # Using URI directly is way too slow, so we construct the URLs manually
 209     my $uri_class = "URI::$scheme";
 210
 211     # HTTP_HOST will include the port even if it's 80/443
 212     $host =~ s/:(?:80|443)$//;
 213
 214     if ( $port !~ /^(?:80|443)$/ && $host !~ /:/ ) {
 215         $host .= ":$port";
 216     }
 217
 218     # Escape the path
 219     $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
 220     $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
 221
 222     my $query = $ENV{QUERY_STRING} ? '?' . $ENV{QUERY_STRING} : '';
 223     my $uri   = $scheme . '://' . $host . '/' . $path . $query;
 224
 225     $c->request->uri( bless(\$uri, $uri_class)->canonical );
 226
 227     # set the base URI
 228     # base must end in a slash
 229     $base_path .= '/' unless $base_path =~ m{/$};
 230
 231     my $base_uri = $scheme . '://' . $host . $base_path;
 232
 233     $c->request->base( bless \$base_uri, $uri_class );
 234 }
 235
 236 =head2 $self->prepare_query_parameters($c)
 237
 238 =cut
 239
 240 around prepare_query_parameters => sub {
 241     my $orig = shift;
 242     my ( $self, $c ) = @_;
 243     local (*ENV) = $self->env || \%ENV;
 244
 245     if ( $ENV{QUERY_STRING} ) {
 246         $self->$orig( $c, $ENV{QUERY_STRING} );
 247     }
 248 };
 249
 250 =head2 $self->prepare_request($c, (env => \%env))
 251
 252 =cut
 253
 254 sub prepare_request {
 255     my ( $self, $c, %args ) = @_;
 256
 257     if ( $args{env} ) {
 258         $self->env( $args{env} );
 259     }
 260 }
 261
 262 =head2 $self->prepare_write($c)
 263
 264 Enable autoflush on the output handle for CGI-based engines.
 265
 266 =cut
 267
 268 around prepare_write => sub {
 269     *STDOUT->autoflush(1);
 270     return shift->(@_);
 271 };
 272
 273 =head2 $self->write($c, $buffer)
 274
 275 Writes the buffer to the client.
 276
 277 =cut
 278
 279 around write => sub {
 280     my $orig = shift;
 281     my ( $self, $c, $buffer ) = @_;
 282
 283     # Prepend the headers if they have not yet been sent
 284     if ( $self->_has_header_buf ) {
 285         $buffer = $self->_clear_header_buf . $buffer;
 286     }
 287
 288     return $self->$orig( $c, $buffer );
 289 };
 290
 291 =head2 $self->read_chunk($c, $buffer, $length)
 292
 293 =cut
 294
 295 sub read_chunk { shift; shift; *STDIN->sysread(@_); }
 296
 297 =head2 $self->run
 298
 299 =cut
 300
 301 sub run { shift; shift->handle_request( env => \%ENV ) }
 302
 303 =head1 SEE ALSO
 304
 305 L<Catalyst>, L<Catalyst::Engine>
 306
 307 =head1 AUTHORS
 308
 309 Catalyst Contributors, see Catalyst.pm
 310
 311 =head1 COPYRIGHT
 312
 313 This library is free software. You can redistribute it and/or modify it under
 314 the same terms as Perl itself.
 315
 316 =cut
 317 no Moose;
 318
 319 1;