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', 'encode', 'decode';
  14 use Plack::Request::Upload;
  15 use Hash::MultiValue;
  16 use Ref::Util qw(is_plain_arrayref is_plain_globref is_plain_hashref);
  17 use namespace::clean -except => 'meta';
  18 use utf8;
  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' , weak_ref=>1);
  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 # XXX - Only here for Engine::PSGI compat
  37 sub prepare_connection {
  38     my ($self, $ctx) = @_;
  39     $ctx->request->prepare_connection;
  40 }
  41
  42 =head1 NAME
  43
  44 Catalyst::Engine - The Catalyst Engine
  45
  46 =head1 SYNOPSIS
  47
  48 See L<Catalyst>.
  49
  50 =head1 DESCRIPTION
  51
  52 =head1 METHODS
  53
  54
  55 =head2 $self->finalize_body($c)
  56
  57 Finalize body.  Prints the response output as blocking stream if it looks like
  58 a filehandle, otherwise write it out all in one go.  If there is no body in
  59 the response, we assume you are handling it 'manually', such as for nonblocking
  60 style or asynchronous streaming responses.  You do this by calling L</write>
  61 several times (which sends HTTP headers if needed) or you close over
  62 C<< $response->write_fh >>.
  63
  64 See L<Catalyst::Response/write> and L<Catalyst::Response/write_fh> for more.
  65
  66 =cut
  67
  68 sub finalize_body {
  69     my ( $self, $c ) = @_;
  70     my $res = $c->response; # We use this all over
  71
  72     ## If we've asked for the write 'filehandle' that means the application is
  73     ## doing something custom and is expected to close the response
  74     return if $res->_has_write_fh;
  75
  76     my $body = $res->body; # save some typing
  77     if($res->_has_response_cb) {
  78         ## we have not called the response callback yet, so we are safe to send
  79         ## the whole body to PSGI
  80
  81         my @headers;
  82         $res->headers->scan(sub { push @headers, @_ });
  83
  84         # We need to figure out what kind of body we have and normalize it to something
  85         # PSGI can deal with
  86         if(defined $body) {
  87             # Handle objects first
  88             if(blessed($body)) {
  89                 if($body->can('getline')) {
  90                     # Body is an IO handle that meets the PSGI spec.  Nothing to normalize
  91                 } elsif($body->can('read')) {
  92
  93                     # In the past, Catalyst only looked for ->read not ->getline.  It is very possible
  94                     # that one might have an object that respected read but did not have getline.
  95                     # As a result, we need to handle this case for backcompat.
  96
  97                     # We will just do the old loop for now.  In a future version of Catalyst this support
  98                     # will be removed and one will have to rewrite their custom object or use
  99                     # Plack::Middleware::AdaptFilehandleRead.  In anycase support for this is officially
 100                     # deprecated and described as such as of 5.90060
 101
 102                     my $got;
 103                     do {
 104                         $got = read $body, my ($buffer), $CHUNKSIZE;
 105                         $got = 0 unless $self->write($c, $buffer );
 106                     } while $got > 0;
 107
 108                     close $body;
 109                     return;
 110                 } else {
 111                     # Looks like for  backcompat reasons we need to be able to deal
 112                     # with stringyfiable objects.
 113                     $body = ["$body"];
 114                 }
 115             } elsif(ref $body) {
 116                 if( (is_plain_globref($body)) or (is_plain_arrayref($body))) {
 117                   # Again, PSGI can just accept this, no transform needed.  We don't officially
 118                   # document the body as arrayref at this time (and there's not specific test
 119                   # cases.  we support it because it simplifies some plack compatibility logic
 120                   # and we might make it official at some point.
 121                 } else {
 122                    $c->log->error("${\ref($body)} is not a valid value for Response->body");
 123                    return;
 124                 }
 125             } else {
 126                 # Body is defined and not an object or reference.  We assume a simple value
 127                 # and wrap it in an array for PSGI
 128                 $body = [$body];
 129             }
 130         } else {
 131             # There's no body...
 132             $body = [];
 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 is_plain_globref($body) ) {
 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 after 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. Since body has already been encoded, we need to do
 166               # an 'unencoded_write' here.
 167               $self->unencoded_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 is_plain_hashref($val) && 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           (is_plain_arrayref($upload) ? @{$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     my $do_not_decode_query = $c->config->{do_not_decode_query};
 578
 579     my $old_encoding;
 580     if(my $new = $c->config->{default_query_encoding}) {
 581       $old_encoding = $c->encoding;
 582       $c->encoding($new);
 583     }
 584
 585     my $check = $c->config->{do_not_check_query_encoding} ? undef :$c->_encode_check;
 586     my $decoder = sub {
 587       my $str = shift;
 588       return $str if $do_not_decode_query;
 589       return $c->_handle_param_unicode_decoding($str, $check);
 590     };
 591
 592     my $query_string = exists $env->{QUERY_STRING}
 593         ? $env->{QUERY_STRING}
 594         : '';
 595
 596     # Check for keywords (no = signs)
 597     # (yes, index() is faster than a regex :))
 598     if ( index( $query_string, '=' ) < 0 ) {
 599         my $keywords = $self->unescape_uri($query_string);
 600         $keywords = $decoder->($keywords);
 601         $c->request->query_keywords($keywords);
 602         return;
 603     }
 604
 605     $query_string =~ s/\A[&;]+//;
 606
 607     my $p = Hash::MultiValue->new(
 608         map { defined $_ ? $decoder->($self->unescape_uri($_)) : $_ }
 609         map { ( split /=/, $_, 2 )[0,1] } # slice forces two elements
 610         split /[&;]+/, $query_string
 611     );
 612
 613     $c->encoding($old_encoding) if $old_encoding;
 614     $c->request->query_parameters( $c->request->_use_hash_multivalue ? $p : $p->mixed );
 615 }
 616
 617 =head2 $self->prepare_read($c)
 618
 619 Prepare to read by initializing the Content-Length from headers.
 620
 621 =cut
 622
 623 sub prepare_read {
 624     my ( $self, $c ) = @_;
 625
 626     # Initialize the amount of data we think we need to read
 627     $c->request->_read_length;
 628 }
 629
 630 =head2 $self->prepare_request(@arguments)
 631
 632 Populate the context object from the request object.
 633
 634 =cut
 635
 636 sub prepare_request {
 637     my ($self, $ctx, %args) = @_;
 638     $ctx->log->psgienv($args{env}) if $ctx->log->can('psgienv');
 639     $ctx->request->_set_env($args{env});
 640     $self->_set_env($args{env}); # Nasty back compat!
 641     $ctx->response->_set_response_cb($args{response_cb});
 642 }
 643
 644 =head2 $self->prepare_uploads($c)
 645
 646 =cut
 647
 648 sub prepare_uploads {
 649     my ( $self, $c ) = @_;
 650
 651     my $request = $c->request;
 652     return unless $request->_body;
 653
 654     my $enc = $c->encoding;
 655     my $uploads = $request->_body->upload;
 656     my $parameters = $request->parameters;
 657     foreach my $name (keys %$uploads) {
 658         my $files = $uploads->{$name};
 659         $name = $c->_handle_unicode_decoding($name) if $enc;
 660         my @uploads;
 661         for my $upload (is_plain_arrayref($files) ? @$files : ($files)) {
 662             my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
 663             my $filename = $upload->{filename};
 664             $filename = $c->_handle_unicode_decoding($filename) if $enc;
 665
 666             my $u = Catalyst::Request::Upload->new
 667               (
 668                size => $upload->{size},
 669                type => scalar $headers->content_type,
 670                charset => scalar $headers->content_type_charset,
 671                headers => $headers,
 672                tempname => $upload->{tempname},
 673                filename => $filename,
 674               );
 675             push @uploads, $u;
 676         }
 677         $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
 678
 679         # support access to the filename as a normal param
 680         my @filenames = map { $_->{filename} } @uploads;
 681         # append, if there's already params with this name
 682         if (exists $parameters->{$name}) {
 683             if (is_plain_arrayref($parameters->{$name})) {
 684                 push @{ $parameters->{$name} }, @filenames;
 685             }
 686             else {
 687                 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
 688             }
 689         }
 690         else {
 691             $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
 692         }
 693     }
 694 }
 695
 696 =head2 $self->write($c, $buffer)
 697
 698 Writes the buffer to the client.
 699
 700 =cut
 701
 702 sub write {
 703     my ( $self, $c, $buffer ) = @_;
 704
 705     $c->response->write($buffer);
 706 }
 707
 708 =head2 $self->unencoded_write($c, $buffer)
 709
 710 Writes the buffer to the client without encoding. Necessary for
 711 already encoded buffers. Used when a $c->write has been done
 712 followed by $c->res->body.
 713
 714 =cut
 715
 716 sub unencoded_write {
 717     my ( $self, $c, $buffer ) = @_;
 718
 719     $c->response->unencoded_write($buffer);
 720 }
 721
 722 =head2 $self->read($c, [$maxlength])
 723
 724 Reads from the input stream by calling C<< $self->read_chunk >>.
 725
 726 Maintains the read_length and read_position counters as data is read.
 727
 728 =cut
 729
 730 sub read {
 731     my ( $self, $c, $maxlength ) = @_;
 732
 733     $c->request->read($maxlength);
 734 }
 735
 736 =head2 $self->read_chunk($c, \$buffer, $length)
 737
 738 Each engine implements read_chunk as its preferred way of reading a chunk
 739 of data. Returns the number of bytes read. A return of 0 indicates that
 740 there is no more data to be read.
 741
 742 =cut
 743
 744 sub read_chunk {
 745     my ($self, $ctx) = (shift, shift);
 746     return $ctx->request->read_chunk(@_);
 747 }
 748
 749 =head2 $self->run($app, $server)
 750
 751 Start the engine. Builds a PSGI application and calls the
 752 run method on the server passed in, which then causes the
 753 engine to loop, handling requests..
 754
 755 =cut
 756
 757 sub run {
 758     my ($self, $app, $psgi, @args) = @_;
 759     # @args left here rather than just a $options, $server for back compat with the
 760     # old style scripts which send a few args, then a hashref
 761
 762     # They should never actually be used in the normal case as the Plack engine is
 763     # passed in got all the 'standard' args via the loader in the script already.
 764
 765     # FIXME - we should stash the options in an attribute so that custom args
 766     # like Gitalist's --git_dir are possible to get from the app without stupid tricks.
 767     my $server = pop @args if (scalar @args && blessed $args[-1]);
 768     my $options = pop @args if (scalar @args && is_plain_hashref($args[-1]));
 769     # Back compat hack for applications with old (non Catalyst::Script) scripts to work in FCGI.
 770     if (scalar @args && !ref($args[0])) {
 771         if (my $listen = shift @args) {
 772             $options->{listen} ||= [$listen];
 773         }
 774     }
 775     if (! $server ) {
 776         $server = Catalyst::EngineLoader->new(application_name => ref($self))->auto(%$options);
 777         # We're not being called from a script, so auto detect what backend to
 778         # run on.  This should never happen, as mod_perl never calls ->run,
 779         # instead the $app->handle method is called per request.
 780         $app->log->warn("Not supplied a Plack engine, falling back to engine auto-loader (are your scripts ancient?)")
 781     }
 782     $app->run_options($options);
 783     $server->run($psgi, $options);
 784 }
 785
 786 =head2 build_psgi_app ($app, @args)
 787
 788 Builds and returns a PSGI application closure. (Raw, not wrapped in middleware)
 789
 790 =cut
 791
 792 sub build_psgi_app {
 793     my ($self, $app, @args) = @_;
 794
 795     return sub {
 796         my ($env) = @_;
 797
 798         return sub {
 799             my ($respond) = @_;
 800             confess("Did not get a response callback for writer, cannot continue") unless $respond;
 801             $app->handle_request(env => $env, response_cb => $respond);
 802         };
 803     };
 804 }
 805
 806 =head2 $self->unescape_uri($uri)
 807
 808 Unescapes a given URI using the most efficient method available.  Engines such
 809 as Apache may implement this using Apache's C-based modules, for example.
 810
 811 =cut
 812
 813 sub unescape_uri {
 814     my ( $self, $str ) = @_;
 815
 816     $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
 817
 818     return $str;
 819 }
 820
 821 =head2 $self->finalize_output
 822
 823 <obsolete>, see finalize_body
 824
 825 =head2 $self->env
 826
 827 Hash containing environment variables including many special variables inserted
 828 by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
 829
 830 Before accessing environment variables consider whether the same information is
 831 not directly available via Catalyst objects $c->request, $c->engine ...
 832
 833 BEWARE: If you really need to access some environment variable from your Catalyst
 834 application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
 835 as in some environments the %ENV hash does not contain what you would expect.
 836
 837 =head1 AUTHORS
 838
 839 Catalyst Contributors, see Catalyst.pm
 840
 841 =head1 COPYRIGHT
 842
 843 This library is free software. You can redistribute it and/or modify it under
 844 the same terms as Perl itself.
 845
 846 =cut
 847
 848 __PACKAGE__->meta->make_immutable;
 849
 850 1;