lib/Catalyst/Engine.pm

   1 package Catalyst::Engine;
   2
   3 use Moose;
   4 with 'MooseX::Emulate::Class::Accessor::Fast';
   5
   6 use CGI::Simple::Cookie;
   7 use Data::Dump qw/dump/;
   8 use Errno 'EWOULDBLOCK';
   9 use HTML::Entities;
  10 use HTTP::Body;
  11 use HTTP::Headers;
  12 use URI::QueryParam;
  13 use Plack::Loader;
  14 use Catalyst::EngineLoader;
  15 use Encode ();
  16 use Plack::Request::Upload;
  17 use Hash::MultiValue;
  18 use utf8;
  19
  20 use namespace::clean -except => 'meta';
  21
  22 # Amount of data to read from input on each pass
  23 our $CHUNKSIZE = 64 * 1024;
  24
  25 # XXX - this is only here for compat, do not use!
  26 has env => ( is => 'rw', writer => '_set_env' );
  27 my $WARN_ABOUT_ENV = 0;
  28 around env => sub {
  29   my ($orig, $self, @args) = @_;
  30   if(@args) {
  31     warn "env as a writer is deprecated, you probably need to upgrade Catalyst::Engine::PSGI"
  32       unless $WARN_ABOUT_ENV++;
  33     return $self->_set_env(@args);
  34   }
  35   return $self->$orig;
  36 };
  37
  38 # XXX - Only here for Engine::PSGI compat
  39 sub prepare_connection {
  40     my ($self, $ctx) = @_;
  41     $ctx->request->prepare_connection;
  42 }
  43
  44 =head1 NAME
  45
  46 Catalyst::Engine - The Catalyst Engine
  47
  48 =head1 SYNOPSIS
  49
  50 See L<Catalyst>.
  51
  52 =head1 DESCRIPTION
  53
  54 =head1 METHODS
  55
  56
  57 =head2 $self->finalize_body($c)
  58
  59 Finalize body.  Prints the response output as blocking stream if it looks like
  60 a filehandle, otherwise write it out all in one go.  If there is no body in
  61 the response, we assume you are handling it 'manually', such as for nonblocking
  62 style or asynchronous streaming responses.  You do this by calling L</write>
  63 several times (which sends HTTP headers if needed) or you close over
  64 C<< $response->write_fh >>.
  65
  66 See L<Catalyst::Response/write> and L<Catalyst::Response/write_fh> for more.
  67
  68 =cut
  69
  70 sub finalize_body {
  71     my ( $self, $c ) = @_;
  72     my $res = $c->response; # We use this all over
  73
  74     ## If we've asked for the write 'filehandle' that means the application is
  75     ## doing something custom and is expected to close the response
  76     return if $res->_has_write_fh;
  77
  78     my $body = $res->body; # save some typing
  79     if($res->_has_response_cb) {
  80         ## we have not called the response callback yet, so we are safe to send
  81         ## the whole body to PSGI
  82
  83         my @headers;
  84         $res->headers->scan(sub { push @headers, @_ });
  85
  86         # We need to figure out what kind of body we have and normalize it to something
  87         # PSGI can deal with
  88         if(defined $body) {
  89             # Handle objects first
  90             if(blessed($body)) {
  91                 if($body->can('getline')) {
  92                     # Body is an IO handle that meets the PSGI spec.  Nothing to normalize
  93                 } elsif($body->can('read')) {
  94
  95                     # In the past, Catalyst only looked for ->read not ->getline.  It is very possible
  96                     # that one might have an object that respected read but did not have getline.
  97                     # As a result, we need to handle this case for backcompat.
  98
  99                     # We will just do the old loop for now.  In a future version of Catalyst this support
 100                     # will be removed and one will have to rewrite their custom object or use
 101                     # Plack::Middleware::AdaptFilehandleRead.  In anycase support for this is officially
 102                     # deprecated and described as such as of 5.90060
 103
 104                     my $got;
 105                     do {
 106                         $got = read $body, my ($buffer), $CHUNKSIZE;
 107                         $got = 0 unless $self->write($c, $buffer );
 108                     } while $got > 0;
 109
 110                     close $body;
 111                     return;
 112                 } else {
 113                     # Looks like for  backcompat reasons we need to be able to deal
 114                     # with stringyfiable objects.
 115                     $body = ["$body"];
 116                 }
 117             } elsif(ref $body) {
 118                 if( (ref($body) eq 'GLOB') or (ref($body) eq 'ARRAY')) {
 119                   # Again, PSGI can just accept this, no transform needed.  We don't officially
 120                   # document the body as arrayref at this time (and there's not specific test
 121                   # cases.  we support it because it simplifies some plack compatibility logic
 122                   # and we might make it official at some point.
 123                 } else {
 124                    $c->log->error("${\ref($body)} is not a valid value for Response->body");
 125                    return;
 126                 }
 127             } else {
 128                 # Body is defined and not an object or reference.  We assume a simple value
 129                 # and wrap it in an array for PSGI
 130                 $body = [$body];
 131             }
 132         } else {
 133             # There's no body...
 134             $body = [];
 135         }
 136
 137         $res->_response_cb->([ $res->status, \@headers, $body]);
 138         $res->_clear_response_cb;
 139
 140     } else {
 141         ## Now, if there's no response callback anymore, that means someone has
 142         ## called ->write in order to stream 'some stuff along the way'.  I think
 143         ## for backcompat we still need to handle a ->body.  I guess I could see
 144         ## someone calling ->write to presend some stuff, and then doing the rest
 145         ## via ->body, like in a template.
 146
 147         ## We'll just use the old, existing code for this (or most of it)
 148
 149         if(my $body = $res->body) {
 150
 151           if ( blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
 152
 153               ## In this case we have no choice and will fall back on the old
 154               ## manual streaming stuff.  Not optimal.  This is deprecated as of 5.900560+
 155
 156               my $got;
 157               do {
 158                   $got = read $body, my ($buffer), $CHUNKSIZE;
 159                   $got = 0 unless $self->write($c, $buffer );
 160               } while $got > 0;
 161
 162               close $body;
 163           }
 164           else {
 165               $self->write($c, $body );
 166           }
 167         }
 168
 169         $res->_writer->close;
 170         $res->_clear_writer;
 171     }
 172
 173     return;
 174 }
 175
 176 =head2 $self->finalize_cookies($c)
 177
 178 Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
 179 response headers.
 180
 181 =cut
 182
 183 sub finalize_cookies {
 184     my ( $self, $c ) = @_;
 185
 186     my @cookies;
 187     my $response = $c->response;
 188
 189     foreach my $name (keys %{ $response->cookies }) {
 190
 191         my $val = $response->cookies->{$name};
 192
 193         my $cookie = (
 194             blessed($val)
 195             ? $val
 196             : CGI::Simple::Cookie->new(
 197                 -name    => $name,
 198                 -value   => $val->{value},
 199                 -expires => $val->{expires},
 200                 -domain  => $val->{domain},
 201                 -path    => $val->{path},
 202                 -secure  => $val->{secure} || 0,
 203                 -httponly => $val->{httponly} || 0,
 204             )
 205         );
 206         if (!defined $cookie) {
 207             $c->log->warn("undef passed in '$name' cookie value - not setting cookie")
 208                 if $c->debug;
 209             next;
 210         }
 211
 212         push @cookies, $cookie->as_string;
 213     }
 214
 215     for my $cookie (@cookies) {
 216         $response->headers->push_header( 'Set-Cookie' => $cookie );
 217     }
 218 }
 219
 220 =head2 $self->finalize_error($c)
 221
 222 Output an appropriate error message. Called if there's an error in $c
 223 after the dispatch has finished. Will output debug messages if Catalyst
 224 is in debug mode, or a `please come back later` message otherwise.
 225
 226 =cut
 227
 228 sub _dump_error_page_element {
 229     my ($self, $i, $element) = @_;
 230     my ($name, $val)  = @{ $element };
 231
 232     # This is fugly, but the metaclass is _HUGE_ and demands waaay too much
 233     # scrolling. Suggestions for more pleasant ways to do this welcome.
 234     local $val->{'__MOP__'} = "Stringified: "
 235         . $val->{'__MOP__'} if ref $val eq 'HASH' && exists $val->{'__MOP__'};
 236
 237     my $text = encode_entities( dump( $val ));
 238     sprintf <<"EOF", $name, $text;
 239 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
 240 <div id="dump_$i">
 241     <pre wrap="">%s</pre>
 242 </div>
 243 EOF
 244 }
 245
 246 sub finalize_error {
 247     my ( $self, $c ) = @_;
 248
 249     $c->res->content_type('text/html; charset=utf-8');
 250     my $name = ref($c)->config->{name} || join(' ', split('::', ref $c));
 251
 252     # Prevent Catalyst::Plugin::Unicode::Encoding from running.
 253     # This is a little nasty, but it's the best way to be clean whether or
 254     # not the user has an encoding plugin.
 255
 256     if ($c->can('encoding')) {
 257       $c->{encoding} = '';
 258     }
 259
 260     my ( $title, $error, $infos );
 261     if ( $c->debug ) {
 262
 263         # For pretty dumps
 264         $error = join '', map {
 265                 '<p><code class="error">'
 266               . encode_entities($_)
 267               . '</code></p>'
 268         } @{ $c->error };
 269         $error ||= 'No output';
 270         $error = qq{<pre wrap="">$error</pre>};
 271         $title = $name = "$name on Catalyst $Catalyst::VERSION";
 272         $name  = "<h1>$name</h1>";
 273
 274         # Don't show context in the dump
 275         $c->res->_clear_context;
 276
 277         # Don't show body parser in the dump
 278         $c->req->_clear_body;
 279
 280         my @infos;
 281         my $i = 0;
 282         for my $dump ( $c->dump_these ) {
 283             push @infos, $self->_dump_error_page_element($i, $dump);
 284             $i++;
 285         }
 286         $infos = join "\n", @infos;
 287     }
 288     else {
 289         $title = $name;
 290         $error = '';
 291         $infos = <<"";
 292 <pre>
 293 (en) Please come back later
 294 (fr) SVP veuillez revenir plus tard
 295 (de) Bitte versuchen sie es spaeter nocheinmal
 296 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
 297 (no) Vennligst prov igjen senere
 298 (dk) Venligst prov igen senere
 299 (pl) Prosze sprobowac pozniej
 300 (pt) Por favor volte mais tarde
 301 (ru) Попробуйте еще раз позже
 302 (ua) Спробуйте ще раз пізніше
 303 </pre>
 304
 305         $name = '';
 306     }
 307     $c->res->body( <<"" );
 308 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 309     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 310 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
 311 <head>
 312     <meta http-equiv="Content-Language" content="en" />
 313     <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
 314     <title>$title</title>
 315     <script type="text/javascript">
 316         <!--
 317         function toggleDump (dumpElement) {
 318             var e = document.getElementById( dumpElement );
 319             if (e.style.display == "none") {
 320                 e.style.display = "";
 321             }
 322             else {
 323                 e.style.display = "none";
 324             }
 325         }
 326         -->
 327     </script>
 328     <style type="text/css">
 329         body {
 330             font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
 331                          Tahoma, Arial, helvetica, sans-serif;
 332             color: #333;
 333             background-color: #eee;
 334             margin: 0px;
 335             padding: 0px;
 336         }
 337         :link, :link:hover, :visited, :visited:hover {
 338             color: #000;
 339         }
 340         div.box {
 341             position: relative;
 342             background-color: #ccc;
 343             border: 1px solid #aaa;
 344             padding: 4px;
 345             margin: 10px;
 346         }
 347         div.error {
 348             background-color: #cce;
 349             border: 1px solid #755;
 350             padding: 8px;
 351             margin: 4px;
 352             margin-bottom: 10px;
 353         }
 354         div.infos {
 355             background-color: #eee;
 356             border: 1px solid #575;
 357             padding: 8px;
 358             margin: 4px;
 359             margin-bottom: 10px;
 360         }
 361         div.name {
 362             background-color: #cce;
 363             border: 1px solid #557;
 364             padding: 8px;
 365             margin: 4px;
 366         }
 367         code.error {
 368             display: block;
 369             margin: 1em 0;
 370             overflow: auto;
 371         }
 372         div.name h1, div.error p {
 373             margin: 0;
 374         }
 375         h2 {
 376             margin-top: 0;
 377             margin-bottom: 10px;
 378             font-size: medium;
 379             font-weight: bold;
 380             text-decoration: underline;
 381         }
 382         h1 {
 383             font-size: medium;
 384             font-weight: normal;
 385         }
 386         /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
 387         /* Browser specific (not valid) styles to make preformatted text wrap */
 388         pre {
 389             white-space: pre-wrap;       /* css-3 */
 390             white-space: -moz-pre-wrap;  /* Mozilla, since 1999 */
 391             white-space: -pre-wrap;      /* Opera 4-6 */
 392             white-space: -o-pre-wrap;    /* Opera 7 */
 393             word-wrap: break-word;       /* Internet Explorer 5.5+ */
 394         }
 395     </style>
 396 </head>
 397 <body>
 398     <div class="box">
 399         <div class="error">$error</div>
 400         <div class="infos">$infos</div>
 401         <div class="name">$name</div>
 402     </div>
 403 </body>
 404 </html>
 405
 406     # Trick IE. Old versions of IE would display their own error page instead
 407     # of ours if we'd give it less than 512 bytes.
 408     $c->res->{body} .= ( ' ' x 512 );
 409
 410     $c->res->{body} = Encode::encode("UTF-8", $c->res->{body});
 411
 412     # Return 500
 413     $c->res->status(500);
 414 }
 415
 416 =head2 $self->finalize_headers($c)
 417
 418 Allows engines to write headers to response
 419
 420 =cut
 421
 422 sub finalize_headers {
 423     my ($self, $ctx) = @_;
 424
 425     $ctx->finalize_headers unless $ctx->response->finalized_headers;
 426     return;
 427 }
 428
 429 =head2 $self->finalize_uploads($c)
 430
 431 Clean up after uploads, deleting temp files.
 432
 433 =cut
 434
 435 sub finalize_uploads {
 436     my ( $self, $c ) = @_;
 437
 438     # N.B. This code is theoretically entirely unneeded due to ->cleanup(1)
 439     #      on the HTTP::Body object.
 440     my $request = $c->request;
 441     foreach my $key (keys %{ $request->uploads }) {
 442         my $upload = $request->uploads->{$key};
 443         unlink grep { -e $_ } map { $_->tempname }
 444           (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
 445     }
 446
 447 }
 448
 449 =head2 $self->prepare_body($c)
 450
 451 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
 452
 453 =cut
 454
 455 sub prepare_body {
 456     my ( $self, $c ) = @_;
 457
 458     $c->request->prepare_body;
 459 }
 460
 461 =head2 $self->prepare_body_chunk($c)
 462
 463 Add a chunk to the request body.
 464
 465 =cut
 466
 467 # XXX - Can this be deleted?
 468 sub prepare_body_chunk {
 469     my ( $self, $c, $chunk ) = @_;
 470
 471     $c->request->prepare_body_chunk($chunk);
 472 }
 473
 474 =head2 $self->prepare_body_parameters($c)
 475
 476 Sets up parameters from body.
 477
 478 =cut
 479
 480 sub prepare_body_parameters {
 481     my ( $self, $c ) = @_;
 482
 483     $c->request->prepare_body_parameters;
 484 }
 485
 486 =head2 $self->prepare_parameters($c)
 487
 488 Sets up parameters from query and post parameters.
 489 If parameters have already been set up will clear
 490 existing parameters and set up again.
 491
 492 =cut
 493
 494 sub prepare_parameters {
 495     my ( $self, $c ) = @_;
 496
 497     $c->request->_clear_parameters;
 498     return $c->request->parameters;
 499 }
 500
 501 =head2 $self->prepare_path($c)
 502
 503 abstract method, implemented by engines.
 504
 505 =cut
 506
 507 sub prepare_path {
 508     my ($self, $ctx) = @_;
 509
 510     my $env = $ctx->request->env;
 511
 512     my $scheme    = $ctx->request->secure ? 'https' : 'http';
 513     my $host      = $env->{HTTP_HOST} || $env->{SERVER_NAME};
 514     my $port      = $env->{SERVER_PORT} || 80;
 515     my $base_path = $env->{SCRIPT_NAME} || "/";
 516
 517     # set the request URI
 518     my $path;
 519     if (!$ctx->config->{use_request_uri_for_path}) {
 520         my $path_info = $env->{PATH_INFO};
 521         if ( exists $env->{REDIRECT_URL} ) {
 522             $base_path = $env->{REDIRECT_URL};
 523             $base_path =~ s/\Q$path_info\E$//;
 524         }
 525         $path = $base_path . $path_info;
 526         $path =~ s{^/+}{};
 527         $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
 528         $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
 529     }
 530     else {
 531         my $req_uri = $env->{REQUEST_URI};
 532         $req_uri =~ s/\?.*$//;
 533         $path = $req_uri;
 534         $path =~ s{^/+}{};
 535     }
 536
 537     # Using URI directly is way too slow, so we construct the URLs manually
 538     my $uri_class = "URI::$scheme";
 539
 540     # HTTP_HOST will include the port even if it's 80/443
 541     $host =~ s/:(?:80|443)$//;
 542
 543     if ($port !~ /^(?:80|443)$/ && $host !~ /:/) {
 544         $host .= ":$port";
 545     }
 546
 547     my $query = $env->{QUERY_STRING} ? '?' . $env->{QUERY_STRING} : '';
 548     my $uri   = $scheme . '://' . $host . '/' . $path . $query;
 549
 550     $ctx->request->uri( (bless \$uri, $uri_class)->canonical );
 551
 552     # set the base URI
 553     # base must end in a slash
 554     $base_path .= '/' unless $base_path =~ m{/$};
 555
 556     my $base_uri = $scheme . '://' . $host . $base_path;
 557
 558     $ctx->request->base( bless \$base_uri, $uri_class );
 559
 560     return;
 561 }
 562
 563 =head2 $self->prepare_request($c)
 564
 565 =head2 $self->prepare_query_parameters($c)
 566
 567 process the query string and extract query parameters.
 568
 569 =cut
 570
 571 sub prepare_query_parameters {
 572     my ($self, $c) = @_;
 573     my $env = $c->request->env;
 574
 575     if(my $query_obj = $env->{'plack.request.query'}) {
 576          $c->request->query_parameters(
 577            $c->request->_use_hash_multivalue ?
 578               $query_obj->clone :
 579               $query_obj->as_hashref_mixed);
 580          return;
 581     }
 582
 583     my $query_string = exists $env->{QUERY_STRING}
 584         ? $env->{QUERY_STRING}
 585         : '';
 586
 587     # Check for keywords (no = signs)
 588     # (yes, index() is faster than a regex :))
 589     if ( index( $query_string, '=' ) < 0 ) {
 590         $c->request->query_keywords($self->unescape_uri($query_string));
 591         return;
 592     }
 593
 594     my %query;
 595
 596     # replace semi-colons
 597     $query_string =~ s/;/&/g;
 598
 599     my @params = grep { length $_ } split /&/, $query_string;
 600
 601     for my $item ( @params ) {
 602
 603         my ($param, $value)
 604             = map { $self->unescape_uri($_) }
 605               split( /=/, $item, 2 );
 606
 607         $param = $self->unescape_uri($item) unless defined $param;
 608
 609         if ( exists $query{$param} ) {
 610             if ( ref $query{$param} ) {
 611                 push @{ $query{$param} }, $value;
 612             }
 613             else {
 614                 $query{$param} = [ $query{$param}, $value ];
 615             }
 616         }
 617         else {
 618             $query{$param} = $value;
 619         }
 620     }
 621
 622     $c->request->query_parameters(
 623       $c->request->_use_hash_multivalue ?
 624         Hash::MultiValue->from_mixed(\%query) :
 625         \%query);
 626 }
 627
 628 =head2 $self->prepare_read($c)
 629
 630 Prepare to read by initializing the Content-Length from headers.
 631
 632 =cut
 633
 634 sub prepare_read {
 635     my ( $self, $c ) = @_;
 636
 637     # Initialize the amount of data we think we need to read
 638     $c->request->_read_length;
 639 }
 640
 641 =head2 $self->prepare_request(@arguments)
 642
 643 Populate the context object from the request object.
 644
 645 =cut
 646
 647 sub prepare_request {
 648     my ($self, $ctx, %args) = @_;
 649     $ctx->log->psgienv($args{env}) if $ctx->log->can('psgienv');
 650     $ctx->request->_set_env($args{env});
 651     $self->_set_env($args{env}); # Nasty back compat!
 652     $ctx->response->_set_response_cb($args{response_cb});
 653 }
 654
 655 =head2 $self->prepare_uploads($c)
 656
 657 =cut
 658
 659 sub prepare_uploads {
 660     my ( $self, $c ) = @_;
 661
 662     my $request = $c->request;
 663     return unless $request->_body;
 664
 665     my $uploads = $request->_body->upload;
 666     my $parameters = $request->parameters;
 667     foreach my $name (keys %$uploads) {
 668         my $files = $uploads->{$name};
 669         my @uploads;
 670         for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
 671             my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
 672             my $u = Catalyst::Request::Upload->new
 673               (
 674                size => $upload->{size},
 675                type => scalar $headers->content_type,
 676                headers => $headers,
 677                tempname => $upload->{tempname},
 678                filename => $upload->{filename},
 679               );
 680             push @uploads, $u;
 681         }
 682         $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
 683
 684         # support access to the filename as a normal param
 685         my @filenames = map { $_->{filename} } @uploads;
 686         # append, if there's already params with this name
 687         if (exists $parameters->{$name}) {
 688             if (ref $parameters->{$name} eq 'ARRAY') {
 689                 push @{ $parameters->{$name} }, @filenames;
 690             }
 691             else {
 692                 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
 693             }
 694         }
 695         else {
 696             $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
 697         }
 698     }
 699 }
 700
 701 =head2 $self->write($c, $buffer)
 702
 703 Writes the buffer to the client.
 704
 705 =cut
 706
 707 sub write {
 708     my ( $self, $c, $buffer ) = @_;
 709
 710     $c->response->write($buffer);
 711 }
 712
 713 =head2 $self->read($c, [$maxlength])
 714
 715 Reads from the input stream by calling C<< $self->read_chunk >>.
 716
 717 Maintains the read_length and read_position counters as data is read.
 718
 719 =cut
 720
 721 sub read {
 722     my ( $self, $c, $maxlength ) = @_;
 723
 724     $c->request->read($maxlength);
 725 }
 726
 727 =head2 $self->read_chunk($c, \$buffer, $length)
 728
 729 Each engine implements read_chunk as its preferred way of reading a chunk
 730 of data. Returns the number of bytes read. A return of 0 indicates that
 731 there is no more data to be read.
 732
 733 =cut
 734
 735 sub read_chunk {
 736     my ($self, $ctx) = (shift, shift);
 737     return $ctx->request->read_chunk(@_);
 738 }
 739
 740 =head2 $self->run($app, $server)
 741
 742 Start the engine. Builds a PSGI application and calls the
 743 run method on the server passed in, which then causes the
 744 engine to loop, handling requests..
 745
 746 =cut
 747
 748 sub run {
 749     my ($self, $app, $psgi, @args) = @_;
 750     # @args left here rather than just a $options, $server for back compat with the
 751     # old style scripts which send a few args, then a hashref
 752
 753     # They should never actually be used in the normal case as the Plack engine is
 754     # passed in got all the 'standard' args via the loader in the script already.
 755
 756     # FIXME - we should stash the options in an attribute so that custom args
 757     # like Gitalist's --git_dir are possible to get from the app without stupid tricks.
 758     my $server = pop @args if (scalar @args && blessed $args[-1]);
 759     my $options = pop @args if (scalar @args && ref($args[-1]) eq 'HASH');
 760     # Back compat hack for applications with old (non Catalyst::Script) scripts to work in FCGI.
 761     if (scalar @args && !ref($args[0])) {
 762         if (my $listen = shift @args) {
 763             $options->{listen} ||= [$listen];
 764         }
 765     }
 766     if (! $server ) {
 767         $server = Catalyst::EngineLoader->new(application_name => ref($self))->auto(%$options);
 768         # We're not being called from a script, so auto detect what backend to
 769         # run on.  This should never happen, as mod_perl never calls ->run,
 770         # instead the $app->handle method is called per request.
 771         $app->log->warn("Not supplied a Plack engine, falling back to engine auto-loader (are your scripts ancient?)")
 772     }
 773     $app->run_options($options);
 774     $server->run($psgi, $options);
 775 }
 776
 777 =head2 build_psgi_app ($app, @args)
 778
 779 Builds and returns a PSGI application closure. (Raw, not wrapped in middleware)
 780
 781 =cut
 782
 783 sub build_psgi_app {
 784     my ($self, $app, @args) = @_;
 785
 786     return sub {
 787         my ($env) = @_;
 788
 789         return sub {
 790             my ($respond) = @_;
 791             confess("Did not get a response callback for writer, cannot continue") unless $respond;
 792             $app->handle_request(env => $env, response_cb => $respond);
 793         };
 794     };
 795 }
 796
 797 =head2 $self->unescape_uri($uri)
 798
 799 Unescapes a given URI using the most efficient method available.  Engines such
 800 as Apache may implement this using Apache's C-based modules, for example.
 801
 802 =cut
 803
 804 sub unescape_uri {
 805     my ( $self, $str ) = @_;
 806
 807     $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
 808
 809     return $str;
 810 }
 811
 812 =head2 $self->finalize_output
 813
 814 <obsolete>, see finalize_body
 815
 816 =head2 $self->env
 817
 818 Hash containing environment variables including many special variables inserted
 819 by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
 820
 821 Before accessing environment variables consider whether the same information is
 822 not directly available via Catalyst objects $c->request, $c->engine ...
 823
 824 BEWARE: If you really need to access some environment variable from your Catalyst
 825 application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
 826 as in some environments the %ENV hash does not contain what you would expect.
 827
 828 =head1 AUTHORS
 829
 830 Catalyst Contributors, see Catalyst.pm
 831
 832 =head1 COPYRIGHT
 833
 834 This library is free software. You can redistribute it and/or modify it under
 835 the same terms as Perl itself.
 836
 837 =cut
 838
 839 __PACKAGE__->meta->make_immutable;
 840
 841 1;