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                 # I really am guessing this case is pathological.  I'd like to remove it
 107                 # but need to give people a bit of heads up
 108                 $c->log->warn('!!! Setting $response->body to an object that supports "read" but not "getline" is deprecated. !!!')
 109                   unless $self->{__FH_READ_DEPRECATION_NOTICE_qwvsretf43}++;
 110
 111                 close $body;
 112                 return;
 113             } else {
 114               # Looks like for  backcompat reasons we need to be able to deal
 115               # with stringyfiable objects.
 116               $body = "$body" if blessed($body); # Assume there's some sort of overloading..
 117               $body = [$body];
 118             }
 119         } else {
 120           $body = [];
 121         }
 122
 123         $res->_response_cb->([ $res->status, \@headers, $body]);
 124         $res->_clear_response_cb;
 125
 126     } else {
 127         ## Now, if there's no response callback anymore, that means someone has
 128         ## called ->write in order to stream 'some stuff along the way'.  I think
 129         ## for backcompat we still need to handle a ->body.  I guess I could see
 130         ## someone calling ->write to presend some stuff, and then doing the rest
 131         ## via ->body, like in a template.
 132
 133         ## We'll just use the old, existing code for this (or most of it)
 134
 135         if(my $body = $res->body) {
 136           no warnings 'uninitialized';
 137           if ( blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
 138
 139               ## In this case we have no choice and will fall back on the old
 140               ## manual streaming stuff.
 141
 142               my $got;
 143               do {
 144                   $got = read $body, my ($buffer), $CHUNKSIZE;
 145                   $got = 0 unless $self->write($c, $buffer );
 146               } while $got > 0;
 147
 148               close $body;
 149           }
 150           else {
 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->log->warn("undef passed in '$name' cookie value - not setting cookie")
 194                 if $c->debug;
 195             next;
 196         }
 197
 198         push @cookies, $cookie->as_string;
 199     }
 200
 201     for my $cookie (@cookies) {
 202         $response->headers->push_header( 'Set-Cookie' => $cookie );
 203     }
 204 }
 205
 206 =head2 $self->finalize_error($c)
 207
 208 Output an appropriate error message. Called if there's an error in $c
 209 after the dispatch has finished. Will output debug messages if Catalyst
 210 is in debug mode, or a `please come back later` message otherwise.
 211
 212 =cut
 213
 214 sub _dump_error_page_element {
 215     my ($self, $i, $element) = @_;
 216     my ($name, $val)  = @{ $element };
 217
 218     # This is fugly, but the metaclass is _HUGE_ and demands waaay too much
 219     # scrolling. Suggestions for more pleasant ways to do this welcome.
 220     local $val->{'__MOP__'} = "Stringified: "
 221         . $val->{'__MOP__'} if ref $val eq 'HASH' && exists $val->{'__MOP__'};
 222
 223     my $text = encode_entities( dump( $val ));
 224     sprintf <<"EOF", $name, $text;
 225 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
 226 <div id="dump_$i">
 227     <pre wrap="">%s</pre>
 228 </div>
 229 EOF
 230 }
 231
 232 sub finalize_error {
 233     my ( $self, $c ) = @_;
 234
 235     $c->res->content_type('text/html; charset=utf-8');
 236     my $name = ref($c)->config->{name} || join(' ', split('::', ref $c));
 237
 238     # Prevent Catalyst::Plugin::Unicode::Encoding from running.
 239     # This is a little nasty, but it's the best way to be clean whether or
 240     # not the user has an encoding plugin.
 241
 242     if ($c->can('encoding')) {
 243       $c->{encoding} = '';
 244     }
 245
 246     my ( $title, $error, $infos );
 247     if ( $c->debug ) {
 248
 249         # For pretty dumps
 250         $error = join '', map {
 251                 '<p><code class="error">'
 252               . encode_entities($_)
 253               . '</code></p>'
 254         } @{ $c->error };
 255         $error ||= 'No output';
 256         $error = qq{<pre wrap="">$error</pre>};
 257         $title = $name = "$name on Catalyst $Catalyst::VERSION";
 258         $name  = "<h1>$name</h1>";
 259
 260         # Don't show context in the dump
 261         $c->res->_clear_context;
 262
 263         # Don't show body parser in the dump
 264         $c->req->_clear_body;
 265
 266         my @infos;
 267         my $i = 0;
 268         for my $dump ( $c->dump_these ) {
 269             push @infos, $self->_dump_error_page_element($i, $dump);
 270             $i++;
 271         }
 272         $infos = join "\n", @infos;
 273     }
 274     else {
 275         $title = $name;
 276         $error = '';
 277         $infos = <<"";
 278 <pre>
 279 (en) Please come back later
 280 (fr) SVP veuillez revenir plus tard
 281 (de) Bitte versuchen sie es spaeter nocheinmal
 282 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
 283 (no) Vennligst prov igjen senere
 284 (dk) Venligst prov igen senere
 285 (pl) Prosze sprobowac pozniej
 286 (pt) Por favor volte mais tarde
 287 (ru) Попробуйте еще раз позже
 288 (ua) Спробуйте ще раз пізніше
 289 </pre>
 290
 291         $name = '';
 292     }
 293     $c->res->body( <<"" );
 294 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 295     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 296 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
 297 <head>
 298     <meta http-equiv="Content-Language" content="en" />
 299     <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
 300     <title>$title</title>
 301     <script type="text/javascript">
 302         <!--
 303         function toggleDump (dumpElement) {
 304             var e = document.getElementById( dumpElement );
 305             if (e.style.display == "none") {
 306                 e.style.display = "";
 307             }
 308             else {
 309                 e.style.display = "none";
 310             }
 311         }
 312         -->
 313     </script>
 314     <style type="text/css">
 315         body {
 316             font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
 317                          Tahoma, Arial, helvetica, sans-serif;
 318             color: #333;
 319             background-color: #eee;
 320             margin: 0px;
 321             padding: 0px;
 322         }
 323         :link, :link:hover, :visited, :visited:hover {
 324             color: #000;
 325         }
 326         div.box {
 327             position: relative;
 328             background-color: #ccc;
 329             border: 1px solid #aaa;
 330             padding: 4px;
 331             margin: 10px;
 332         }
 333         div.error {
 334             background-color: #cce;
 335             border: 1px solid #755;
 336             padding: 8px;
 337             margin: 4px;
 338             margin-bottom: 10px;
 339         }
 340         div.infos {
 341             background-color: #eee;
 342             border: 1px solid #575;
 343             padding: 8px;
 344             margin: 4px;
 345             margin-bottom: 10px;
 346         }
 347         div.name {
 348             background-color: #cce;
 349             border: 1px solid #557;
 350             padding: 8px;
 351             margin: 4px;
 352         }
 353         code.error {
 354             display: block;
 355             margin: 1em 0;
 356             overflow: auto;
 357         }
 358         div.name h1, div.error p {
 359             margin: 0;
 360         }
 361         h2 {
 362             margin-top: 0;
 363             margin-bottom: 10px;
 364             font-size: medium;
 365             font-weight: bold;
 366             text-decoration: underline;
 367         }
 368         h1 {
 369             font-size: medium;
 370             font-weight: normal;
 371         }
 372         /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
 373         /* Browser specific (not valid) styles to make preformatted text wrap */
 374         pre {
 375             white-space: pre-wrap;       /* css-3 */
 376             white-space: -moz-pre-wrap;  /* Mozilla, since 1999 */
 377             white-space: -pre-wrap;      /* Opera 4-6 */
 378             white-space: -o-pre-wrap;    /* Opera 7 */
 379             word-wrap: break-word;       /* Internet Explorer 5.5+ */
 380         }
 381     </style>
 382 </head>
 383 <body>
 384     <div class="box">
 385         <div class="error">$error</div>
 386         <div class="infos">$infos</div>
 387         <div class="name">$name</div>
 388     </div>
 389 </body>
 390 </html>
 391
 392     # Trick IE. Old versions of IE would display their own error page instead
 393     # of ours if we'd give it less than 512 bytes.
 394     $c->res->{body} .= ( ' ' x 512 );
 395
 396     $c->res->{body} = Encode::encode("UTF-8", $c->res->{body});
 397
 398     # Return 500
 399     $c->res->status(500);
 400 }
 401
 402 =head2 $self->finalize_headers($c)
 403
 404 Allows engines to write headers to response
 405
 406 =cut
 407
 408 sub finalize_headers {
 409     my ($self, $ctx) = @_;
 410
 411     $ctx->finalize_headers unless $ctx->response->finalized_headers;
 412     return;
 413 }
 414
 415 =head2 $self->finalize_uploads($c)
 416
 417 Clean up after uploads, deleting temp files.
 418
 419 =cut
 420
 421 sub finalize_uploads {
 422     my ( $self, $c ) = @_;
 423
 424     # N.B. This code is theoretically entirely unneeded due to ->cleanup(1)
 425     #      on the HTTP::Body object.
 426     my $request = $c->request;
 427     foreach my $key (keys %{ $request->uploads }) {
 428         my $upload = $request->uploads->{$key};
 429         unlink grep { -e $_ } map { $_->tempname }
 430           (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
 431     }
 432
 433 }
 434
 435 =head2 $self->prepare_body($c)
 436
 437 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
 438
 439 =cut
 440
 441 sub prepare_body {
 442     my ( $self, $c ) = @_;
 443
 444     $c->request->prepare_body;
 445 }
 446
 447 =head2 $self->prepare_body_chunk($c)
 448
 449 Add a chunk to the request body.
 450
 451 =cut
 452
 453 # XXX - Can this be deleted?
 454 sub prepare_body_chunk {
 455     my ( $self, $c, $chunk ) = @_;
 456
 457     $c->request->prepare_body_chunk($chunk);
 458 }
 459
 460 =head2 $self->prepare_body_parameters($c)
 461
 462 Sets up parameters from body.
 463
 464 =cut
 465
 466 sub prepare_body_parameters {
 467     my ( $self, $c ) = @_;
 468
 469     $c->request->prepare_body_parameters;
 470 }
 471
 472 =head2 $self->prepare_parameters($c)
 473
 474 Sets up parameters from query and post parameters.
 475 If parameters have already been set up will clear
 476 existing parameters and set up again.
 477
 478 =cut
 479
 480 sub prepare_parameters {
 481     my ( $self, $c ) = @_;
 482
 483     $c->request->_clear_parameters;
 484     return $c->request->parameters;
 485 }
 486
 487 =head2 $self->prepare_path($c)
 488
 489 abstract method, implemented by engines.
 490
 491 =cut
 492
 493 sub prepare_path {
 494     my ($self, $ctx) = @_;
 495
 496     my $env = $ctx->request->env;
 497
 498     my $scheme    = $ctx->request->secure ? 'https' : 'http';
 499     my $host      = $env->{HTTP_HOST} || $env->{SERVER_NAME};
 500     my $port      = $env->{SERVER_PORT} || 80;
 501     my $base_path = $env->{SCRIPT_NAME} || "/";
 502
 503     # set the request URI
 504     my $path;
 505     if (!$ctx->config->{use_request_uri_for_path}) {
 506         my $path_info = $env->{PATH_INFO};
 507         if ( exists $env->{REDIRECT_URL} ) {
 508             $base_path = $env->{REDIRECT_URL};
 509             $base_path =~ s/\Q$path_info\E$//;
 510         }
 511         $path = $base_path . $path_info;
 512         $path =~ s{^/+}{};
 513         $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
 514         $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
 515     }
 516     else {
 517         my $req_uri = $env->{REQUEST_URI};
 518         $req_uri =~ s/\?.*$//;
 519         $path = $req_uri;
 520         $path =~ s{^/+}{};
 521     }
 522
 523     # Using URI directly is way too slow, so we construct the URLs manually
 524     my $uri_class = "URI::$scheme";
 525
 526     # HTTP_HOST will include the port even if it's 80/443
 527     $host =~ s/:(?:80|443)$//;
 528
 529     if ($port !~ /^(?:80|443)$/ && $host !~ /:/) {
 530         $host .= ":$port";
 531     }
 532
 533     my $query = $env->{QUERY_STRING} ? '?' . $env->{QUERY_STRING} : '';
 534     my $uri   = $scheme . '://' . $host . '/' . $path . $query;
 535
 536     $ctx->request->uri( (bless \$uri, $uri_class)->canonical );
 537
 538     # set the base URI
 539     # base must end in a slash
 540     $base_path .= '/' unless $base_path =~ m{/$};
 541
 542     my $base_uri = $scheme . '://' . $host . $base_path;
 543
 544     $ctx->request->base( bless \$base_uri, $uri_class );
 545
 546     return;
 547 }
 548
 549 =head2 $self->prepare_request($c)
 550
 551 =head2 $self->prepare_query_parameters($c)
 552
 553 process the query string and extract query parameters.
 554
 555 =cut
 556
 557 sub prepare_query_parameters {
 558     my ($self, $c) = @_;
 559     my $env = $c->request->env;
 560
 561     if(my $query_obj = $env->{'plack.request.query'}) {
 562          $c->request->query_parameters(
 563            $c->request->_use_hash_multivalue ?
 564               $query_obj->clone :
 565               $query_obj->as_hashref_mixed);
 566          return;
 567     }
 568
 569     my $query_string = exists $env->{QUERY_STRING}
 570         ? $env->{QUERY_STRING}
 571         : '';
 572
 573     # Check for keywords (no = signs)
 574     # (yes, index() is faster than a regex :))
 575     if ( index( $query_string, '=' ) < 0 ) {
 576         $c->request->query_keywords($self->unescape_uri($query_string));
 577         return;
 578     }
 579
 580     my %query;
 581
 582     # replace semi-colons
 583     $query_string =~ s/;/&/g;
 584
 585     my @params = grep { length $_ } split /&/, $query_string;
 586
 587     for my $item ( @params ) {
 588
 589         my ($param, $value)
 590             = map { $self->unescape_uri($_) }
 591               split( /=/, $item, 2 );
 592
 593         $param = $self->unescape_uri($item) unless defined $param;
 594
 595         if ( exists $query{$param} ) {
 596             if ( ref $query{$param} ) {
 597                 push @{ $query{$param} }, $value;
 598             }
 599             else {
 600                 $query{$param} = [ $query{$param}, $value ];
 601             }
 602         }
 603         else {
 604             $query{$param} = $value;
 605         }
 606     }
 607
 608     $c->request->query_parameters(
 609       $c->request->_use_hash_multivalue ?
 610         Hash::MultiValue->from_mixed(\%query) :
 611         \%query);
 612 }
 613
 614 =head2 $self->prepare_read($c)
 615
 616 Prepare to read by initializing the Content-Length from headers.
 617
 618 =cut
 619
 620 sub prepare_read {
 621     my ( $self, $c ) = @_;
 622
 623     # Initialize the amount of data we think we need to read
 624     $c->request->_read_length;
 625 }
 626
 627 =head2 $self->prepare_request(@arguments)
 628
 629 Populate the context object from the request object.
 630
 631 =cut
 632
 633 sub prepare_request {
 634     my ($self, $ctx, %args) = @_;
 635     $ctx->log->psgienv($args{env}) if $ctx->log->can('psgienv');
 636     $ctx->request->_set_env($args{env});
 637     $self->_set_env($args{env}); # Nasty back compat!
 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;