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