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