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