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