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.
  58
  59 =cut
  60
  61 sub finalize_body {
  62     my ( $self, $c ) = @_;
  63     my $body = $c->response->body;
  64     no warnings 'uninitialized';
  65     if ( blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
  66         my $got;
  67         do {
  68             $got = read $body, my ($buffer), $CHUNKSIZE;
  69             $got = 0 unless $self->write( $c, $buffer );
  70         } while $got > 0;
  71
  72         close $body;
  73     }
  74     else {
  75         $self->write( $c, $body );
  76     }
  77
  78     my $res = $c->response;
  79     $res->_writer->close;
  80     $res->_clear_writer;
  81
  82     return;
  83 }
  84
  85 =head2 $self->finalize_cookies($c)
  86
  87 Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
  88 response headers.
  89
  90 =cut
  91
  92 sub finalize_cookies {
  93     my ( $self, $c ) = @_;
  94
  95     my @cookies;
  96     my $response = $c->response;
  97
  98     foreach my $name (keys %{ $response->cookies }) {
  99
 100         my $val = $response->cookies->{$name};
 101
 102         my $cookie = (
 103             blessed($val)
 104             ? $val
 105             : CGI::Simple::Cookie->new(
 106                 -name    => $name,
 107                 -value   => $val->{value},
 108                 -expires => $val->{expires},
 109                 -domain  => $val->{domain},
 110                 -path    => $val->{path},
 111                 -secure  => $val->{secure} || 0,
 112                 -httponly => $val->{httponly} || 0,
 113             )
 114         );
 115         if (!defined $cookie) {
 116             $c->log->warn("undef passed in '$name' cookie value - not setting cookie")
 117                 if $c->debug;
 118             next;
 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 Allows engines to write headers to response
 329
 330 =cut
 331
 332 sub finalize_headers {
 333     my ($self, $ctx) = @_;
 334
 335     $ctx->response->finalize_headers;
 336     return;
 337 }
 338
 339 =head2 $self->finalize_uploads($c)
 340
 341 Clean up after uploads, deleting temp files.
 342
 343 =cut
 344
 345 sub finalize_uploads {
 346     my ( $self, $c ) = @_;
 347
 348     # N.B. This code is theoretically entirely unneeded due to ->cleanup(1)
 349     #      on the HTTP::Body object.
 350     my $request = $c->request;
 351     foreach my $key (keys %{ $request->uploads }) {
 352         my $upload = $request->uploads->{$key};
 353         unlink grep { -e $_ } map { $_->tempname }
 354           (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
 355     }
 356
 357 }
 358
 359 =head2 $self->prepare_body($c)
 360
 361 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
 362
 363 =cut
 364
 365 sub prepare_body {
 366     my ( $self, $c ) = @_;
 367
 368     $c->request->prepare_body;
 369 }
 370
 371 =head2 $self->prepare_body_chunk($c)
 372
 373 Add a chunk to the request body.
 374
 375 =cut
 376
 377 # XXX - Can this be deleted?
 378 sub prepare_body_chunk {
 379     my ( $self, $c, $chunk ) = @_;
 380
 381     $c->request->prepare_body_chunk($chunk);
 382 }
 383
 384 =head2 $self->prepare_body_parameters($c)
 385
 386 Sets up parameters from body.
 387
 388 =cut
 389
 390 sub prepare_body_parameters {
 391     my ( $self, $c ) = @_;
 392
 393     $c->request->prepare_body_parameters;
 394 }
 395
 396 =head2 $self->prepare_parameters($c)
 397
 398 sets up parameters from query and post parameters.
 399
 400 =cut
 401
 402 sub prepare_parameters {
 403     my ( $self, $c ) = @_;
 404
 405     $c->request->parameters;
 406 }
 407
 408 =head2 $self->prepare_path($c)
 409
 410 abstract method, implemented by engines.
 411
 412 =cut
 413
 414 sub prepare_path {
 415     my ($self, $ctx) = @_;
 416
 417     my $env = $ctx->request->env;
 418
 419     my $scheme    = $ctx->request->secure ? 'https' : 'http';
 420     my $host      = $env->{HTTP_HOST} || $env->{SERVER_NAME};
 421     my $port      = $env->{SERVER_PORT} || 80;
 422     my $base_path = $env->{SCRIPT_NAME} || "/";
 423
 424     # set the request URI
 425     my $path;
 426     if (!$ctx->config->{use_request_uri_for_path}) {
 427         my $path_info = $env->{PATH_INFO};
 428         if ( exists $env->{REDIRECT_URL} ) {
 429             $base_path = $env->{REDIRECT_URL};
 430             $base_path =~ s/\Q$path_info\E$//;
 431         }
 432         $path = $base_path . $path_info;
 433         $path =~ s{^/+}{};
 434         $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
 435         $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
 436     }
 437     else {
 438         my $req_uri = $env->{REQUEST_URI};
 439         $req_uri =~ s/\?.*$//;
 440         $path = $req_uri;
 441         $path =~ s{^/+}{};
 442     }
 443
 444     # Using URI directly is way too slow, so we construct the URLs manually
 445     my $uri_class = "URI::$scheme";
 446
 447     # HTTP_HOST will include the port even if it's 80/443
 448     $host =~ s/:(?:80|443)$//;
 449
 450     if ($port !~ /^(?:80|443)$/ && $host !~ /:/) {
 451         $host .= ":$port";
 452     }
 453
 454     my $query = $env->{QUERY_STRING} ? '?' . $env->{QUERY_STRING} : '';
 455     my $uri   = $scheme . '://' . $host . '/' . $path . $query;
 456
 457     $ctx->request->uri( (bless \$uri, $uri_class)->canonical );
 458
 459     # set the base URI
 460     # base must end in a slash
 461     $base_path .= '/' unless $base_path =~ m{/$};
 462
 463     my $base_uri = $scheme . '://' . $host . $base_path;
 464
 465     $ctx->request->base( bless \$base_uri, $uri_class );
 466
 467     return;
 468 }
 469
 470 =head2 $self->prepare_request($c)
 471
 472 =head2 $self->prepare_query_parameters($c)
 473
 474 process the query string and extract query parameters.
 475
 476 =cut
 477
 478 sub prepare_query_parameters {
 479     my ($self, $c) = @_;
 480
 481     my $env = $c->request->env;
 482     my $query_string = exists $env->{QUERY_STRING}
 483         ? $env->{QUERY_STRING}
 484         : '';
 485
 486     # Check for keywords (no = signs)
 487     # (yes, index() is faster than a regex :))
 488     if ( index( $query_string, '=' ) < 0 ) {
 489         $c->request->query_keywords( $self->unescape_uri($query_string) );
 490         return;
 491     }
 492
 493     my %query;
 494
 495     # replace semi-colons
 496     $query_string =~ s/;/&/g;
 497
 498     my @params = grep { length $_ } split /&/, $query_string;
 499
 500     for my $item ( @params ) {
 501
 502         my ($param, $value)
 503             = map { $self->unescape_uri($_) }
 504               split( /=/, $item, 2 );
 505
 506         $param = $self->unescape_uri($item) unless defined $param;
 507
 508         if ( exists $query{$param} ) {
 509             if ( ref $query{$param} ) {
 510                 push @{ $query{$param} }, $value;
 511             }
 512             else {
 513                 $query{$param} = [ $query{$param}, $value ];
 514             }
 515         }
 516         else {
 517             $query{$param} = $value;
 518         }
 519     }
 520     $c->request->query_parameters( \%query );
 521 }
 522
 523 =head2 $self->prepare_read($c)
 524
 525 Prepare to read by initializing the Content-Length from headers.
 526
 527 =cut
 528
 529 sub prepare_read {
 530     my ( $self, $c ) = @_;
 531
 532     # Initialize the amount of data we think we need to read
 533     $c->request->_read_length;
 534 }
 535
 536 =head2 $self->prepare_request(@arguments)
 537
 538 Sets up the PSGI environment in the Engine.
 539
 540 =cut
 541
 542 sub prepare_request {
 543     my ($self, $ctx, %args) = @_;
 544     $ctx->request->_set_env($args{env});
 545     $self->_set_env($args{env}); # Nasty back compat!
 546     $ctx->response->_set_response_cb($args{response_cb});
 547 }
 548
 549 =head2 $self->prepare_uploads($c)
 550
 551 =cut
 552
 553 sub prepare_uploads {
 554     my ( $self, $c ) = @_;
 555
 556     my $request = $c->request;
 557     return unless $request->_body;
 558
 559     my $uploads = $request->_body->upload;
 560     my $parameters = $request->parameters;
 561     foreach my $name (keys %$uploads) {
 562         my $files = $uploads->{$name};
 563         my @uploads;
 564         for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
 565             my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
 566             my $u = Catalyst::Request::Upload->new
 567               (
 568                size => $upload->{size},
 569                type => scalar $headers->content_type,
 570                headers => $headers,
 571                tempname => $upload->{tempname},
 572                filename => $upload->{filename},
 573               );
 574             push @uploads, $u;
 575         }
 576         $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
 577
 578         # support access to the filename as a normal param
 579         my @filenames = map { $_->{filename} } @uploads;
 580         # append, if there's already params with this name
 581         if (exists $parameters->{$name}) {
 582             if (ref $parameters->{$name} eq 'ARRAY') {
 583                 push @{ $parameters->{$name} }, @filenames;
 584             }
 585             else {
 586                 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
 587             }
 588         }
 589         else {
 590             $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
 591         }
 592     }
 593 }
 594
 595 =head2 $self->write($c, $buffer)
 596
 597 Writes the buffer to the client.
 598
 599 =cut
 600
 601 sub write {
 602     my ( $self, $c, $buffer ) = @_;
 603
 604     $c->response->write($buffer);
 605 }
 606
 607 =head2 $self->read($c, [$maxlength])
 608
 609 Reads from the input stream by calling C<< $self->read_chunk >>.
 610
 611 Maintains the read_length and read_position counters as data is read.
 612
 613 =cut
 614
 615 sub read {
 616     my ( $self, $c, $maxlength ) = @_;
 617
 618     $c->request->read($maxlength);
 619 }
 620
 621 =head2 $self->read_chunk($c, \$buffer, $length)
 622
 623 Each engine implements read_chunk as its preferred way of reading a chunk
 624 of data. Returns the number of bytes read. A return of 0 indicates that
 625 there is no more data to be read.
 626
 627 =cut
 628
 629 sub read_chunk {
 630     my ($self, $ctx) = (shift, shift);
 631     return $ctx->request->read_chunk(@_);
 632 }
 633
 634 =head2 $self->run($app, $server)
 635
 636 Start the engine. Builds a PSGI application and calls the
 637 run method on the server passed in, which then causes the
 638 engine to loop, handling requests..
 639
 640 =cut
 641
 642 sub run {
 643     my ($self, $app, $psgi, @args) = @_;
 644     # @args left here rather than just a $options, $server for back compat with the
 645     # old style scripts which send a few args, then a hashref
 646
 647     # They should never actually be used in the normal case as the Plack engine is
 648     # passed in got all the 'standard' args via the loader in the script already.
 649
 650     # FIXME - we should stash the options in an attribute so that custom args
 651     # like Gitalist's --git_dir are possible to get from the app without stupid tricks.
 652     my $server = pop @args if (scalar @args && blessed $args[-1]);
 653     my $options = pop @args if (scalar @args && ref($args[-1]) eq 'HASH');
 654     # Back compat hack for applications with old (non Catalyst::Script) scripts to work in FCGI.
 655     if (scalar @args && !ref($args[0])) {
 656         if (my $listen = shift @args) {
 657             $options->{listen} ||= [$listen];
 658         }
 659     }
 660     if (! $server ) {
 661         $server = Catalyst::EngineLoader->new(application_name => ref($self))->auto(%$options);
 662         # We're not being called from a script, so auto detect what backend to
 663         # run on.  This should never happen, as mod_perl never calls ->run,
 664         # instead the $app->handle method is called per request.
 665         $app->log->warn("Not supplied a Plack engine, falling back to engine auto-loader (are your scripts ancient?)")
 666     }
 667     $app->run_options($options);
 668     $server->run($psgi, $options);
 669 }
 670
 671 =head2 build_psgi_app ($app, @args)
 672
 673 Builds and returns a PSGI application closure. (Raw, not wrapped in middleware)
 674
 675 =cut
 676
 677 sub build_psgi_app {
 678     my ($self, $app, @args) = @_;
 679
 680     return sub {
 681         my ($env) = @_;
 682
 683         return sub {
 684             my ($respond) = @_;
 685             $app->handle_request(env => $env, response_cb => $respond);
 686         };
 687     };
 688 }
 689
 690 =head2 $self->unescape_uri($uri)
 691
 692 Unescapes a given URI using the most efficient method available.  Engines such
 693 as Apache may implement this using Apache's C-based modules, for example.
 694
 695 =cut
 696
 697 sub unescape_uri {
 698     my ( $self, $str ) = @_;
 699
 700     $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
 701
 702     return $str;
 703 }
 704
 705 =head2 $self->finalize_output
 706
 707 <obsolete>, see finalize_body
 708
 709 =head2 $self->env
 710
 711 Hash containing environment variables including many special variables inserted
 712 by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
 713
 714 Before accessing environment variables consider whether the same information is
 715 not directly available via Catalyst objects $c->request, $c->engine ...
 716
 717 BEWARE: If you really need to access some environment variable from your Catalyst
 718 application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
 719 as in some environments the %ENV hash does not contain what you would expect.
 720
 721 =head1 AUTHORS
 722
 723 Catalyst Contributors, see Catalyst.pm
 724
 725 =head1 COPYRIGHT
 726
 727 This library is free software. You can redistribute it and/or modify it under
 728 the same terms as Perl itself.
 729
 730 =cut
 731
 732 1;