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