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