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