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