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