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