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