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