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