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_read($c)
 349
 350 =cut
 351
 352 sub finalize_read { }
 353
 354 =head2 $self->finalize_uploads($c)
 355
 356 Clean up after uploads, deleting temp files.
 357
 358 =cut
 359
 360 sub finalize_uploads {
 361     my ( $self, $c ) = @_;
 362
 363     # N.B. This code is theoretically entirely unneeded due to ->cleanup(1)
 364     #      on the HTTP::Body object.
 365     my $request = $c->request;
 366     foreach my $key (keys %{ $request->uploads }) {
 367         my $upload = $request->uploads->{$key};
 368         unlink grep { -e $_ } map { $_->tempname }
 369           (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
 370     }
 371
 372 }
 373
 374 =head2 $self->prepare_body($c)
 375
 376 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
 377
 378 =cut
 379
 380 sub prepare_body {
 381     my ( $self, $c ) = @_;
 382
 383     my $appclass = ref($c) || $c;
 384     my $request = $c->request;
 385     if ( my $length = $request->_read_length ) {
 386         unless ( $request->_body ) {
 387             my $type = $request->header('Content-Type');
 388             $request->_body(HTTP::Body->new( $type, $length ));
 389             $request->_body->cleanup(1); # Make extra sure!
 390             $request->_body->tmpdir( $appclass->config->{uploadtmp} )
 391               if exists $appclass->config->{uploadtmp};
 392         }
 393
 394         # Check for definedness as you could read '0'
 395         while ( defined ( my $buffer = $self->read($c) ) ) {
 396             $c->prepare_body_chunk($buffer);
 397         }
 398
 399         # paranoia against wrong Content-Length header
 400         my $remaining = $length - $c->request->_read_position;
 401         if ( $remaining > 0 ) {
 402             $self->finalize_read($c);
 403             Catalyst::Exception->throw(
 404                 "Wrong Content-Length value: $length" );
 405         }
 406     }
 407     else {
 408         # Defined but will cause all body code to be skipped
 409         $c->request->_body(0);
 410     }
 411 }
 412
 413 =head2 $self->prepare_body_chunk($c)
 414
 415 Add a chunk to the request body.
 416
 417 =cut
 418
 419 sub prepare_body_chunk {
 420     my ( $self, $c, $chunk ) = @_;
 421
 422     $c->request->_body->add($chunk);
 423 }
 424
 425 =head2 $self->prepare_body_parameters($c)
 426
 427 Sets up parameters from body.
 428
 429 =cut
 430
 431 sub prepare_body_parameters {
 432     my ( $self, $c ) = @_;
 433
 434     return unless $c->request->_body;
 435
 436     $c->request->body_parameters( $c->request->_body->param );
 437 }
 438
 439 =head2 $self->prepare_connection($c)
 440
 441 Abstract method implemented in engines.
 442
 443 =cut
 444
 445 sub prepare_connection {
 446     my ($self, $ctx) = @_;
 447
 448     my $request = $ctx->request;
 449     my $env = $ctx->request->env;
 450
 451     $request->address( $env->{REMOTE_ADDR} );
 452     $request->hostname( $env->{REMOTE_HOST} )
 453         if exists $env->{REMOTE_HOST};
 454     $request->protocol( $env->{SERVER_PROTOCOL} );
 455     $request->remote_user( $env->{REMOTE_USER} );
 456     $request->method( $env->{REQUEST_METHOD} );
 457     $request->secure( $env->{'psgi.url_scheme'} eq 'https' ? 1 : 0 );
 458
 459     return;
 460 }
 461
 462 =head2 $self->prepare_cookies($c)
 463
 464 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
 465
 466 =cut
 467
 468 sub prepare_cookies {
 469     my ( $self, $c ) = @_;
 470
 471     if ( my $header = $c->request->header('Cookie') ) {
 472         $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
 473     }
 474 }
 475
 476 =head2 $self->prepare_headers($c)
 477
 478 =cut
 479
 480 sub prepare_headers {
 481     my ($self, $ctx) = @_;
 482
 483     my $env = $ctx->request->env;
 484     my $headers = $ctx->request->headers;
 485
 486     for my $header (keys %{ $env }) {
 487         next unless $header =~ /^(HTTP|CONTENT|COOKIE)/i;
 488         (my $field = $header) =~ s/^HTTPS?_//;
 489         $field =~ tr/_/-/;
 490         $headers->header($field => $env->{$header});
 491     }
 492 }
 493
 494 =head2 $self->prepare_parameters($c)
 495
 496 sets up parameters from query and post parameters.
 497
 498 =cut
 499
 500 sub prepare_parameters {
 501     my ( $self, $c ) = @_;
 502
 503     my $request = $c->request;
 504     my $parameters = $request->parameters;
 505     my $body_parameters = $request->body_parameters;
 506     my $query_parameters = $request->query_parameters;
 507     # We copy, no references
 508     foreach my $name (keys %$query_parameters) {
 509         my $param = $query_parameters->{$name};
 510         $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
 511     }
 512
 513     # Merge query and body parameters
 514     foreach my $name (keys %$body_parameters) {
 515         my $param = $body_parameters->{$name};
 516         my @values = ref $param eq 'ARRAY' ? @$param : ($param);
 517         if ( my $existing = $parameters->{$name} ) {
 518           unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
 519         }
 520         $parameters->{$name} = @values > 1 ? \@values : $values[0];
 521     }
 522 }
 523
 524 =head2 $self->prepare_path($c)
 525
 526 abstract method, implemented by engines.
 527
 528 =cut
 529
 530 sub prepare_path {
 531     my ($self, $ctx) = @_;
 532
 533     my $env = $ctx->request->env;
 534
 535     my $scheme    = $ctx->request->secure ? 'https' : 'http';
 536     my $host      = $env->{HTTP_HOST} || $env->{SERVER_NAME};
 537     my $port      = $env->{SERVER_PORT} || 80;
 538     my $base_path = $env->{SCRIPT_NAME} || "/";
 539
 540     # set the request URI
 541     my $path;
 542     if (!$ctx->config->{use_request_uri_for_path}) {
 543         my $path_info = $env->{PATH_INFO};
 544         if ( exists $env->{REDIRECT_URL} ) {
 545             $base_path = $env->{REDIRECT_URL};
 546             $base_path =~ s/\Q$path_info\E$//;
 547         }
 548         $path = $base_path . $path_info;
 549         $path =~ s{^/+}{};
 550         $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
 551         $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
 552     }
 553     else {
 554         my $req_uri = $env->{REQUEST_URI};
 555         $req_uri =~ s/\?.*$//;
 556         $path = $req_uri;
 557         $path =~ s{^/+}{};
 558     }
 559
 560     # Using URI directly is way too slow, so we construct the URLs manually
 561     my $uri_class = "URI::$scheme";
 562
 563     # HTTP_HOST will include the port even if it's 80/443
 564     $host =~ s/:(?:80|443)$//;
 565
 566     if ($port !~ /^(?:80|443)$/ && $host !~ /:/) {
 567         $host .= ":$port";
 568     }
 569
 570     my $query = $env->{QUERY_STRING} ? '?' . $env->{QUERY_STRING} : '';
 571     my $uri   = $scheme . '://' . $host . '/' . $path . $query;
 572
 573     $ctx->request->uri( (bless \$uri, $uri_class)->canonical );
 574
 575     # set the base URI
 576     # base must end in a slash
 577     $base_path .= '/' unless $base_path =~ m{/$};
 578
 579     my $base_uri = $scheme . '://' . $host . $base_path;
 580
 581     $ctx->request->base( bless \$base_uri, $uri_class );
 582
 583     return;
 584 }
 585
 586 =head2 $self->prepare_request($c)
 587
 588 =head2 $self->prepare_query_parameters($c)
 589
 590 process the query string and extract query parameters.
 591
 592 =cut
 593
 594 sub prepare_query_parameters {
 595     my ($self, $c) = @_;
 596
 597     my $env = $c->request->env;
 598     my $query_string = exists $env->{QUERY_STRING}
 599         ? $env->{QUERY_STRING}
 600         : '';
 601
 602     # Check for keywords (no = signs)
 603     # (yes, index() is faster than a regex :))
 604     if ( index( $query_string, '=' ) < 0 ) {
 605         $c->request->query_keywords( $self->unescape_uri($query_string) );
 606         return;
 607     }
 608
 609     my %query;
 610
 611     # replace semi-colons
 612     $query_string =~ s/;/&/g;
 613
 614     my @params = grep { length $_ } split /&/, $query_string;
 615
 616     for my $item ( @params ) {
 617
 618         my ($param, $value)
 619             = map { $self->unescape_uri($_) }
 620               split( /=/, $item, 2 );
 621
 622         $param = $self->unescape_uri($item) unless defined $param;
 623
 624         if ( exists $query{$param} ) {
 625             if ( ref $query{$param} ) {
 626                 push @{ $query{$param} }, $value;
 627             }
 628             else {
 629                 $query{$param} = [ $query{$param}, $value ];
 630             }
 631         }
 632         else {
 633             $query{$param} = $value;
 634         }
 635     }
 636
 637     $c->request->query_parameters( \%query );
 638 }
 639
 640 =head2 $self->prepare_read($c)
 641
 642 prepare to read from the engine.
 643
 644 =cut
 645
 646 sub prepare_read {
 647     my ( $self, $c ) = @_;
 648
 649     # Initialize the amount of data we think we need to read
 650     $c->request->_read_length;
 651 }
 652
 653 =head2 $self->prepare_request(@arguments)
 654
 655 Populate the context object from the request object.
 656
 657 =cut
 658
 659 sub prepare_request {
 660     my ($self, $ctx, %args) = @_;
 661     $ctx->request->_set_env($args{env});
 662     $self->_set_env($args{env}); # Nasty back compat!
 663     $ctx->response->_set_response_cb($args{response_cb});
 664 }
 665
 666 =head2 $self->prepare_uploads($c)
 667
 668 =cut
 669
 670 sub prepare_uploads {
 671     my ( $self, $c ) = @_;
 672
 673     my $request = $c->request;
 674     return unless $request->_body;
 675
 676     my $uploads = $request->_body->upload;
 677     my $parameters = $request->parameters;
 678     foreach my $name (keys %$uploads) {
 679         my $files = $uploads->{$name};
 680         my @uploads;
 681         for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
 682             my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
 683             my $u = Catalyst::Request::Upload->new
 684               (
 685                size => $upload->{size},
 686                type => scalar $headers->content_type,
 687                headers => $headers,
 688                tempname => $upload->{tempname},
 689                filename => $upload->{filename},
 690               );
 691             push @uploads, $u;
 692         }
 693         $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
 694
 695         # support access to the filename as a normal param
 696         my @filenames = map { $_->{filename} } @uploads;
 697         # append, if there's already params with this name
 698         if (exists $parameters->{$name}) {
 699             if (ref $parameters->{$name} eq 'ARRAY') {
 700                 push @{ $parameters->{$name} }, @filenames;
 701             }
 702             else {
 703                 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
 704             }
 705         }
 706         else {
 707             $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
 708         }
 709     }
 710 }
 711
 712 =head2 $self->prepare_write($c)
 713
 714 Abstract method. Implemented by the engines.
 715
 716 =cut
 717
 718 sub prepare_write { }
 719
 720 =head2 $self->read($c, [$maxlength])
 721
 722 Reads from the input stream by calling C<< $self->read_chunk >>.
 723
 724 Maintains the read_length and read_position counters as data is read.
 725
 726 =cut
 727
 728 sub read {
 729     my ( $self, $c, $maxlength ) = @_;
 730
 731     my $request = $c->request;
 732     my $remaining = $request->_read_length - $request->_read_position;
 733     $maxlength ||= $CHUNKSIZE;
 734
 735     # Are we done reading?
 736     if ( $remaining <= 0 ) {
 737         $self->finalize_read($c);
 738         return;
 739     }
 740
 741     my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
 742     my $rc = $self->read_chunk( $c, my $buffer, $readlen );
 743     if ( defined $rc ) {
 744         if (0 == $rc) { # Nothing more to read even though Content-Length
 745                         # said there should be.
 746             $self->finalize_read;
 747             return;
 748         }
 749         my $request = $c->request;
 750         $request->_read_position( $request->_read_position + $rc );
 751         return $buffer;
 752     }
 753     else {
 754         Catalyst::Exception->throw(
 755             message => "Unknown error reading input: $!" );
 756     }
 757 }
 758
 759 =head2 $self->read_chunk($c, $buffer, $length)
 760
 761 Each engine implements read_chunk as its preferred way of reading a chunk
 762 of data. Returns the number of bytes read. A return of 0 indicates that
 763 there is no more data to be read.
 764
 765 =cut
 766
 767 sub read_chunk {
 768     my ($self, $ctx) = (shift, shift);
 769     return $ctx->request->env->{'psgi.input'}->read(@_);
 770 }
 771
 772 =head2 $self->read_length
 773
 774 The length of input data to be read.  This is obtained from the Content-Length
 775 header.
 776
 777 =head2 $self->read_position
 778
 779 The amount of input data that has already been read.
 780
 781 =head2 $self->run($app, $server)
 782
 783 Start the engine. Builds a PSGI application and calls the
 784 run method on the server passed in, which then causes the
 785 engine to loop, handling requests..
 786
 787 =cut
 788
 789 sub run {
 790     my ($self, $app, $psgi, @args) = @_;
 791     # @args left here rather than just a $options, $server for back compat with the
 792     # old style scripts which send a few args, then a hashref
 793
 794     # They should never actually be used in the normal case as the Plack engine is
 795     # passed in got all the 'standard' args via the loader in the script already.
 796
 797     # FIXME - we should stash the options in an attribute so that custom args
 798     # like Gitalist's --git_dir are possible to get from the app without stupid tricks.
 799     my $server = pop @args if (scalar @args && blessed $args[-1]);
 800     my $options = pop @args if (scalar @args && ref($args[-1]) eq 'HASH');
 801     # Back compat hack for applications with old (non Catalyst::Script) scripts to work in FCGI.
 802     if (scalar @args && !ref($args[0])) {
 803         if (my $listen = shift @args) {
 804             $options->{listen} ||= [$listen];
 805         }
 806     }
 807     if (! $server ) {
 808         $server = Catalyst::EngineLoader->new(application_name => ref($self))->auto(%$options);
 809         # We're not being called from a script, so auto detect what backend to
 810         # run on.  This should never happen, as mod_perl never calls ->run,
 811         # instead the $app->handle method is called per request.
 812         $app->log->warn("Not supplied a Plack engine, falling back to engine auto-loader (are your scripts ancient?)")
 813     }
 814     $app->run_options($options);
 815     $server->run($psgi, $options);
 816 }
 817
 818 =head2 build_psgi_app ($app, @args)
 819
 820 Builds and returns a PSGI application closure, wrapping it in the reverse proxy
 821 middleware if the using_frontend_proxy config setting is set.
 822
 823 =cut
 824
 825 sub build_psgi_app {
 826     my ($self, $app, @args) = @_;
 827
 828     return sub {
 829         my ($env) = @_;
 830
 831         return sub {
 832             my ($respond) = @_;
 833             $app->handle_request(env => $env, response_cb => $respond);
 834         };
 835     };
 836 }
 837
 838 =head2 $self->write($c, $buffer)
 839
 840 Writes the buffer to the client.
 841
 842 =cut
 843
 844 sub write {
 845     my ( $self, $c, $buffer ) = @_;
 846
 847     my $response = $c->response;
 848     unless ( $response->_prepared_write ) {
 849         $self->prepare_write($c);
 850         $response->_set_prepared_write(1);
 851     }
 852
 853     $buffer = q[] unless defined $buffer;
 854
 855     my $len = length($buffer);
 856     $c->res->_writer->write($buffer);
 857
 858     return $len;
 859 }
 860
 861 =head2 $self->unescape_uri($uri)
 862
 863 Unescapes a given URI using the most efficient method available.  Engines such
 864 as Apache may implement this using Apache's C-based modules, for example.
 865
 866 =cut
 867
 868 sub unescape_uri {
 869     my ( $self, $str ) = @_;
 870
 871     $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
 872
 873     return $str;
 874 }
 875
 876 =head2 $self->finalize_output
 877
 878 <obsolete>, see finalize_body
 879
 880 =head2 $self->env
 881
 882 Hash containing environment variables including many special variables inserted
 883 by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
 884
 885 Before accessing environment variables consider whether the same information is
 886 not directly available via Catalyst objects $c->request, $c->engine ...
 887
 888 BEWARE: If you really need to access some environment variable from your Catalyst
 889 application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
 890 as in some environments the %ENV hash does not contain what you would expect.
 891
 892 =head1 AUTHORS
 893
 894 Catalyst Contributors, see Catalyst.pm
 895
 896 =head1 COPYRIGHT
 897
 898 This library is free software. You can redistribute it and/or modify it under
 899 the same terms as Perl itself.
 900
 901 =cut
 902
 903 1;