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