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