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