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