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