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 $path;
 527     if (!$ctx->config->{use_request_uri_for_path}) {
 528         $path = $base_path . $env->{PATH_INFO};
 529         $path =~ s{^/+}{};
 530         $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
 531         $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
 532     }
 533     else {
 534         my $req_uri = $env->{REQUEST_URI};
 535         $req_uri =~ s/\?.*$//;
 536         $path = $req_uri;
 537         $path =~ s{^/+}{};
 538     }
 539
 540     # Using URI directly is way too slow, so we construct the URLs manually
 541     my $uri_class = "URI::$scheme";
 542
 543     # HTTP_HOST will include the port even if it's 80/443
 544     $host =~ s/:(?:80|443)$//;
 545
 546     if ($port !~ /^(?:80|443)$/ && $host !~ /:/) {
 547         $host .= ":$port";
 548     }
 549
 550     my $query = $env->{QUERY_STRING} ? '?' . $env->{QUERY_STRING} : '';
 551     my $uri   = $scheme . '://' . $host . '/' . $path . $query;
 552
 553     $ctx->request->uri( (bless \$uri, $uri_class)->canonical );
 554
 555     # set the base URI
 556     # base must end in a slash
 557     $base_path .= '/' unless $base_path =~ m{/$};
 558
 559     my $base_uri = $scheme . '://' . $host . $base_path;
 560
 561     $ctx->request->base( bless \$base_uri, $uri_class );
 562
 563     return;
 564 }
 565
 566 =head2 $self->prepare_request($c)
 567
 568 =head2 $self->prepare_query_parameters($c)
 569
 570 process the query string and extract query parameters.
 571
 572 =cut
 573
 574 sub prepare_query_parameters {
 575     my ($self, $c) = @_;
 576
 577     my $query_string = exists $self->env->{QUERY_STRING}
 578         ? $self->env->{QUERY_STRING}
 579         : '';
 580
 581     # Check for keywords (no = signs)
 582     # (yes, index() is faster than a regex :))
 583     if ( index( $query_string, '=' ) < 0 ) {
 584         $c->request->query_keywords( $self->unescape_uri($query_string) );
 585         return;
 586     }
 587
 588     my %query;
 589
 590     # replace semi-colons
 591     $query_string =~ s/;/&/g;
 592
 593     my @params = grep { length $_ } split /&/, $query_string;
 594
 595     for my $item ( @params ) {
 596
 597         my ($param, $value)
 598             = map { $self->unescape_uri($_) }
 599               split( /=/, $item, 2 );
 600
 601         $param = $self->unescape_uri($item) unless defined $param;
 602
 603         if ( exists $query{$param} ) {
 604             if ( ref $query{$param} ) {
 605                 push @{ $query{$param} }, $value;
 606             }
 607             else {
 608                 $query{$param} = [ $query{$param}, $value ];
 609             }
 610         }
 611         else {
 612             $query{$param} = $value;
 613         }
 614     }
 615
 616     $c->request->query_parameters( \%query );
 617 }
 618
 619 =head2 $self->prepare_read($c)
 620
 621 prepare to read from the engine.
 622
 623 =cut
 624
 625 sub prepare_read {
 626     my ( $self, $c ) = @_;
 627
 628     # Initialize the read position
 629     $self->read_position(0);
 630
 631     # Initialize the amount of data we think we need to read
 632     $self->read_length( $c->request->header('Content-Length') || 0 );
 633 }
 634
 635 =head2 $self->prepare_request(@arguments)
 636
 637 Populate the context object from the request object.
 638
 639 =cut
 640
 641 sub prepare_request {
 642     my ($self, $ctx, %args) = @_;
 643     $self->_set_env($args{env});
 644 }
 645
 646 =head2 $self->prepare_uploads($c)
 647
 648 =cut
 649
 650 sub prepare_uploads {
 651     my ( $self, $c ) = @_;
 652
 653     my $request = $c->request;
 654     return unless $request->_body;
 655
 656     my $uploads = $request->_body->upload;
 657     my $parameters = $request->parameters;
 658     foreach my $name (keys %$uploads) {
 659         my $files = $uploads->{$name};
 660         my @uploads;
 661         for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
 662             my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
 663             my $u = Catalyst::Request::Upload->new
 664               (
 665                size => $upload->{size},
 666                type => scalar $headers->content_type,
 667                headers => $headers,
 668                tempname => $upload->{tempname},
 669                filename => $upload->{filename},
 670               );
 671             push @uploads, $u;
 672         }
 673         $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
 674
 675         # support access to the filename as a normal param
 676         my @filenames = map { $_->{filename} } @uploads;
 677         # append, if there's already params with this name
 678         if (exists $parameters->{$name}) {
 679             if (ref $parameters->{$name} eq 'ARRAY') {
 680                 push @{ $parameters->{$name} }, @filenames;
 681             }
 682             else {
 683                 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
 684             }
 685         }
 686         else {
 687             $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
 688         }
 689     }
 690 }
 691
 692 =head2 $self->prepare_write($c)
 693
 694 Abstract method. Implemented by the engines.
 695
 696 =cut
 697
 698 sub prepare_write { }
 699
 700 =head2 $self->read($c, [$maxlength])
 701
 702 Reads from the input stream by calling C<< $self->read_chunk >>.
 703
 704 Maintains the read_length and read_position counters as data is read.
 705
 706 =cut
 707
 708 sub read {
 709     my ( $self, $c, $maxlength ) = @_;
 710
 711     my $remaining = $self->read_length - $self->read_position;
 712     $maxlength ||= $CHUNKSIZE;
 713
 714     # Are we done reading?
 715     if ( $remaining <= 0 ) {
 716         $self->finalize_read($c);
 717         return;
 718     }
 719
 720     my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
 721     my $rc = $self->read_chunk( $c, my $buffer, $readlen );
 722     if ( defined $rc ) {
 723         if (0 == $rc) { # Nothing more to read even though Content-Length
 724                         # said there should be.
 725             $self->finalize_read;
 726             return;
 727         }
 728         $self->read_position( $self->read_position + $rc );
 729         return $buffer;
 730     }
 731     else {
 732         Catalyst::Exception->throw(
 733             message => "Unknown error reading input: $!" );
 734     }
 735 }
 736
 737 =head2 $self->read_chunk($c, $buffer, $length)
 738
 739 Each engine implements read_chunk as its preferred way of reading a chunk
 740 of data. Returns the number of bytes read. A return of 0 indicates that
 741 there is no more data to be read.
 742
 743 =cut
 744
 745 sub read_chunk {
 746     my ($self, $ctx) = (shift, shift);
 747     return $self->env->{'psgi.input'}->read(@_);
 748 }
 749
 750 =head2 $self->read_length
 751
 752 The length of input data to be read.  This is obtained from the Content-Length
 753 header.
 754
 755 =head2 $self->read_position
 756
 757 The amount of input data that has already been read.
 758
 759 =head2 $self->run($app, $server)
 760
 761 Start the engine. Builds a PSGI application and calls the
 762 run method on the server passed in..
 763
 764 =cut
 765
 766 sub run {
 767     my ($self, $app, @args) = @_;
 768     my $server = pop @args if blessed $args[-1];
 769     $server ||= Plack::Loader->auto(); # We're not being called from a script,
 770                                        # so auto detect what backend to run on.
 771                                        # This does *NOT* cover mod_perl.
 772     # FIXME - Do something sensible with the options we're passed
 773     my $psgi = $self->build_psgi_app($app, @args);
 774     $server->run($psgi);
 775 }
 776
 777 =head2 build_psgi_app ($app, @args)
 778
 779 Builds and returns a PSGI application closure, wrapping it in the reverse proxy
 780 middleware if the using_frontend_proxy config setting is set.
 781
 782 =cut
 783
 784 sub build_psgi_app {
 785     my ($self, $app, @args) = @_;
 786
 787     my $psgi_app = sub {
 788         my ($env) = @_;
 789
 790         return sub {
 791             my ($respond) = @_;
 792             $self->_set_response_cb($respond);
 793             $app->handle_request(env => $env);
 794         };
 795     };
 796
 797     $psgi_app = Plack::Middleware::Conditional->wrap(
 798         $psgi_app,
 799         condition => sub {
 800             my ($env) = @_;
 801             return if $app->config->{ignore_frontend_proxy};
 802             return $env->{REMOTE_ADDR} eq '127.0.0.1' || $app->config->{using_frontend_proxy};
 803         },
 804         builder   => sub { Plack::Middleware::ReverseProxy->wrap($_[0]) },
 805     );
 806
 807     return $psgi_app;
 808 }
 809
 810 =head2 $self->write($c, $buffer)
 811
 812 Writes the buffer to the client.
 813
 814 =cut
 815
 816 sub write {
 817     my ( $self, $c, $buffer ) = @_;
 818
 819     unless ( $self->_prepared_write ) {
 820         $self->prepare_write($c);
 821         $self->_prepared_write(1);
 822     }
 823
 824     return 0 if !defined $buffer;
 825
 826     my $len = length($buffer);
 827     $self->_writer->write($buffer);
 828
 829     return $len;
 830 }
 831
 832 =head2 $self->unescape_uri($uri)
 833
 834 Unescapes a given URI using the most efficient method available.  Engines such
 835 as Apache may implement this using Apache's C-based modules, for example.
 836
 837 =cut
 838
 839 sub unescape_uri {
 840     my ( $self, $str ) = @_;
 841
 842     $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
 843
 844     return $str;
 845 }
 846
 847 =head2 $self->finalize_output
 848
 849 <obsolete>, see finalize_body
 850
 851 =head2 $self->env
 852
 853 Hash containing environment variables including many special variables inserted
 854 by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
 855
 856 Before accessing environment variables consider whether the same information is
 857 not directly available via Catalyst objects $c->request, $c->engine ...
 858
 859 BEWARE: If you really need to access some environment variable from your Catalyst
 860 application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
 861 as in some enviroments the %ENV hash does not contain what you would expect.
 862
 863 =head1 AUTHORS
 864
 865 Catalyst Contributors, see Catalyst.pm
 866
 867 =head1 COPYRIGHT
 868
 869 This library is free software. You can redistribute it and/or modify it under
 870 the same terms as Perl itself.
 871
 872 =cut
 873
 874 1;