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.
  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 However it also means that in a number of cases when the app isn't installed directly at a path, but instead
  59 is having paths rewritten into it (e.g. as a .cgi/fcgi in a public_html directory, with mod_rewrite in a
  60 .htaccess file, or when SSI is used to rewrite pages into the app, or when sub-paths of the app are exposed
  61 at other URIs than that which the app is 'normally' based at with C<mod_rewrite>), the resolution of
  62 C<< $c->request->base >> will be incorrect.
  63
  64 =head1 OVERLOADED METHODS
  65
  66 This class overloads some methods from C<Catalyst::Engine>.
  67
  68 =head2 $self->finalize_headers($c)
  69
  70 =cut
  71
  72 sub finalize_headers {
  73     my ( $self, $c ) = @_;
  74
  75     $c->response->header( Status => $c->response->status );
  76
  77     $self->_header_buf($c->response->headers->as_string("\015\012") . "\015\012");
  78 }
  79
  80 =head2 $self->prepare_connection($c)
  81
  82 =cut
  83
  84 sub prepare_connection {
  85     my ( $self, $c ) = @_;
  86     local (*ENV) = $self->env || \%ENV;
  87
  88     my $request = $c->request;
  89     $request->address( $ENV{REMOTE_ADDR} );
  90
  91   PROXY_CHECK:
  92     {
  93         unless ( ref($c)->config->{using_frontend_proxy} ) {
  94             last PROXY_CHECK if $ENV{REMOTE_ADDR} ne '127.0.0.1';
  95             last PROXY_CHECK if ref($c)->config->{ignore_frontend_proxy};
  96         }
  97         last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_FOR};
  98
  99         # If we are running as a backend server, the user will always appear
 100         # as 127.0.0.1. Select the most recent upstream IP (last in the list)
 101         my ($ip) = $ENV{HTTP_X_FORWARDED_FOR} =~ /([^,\s]+)$/;
 102         $request->address($ip);
 103         if ( defined $ENV{HTTP_X_FORWARDED_PORT} ) {
 104             $ENV{SERVER_PORT} = $ENV{HTTP_X_FORWARDED_PORT};
 105         }
 106     }
 107
 108     $request->hostname( $ENV{REMOTE_HOST} ) if exists $ENV{REMOTE_HOST};
 109     $request->protocol( $ENV{SERVER_PROTOCOL} );
 110     $request->user( $ENV{REMOTE_USER} );  # XXX: Deprecated. See Catalyst::Request for removal information
 111     $request->remote_user( $ENV{REMOTE_USER} );
 112     $request->method( $ENV{REQUEST_METHOD} );
 113
 114     if ( $ENV{HTTPS} && uc( $ENV{HTTPS} ) eq 'ON' ) {
 115         $request->secure(1);
 116     }
 117
 118     if ( $ENV{SERVER_PORT} == 443 ) {
 119         $request->secure(1);
 120     }
 121     binmode(STDOUT); # Ensure we are sending bytes.
 122 }
 123
 124 =head2 $self->prepare_headers($c)
 125
 126 =cut
 127
 128 sub prepare_headers {
 129     my ( $self, $c ) = @_;
 130     local (*ENV) = $self->env || \%ENV;
 131     my $headers = $c->request->headers;
 132     # Read headers from %ENV
 133     foreach my $header ( keys %ENV ) {
 134         next unless $header =~ /^(?:HTTP|CONTENT|COOKIE)/i;
 135         ( my $field = $header ) =~ s/^HTTPS?_//;
 136         $headers->header( $field => $ENV{$header} );
 137     }
 138 }
 139
 140 =head2 $self->prepare_path($c)
 141
 142 =cut
 143
 144 # Please don't touch this method without adding tests in
 145 # t/aggregate/unit_core_engine_cgi-prepare_path.t
 146 sub prepare_path {
 147     my ( $self, $c ) = @_;
 148     local (*ENV) = $self->env || \%ENV;
 149
 150     my $scheme = $c->request->secure ? 'https' : 'http';
 151     my $host      = $ENV{HTTP_HOST}   || $ENV{SERVER_NAME};
 152     my $port      = $ENV{SERVER_PORT} || 80;
 153     my $script_name = $ENV{SCRIPT_NAME};
 154     $script_name =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go if $script_name;
 155
 156     my $base_path;
 157     if ( exists $ENV{REDIRECT_URL} ) {
 158         $base_path = $ENV{REDIRECT_URL};
 159         $base_path =~ s/\Q$ENV{PATH_INFO}\E$//;
 160     }
 161     else {
 162         $base_path = $script_name || '/';
 163     }
 164
 165     # If we are running as a backend proxy, get the true hostname
 166   PROXY_CHECK:
 167     {
 168         unless ( ref($c)->config->{using_frontend_proxy} ) {
 169             last PROXY_CHECK if $host !~ /localhost|127.0.0.1/;
 170             last PROXY_CHECK if ref($c)->config->{ignore_frontend_proxy};
 171         }
 172         last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_HOST};
 173
 174         $host = $ENV{HTTP_X_FORWARDED_HOST};
 175
 176         # backend could be on any port, so
 177         # assume frontend is on the default port
 178         $port = $c->request->secure ? 443 : 80;
 179         if ( $ENV{HTTP_X_FORWARDED_PORT} ) {
 180             $port = $ENV{HTTP_X_FORWARDED_PORT};
 181         }
 182     }
 183
 184     my $path_info   = $ENV{PATH_INFO};
 185     if ($c->config->{use_request_uri_for_path}) {
 186         # RFC 3875: "Unlike a URI path, the PATH_INFO is not URL-encoded,
 187         # and cannot contain path-segment parameters." This means PATH_INFO
 188         # is always decoded, and the script can't distinguish / vs %2F.
 189         # See https://issues.apache.org/bugzilla/show_bug.cgi?id=35256
 190         # Here we try to resurrect the original encoded URI from REQUEST_URI.
 191         if (my $req_uri = $ENV{REQUEST_URI}) {
 192             if (defined $script_name) {
 193                 $req_uri =~ s/^\Q$script_name\E//;
 194             }
 195             $req_uri =~ s/\?.*$//;
 196             $path_info = $req_uri if $req_uri;
 197         }
 198     }
 199
 200     # set the request URI
 201     my $path = $base_path . ( $path_info || '' );
 202     $path =~ s{^/+}{};
 203
 204     # Using URI directly is way too slow, so we construct the URLs manually
 205     my $uri_class = "URI::$scheme";
 206
 207     # HTTP_HOST will include the port even if it's 80/443
 208     $host =~ s/:(?:80|443)$//;
 209
 210     if ( $port !~ /^(?:80|443)$/ && $host !~ /:/ ) {
 211         $host .= ":$port";
 212     }
 213
 214     # Escape the path
 215     $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
 216     $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
 217
 218     my $query = $ENV{QUERY_STRING} ? '?' . $ENV{QUERY_STRING} : '';
 219     my $uri   = $scheme . '://' . $host . '/' . $path . $query;
 220
 221     $c->request->uri( bless(\$uri, $uri_class)->canonical );
 222
 223     # set the base URI
 224     # base must end in a slash
 225     $base_path .= '/' unless $base_path =~ m{/$};
 226
 227     my $base_uri = $scheme . '://' . $host . $base_path;
 228
 229     $c->request->base( bless \$base_uri, $uri_class );
 230 }
 231
 232 =head2 $self->prepare_query_parameters($c)
 233
 234 =cut
 235
 236 around prepare_query_parameters => sub {
 237     my $orig = shift;
 238     my ( $self, $c ) = @_;
 239     local (*ENV) = $self->env || \%ENV;
 240
 241     if ( $ENV{QUERY_STRING} ) {
 242         $self->$orig( $c, $ENV{QUERY_STRING} );
 243     }
 244 };
 245
 246 =head2 $self->prepare_request($c, (env => \%env))
 247
 248 =cut
 249
 250 sub prepare_request {
 251     my ( $self, $c, %args ) = @_;
 252
 253     if ( $args{env} ) {
 254         $self->env( $args{env} );
 255     }
 256 }
 257
 258 =head2 $self->prepare_write($c)
 259
 260 Enable autoflush on the output handle for CGI-based engines.
 261
 262 =cut
 263
 264 around prepare_write => sub {
 265     *STDOUT->autoflush(1);
 266     return shift->(@_);
 267 };
 268
 269 =head2 $self->write($c, $buffer)
 270
 271 Writes the buffer to the client.
 272
 273 =cut
 274
 275 around write => sub {
 276     my $orig = shift;
 277     my ( $self, $c, $buffer ) = @_;
 278
 279     # Prepend the headers if they have not yet been sent
 280     if ( $self->_has_header_buf ) {
 281         $buffer = $self->_clear_header_buf . $buffer;
 282     }
 283
 284     return $self->$orig( $c, $buffer );
 285 };
 286
 287 =head2 $self->read_chunk($c, $buffer, $length)
 288
 289 =cut
 290
 291 sub read_chunk { shift; shift; *STDIN->sysread(@_); }
 292
 293 =head2 $self->run
 294
 295 =cut
 296
 297 sub run { shift; shift->handle_request( env => \%ENV ) }
 298
 299 =head1 SEE ALSO
 300
 301 L<Catalyst>, L<Catalyst::Engine>
 302
 303 =head1 AUTHORS
 304
 305 Catalyst Contributors, see Catalyst.pm
 306
 307 =head1 COPYRIGHT
 308
 309 This library is free software. You can redistribute it and/or modify it under
 310 the same terms as Perl itself.
 311
 312 =cut
 313 no Moose;
 314
 315 1;