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