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->res->_clear_context;
 185
 186         # Don't show body parser in the dump
 187         $c->req->_clear_body;
 188
 189         my @infos;
 190         my $i = 0;
 191         for my $dump ( $c->dump_these ) {
 192             push @infos, $self->_dump_error_page_element($i, $dump);
 193             $i++;
 194         }
 195         $infos = join "\n", @infos;
 196     }
 197     else {
 198         $title = $name;
 199         $error = '';
 200         $infos = <<"";
 201 <pre>
 202 (en) Please come back later
 203 (fr) SVP veuillez revenir plus tard
 204 (de) Bitte versuchen sie es spaeter nocheinmal
 205 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
 206 (no) Vennligst prov igjen senere
 207 (dk) Venligst prov igen senere
 208 (pl) Prosze sprobowac pozniej
 209 (pt) Por favor volte mais tarde
 210 (ru) Попробуйте еще раз позже
 211 (ua) Спробуйте ще раз пізніше
 212 </pre>
 213
 214         $name = '';
 215     }
 216     $c->res->body( <<"" );
 217 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 218     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 219 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
 220 <head>
 221     <meta http-equiv="Content-Language" content="en" />
 222     <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
 223     <title>$title</title>
 224     <script type="text/javascript">
 225         <!--
 226         function toggleDump (dumpElement) {
 227             var e = document.getElementById( dumpElement );
 228             if (e.style.display == "none") {
 229                 e.style.display = "";
 230             }
 231             else {
 232                 e.style.display = "none";
 233             }
 234         }
 235         -->
 236     </script>
 237     <style type="text/css">
 238         body {
 239             font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
 240                          Tahoma, Arial, helvetica, sans-serif;
 241             color: #333;
 242             background-color: #eee;
 243             margin: 0px;
 244             padding: 0px;
 245         }
 246         :link, :link:hover, :visited, :visited:hover {
 247             color: #000;
 248         }
 249         div.box {
 250             position: relative;
 251             background-color: #ccc;
 252             border: 1px solid #aaa;
 253             padding: 4px;
 254             margin: 10px;
 255         }
 256         div.error {
 257             background-color: #cce;
 258             border: 1px solid #755;
 259             padding: 8px;
 260             margin: 4px;
 261             margin-bottom: 10px;
 262         }
 263         div.infos {
 264             background-color: #eee;
 265             border: 1px solid #575;
 266             padding: 8px;
 267             margin: 4px;
 268             margin-bottom: 10px;
 269         }
 270         div.name {
 271             background-color: #cce;
 272             border: 1px solid #557;
 273             padding: 8px;
 274             margin: 4px;
 275         }
 276         code.error {
 277             display: block;
 278             margin: 1em 0;
 279             overflow: auto;
 280         }
 281         div.name h1, div.error p {
 282             margin: 0;
 283         }
 284         h2 {
 285             margin-top: 0;
 286             margin-bottom: 10px;
 287             font-size: medium;
 288             font-weight: bold;
 289             text-decoration: underline;
 290         }
 291         h1 {
 292             font-size: medium;
 293             font-weight: normal;
 294         }
 295         /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
 296         /* Browser specific (not valid) styles to make preformatted text wrap */
 297         pre {
 298             white-space: pre-wrap;       /* css-3 */
 299             white-space: -moz-pre-wrap;  /* Mozilla, since 1999 */
 300             white-space: -pre-wrap;      /* Opera 4-6 */
 301             white-space: -o-pre-wrap;    /* Opera 7 */
 302             word-wrap: break-word;       /* Internet Explorer 5.5+ */
 303         }
 304     </style>
 305 </head>
 306 <body>
 307     <div class="box">
 308         <div class="error">$error</div>
 309         <div class="infos">$infos</div>
 310         <div class="name">$name</div>
 311     </div>
 312 </body>
 313 </html>
 314
 315     # Trick IE. Old versions of IE would display their own error page instead
 316     # of ours if we'd give it less than 512 bytes.
 317     $c->res->{body} .= ( ' ' x 512 );
 318
 319     $c->res->{body} = Encode::encode("UTF-8", $c->res->{body});
 320
 321     # Return 500
 322     $c->res->status(500);
 323 }
 324
 325 =head2 $self->finalize_headers($c)
 326
 327 Allows engines to write headers to response
 328
 329 =cut
 330
 331 sub finalize_headers {
 332     my ($self, $ctx) = @_;
 333
 334     $ctx->finalize_headers unless $ctx->response->finalized_headers;
 335     return;
 336 }
 337
 338 =head2 $self->finalize_uploads($c)
 339
 340 Clean up after uploads, deleting temp files.
 341
 342 =cut
 343
 344 sub finalize_uploads {
 345     my ( $self, $c ) = @_;
 346
 347     # N.B. This code is theoretically entirely unneeded due to ->cleanup(1)
 348     #      on the HTTP::Body object.
 349     my $request = $c->request;
 350     foreach my $key (keys %{ $request->uploads }) {
 351         my $upload = $request->uploads->{$key};
 352         unlink grep { -e $_ } map { $_->tempname }
 353           (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
 354     }
 355
 356 }
 357
 358 =head2 $self->prepare_body($c)
 359
 360 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
 361
 362 =cut
 363
 364 sub prepare_body {
 365     my ( $self, $c ) = @_;
 366
 367     $c->request->prepare_body;
 368 }
 369
 370 =head2 $self->prepare_body_chunk($c)
 371
 372 Add a chunk to the request body.
 373
 374 =cut
 375
 376 # XXX - Can this be deleted?
 377 sub prepare_body_chunk {
 378     my ( $self, $c, $chunk ) = @_;
 379
 380     $c->request->prepare_body_chunk($chunk);
 381 }
 382
 383 =head2 $self->prepare_body_parameters($c)
 384
 385 Sets up parameters from body.
 386
 387 =cut
 388
 389 sub prepare_body_parameters {
 390     my ( $self, $c ) = @_;
 391
 392     $c->request->prepare_body_parameters;
 393 }
 394
 395 =head2 $self->prepare_parameters($c)
 396
 397 Sets up parameters from query and post parameters.
 398 If parameters have already been set up will clear
 399 existing parameters and set up again.
 400
 401 =cut
 402
 403 sub prepare_parameters {
 404     my ( $self, $c ) = @_;
 405
 406     $c->request->_clear_parameters;
 407     return $c->request->parameters;
 408 }
 409
 410 =head2 $self->prepare_path($c)
 411
 412 abstract method, implemented by engines.
 413
 414 =cut
 415
 416 sub prepare_path {
 417     my ($self, $ctx) = @_;
 418
 419     my $env = $ctx->request->env;
 420
 421     my $scheme    = $ctx->request->secure ? 'https' : 'http';
 422     my $host      = $env->{HTTP_HOST} || $env->{SERVER_NAME};
 423     my $port      = $env->{SERVER_PORT} || 80;
 424     my $base_path = $env->{SCRIPT_NAME} || "/";
 425
 426     # set the request URI
 427     my $path;
 428     if (!$ctx->config->{use_request_uri_for_path}) {
 429         my $path_info = $env->{PATH_INFO};
 430         if ( exists $env->{REDIRECT_URL} ) {
 431             $base_path = $env->{REDIRECT_URL};
 432             $base_path =~ s/\Q$path_info\E$//;
 433         }
 434         $path = $base_path . $path_info;
 435         $path =~ s{^/+}{};
 436         $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
 437         $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
 438     }
 439     else {
 440         my $req_uri = $env->{REQUEST_URI};
 441         $req_uri =~ s/\?.*$//;
 442         $path = $req_uri;
 443         $path =~ s{^/+}{};
 444     }
 445
 446     # Using URI directly is way too slow, so we construct the URLs manually
 447     my $uri_class = "URI::$scheme";
 448
 449     # HTTP_HOST will include the port even if it's 80/443
 450     $host =~ s/:(?:80|443)$//;
 451
 452     if ($port !~ /^(?:80|443)$/ && $host !~ /:/) {
 453         $host .= ":$port";
 454     }
 455
 456     my $query = $env->{QUERY_STRING} ? '?' . $env->{QUERY_STRING} : '';
 457     my $uri   = $scheme . '://' . $host . '/' . $path . $query;
 458
 459     $ctx->request->uri( (bless \$uri, $uri_class)->canonical );
 460
 461     # set the base URI
 462     # base must end in a slash
 463     $base_path .= '/' unless $base_path =~ m{/$};
 464
 465     my $base_uri = $scheme . '://' . $host . $base_path;
 466
 467     $ctx->request->base( bless \$base_uri, $uri_class );
 468
 469     return;
 470 }
 471
 472 =head2 $self->prepare_request($c)
 473
 474 =head2 $self->prepare_query_parameters($c)
 475
 476 process the query string and extract query parameters.
 477
 478 =cut
 479
 480 sub prepare_query_parameters {
 481     my ($self, $c) = @_;
 482
 483     my $env = $c->request->env;
 484     my $query_string = exists $env->{QUERY_STRING}
 485         ? $env->{QUERY_STRING}
 486         : '';
 487
 488     # Check for keywords (no = signs)
 489     # (yes, index() is faster than a regex :))
 490     if ( index( $query_string, '=' ) < 0 ) {
 491         $c->request->query_keywords( $self->unescape_uri($query_string) );
 492         return;
 493     }
 494
 495     my %query;
 496
 497     # replace semi-colons
 498     $query_string =~ s/;/&/g;
 499
 500     my @params = grep { length $_ } split /&/, $query_string;
 501
 502     for my $item ( @params ) {
 503
 504         my ($param, $value)
 505             = map { $self->unescape_uri($_) }
 506               split( /=/, $item, 2 );
 507
 508         $param = $self->unescape_uri($item) unless defined $param;
 509
 510         if ( exists $query{$param} ) {
 511             if ( ref $query{$param} ) {
 512                 push @{ $query{$param} }, $value;
 513             }
 514             else {
 515                 $query{$param} = [ $query{$param}, $value ];
 516             }
 517         }
 518         else {
 519             $query{$param} = $value;
 520         }
 521     }
 522     $c->request->query_parameters( \%query );
 523 }
 524
 525 =head2 $self->prepare_read($c)
 526
 527 Prepare to read by initializing the Content-Length from headers.
 528
 529 =cut
 530
 531 sub prepare_read {
 532     my ( $self, $c ) = @_;
 533
 534     # Initialize the amount of data we think we need to read
 535     $c->request->_read_length;
 536 }
 537
 538 =head2 $self->prepare_request(@arguments)
 539
 540 Populate the context object from the request object.
 541
 542 =cut
 543
 544 sub prepare_request {
 545     my ($self, $ctx, %args) = @_;
 546     $ctx->log->psgienv($args{env}) if $ctx->log->can('psgienv');
 547     $ctx->request->_set_env($args{env});
 548     $self->_set_env($args{env}); # Nasty back compat!
 549     $ctx->response->_set_response_cb($args{response_cb});
 550 }
 551
 552 =head2 $self->prepare_uploads($c)
 553
 554 =cut
 555
 556 sub prepare_uploads {
 557     my ( $self, $c ) = @_;
 558
 559     my $request = $c->request;
 560     return unless $request->_body;
 561
 562     my $uploads = $request->_body->upload;
 563     my $parameters = $request->parameters;
 564     foreach my $name (keys %$uploads) {
 565         my $files = $uploads->{$name};
 566         my @uploads;
 567         for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
 568             my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
 569             my $u = Catalyst::Request::Upload->new
 570               (
 571                size => $upload->{size},
 572                type => scalar $headers->content_type,
 573                headers => $headers,
 574                tempname => $upload->{tempname},
 575                filename => $upload->{filename},
 576               );
 577             push @uploads, $u;
 578         }
 579         $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
 580
 581         # support access to the filename as a normal param
 582         my @filenames = map { $_->{filename} } @uploads;
 583         # append, if there's already params with this name
 584         if (exists $parameters->{$name}) {
 585             if (ref $parameters->{$name} eq 'ARRAY') {
 586                 push @{ $parameters->{$name} }, @filenames;
 587             }
 588             else {
 589                 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
 590             }
 591         }
 592         else {
 593             $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
 594         }
 595     }
 596 }
 597
 598 =head2 $self->write($c, $buffer)
 599
 600 Writes the buffer to the client.
 601
 602 =cut
 603
 604 sub write {
 605     my ( $self, $c, $buffer ) = @_;
 606
 607     $c->response->write($buffer);
 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->run($app, $server)
 638
 639 Start the engine. Builds a PSGI application and calls the
 640 run method on the server passed in, which then causes the
 641 engine to loop, handling requests..
 642
 643 =cut
 644
 645 sub run {
 646     my ($self, $app, $psgi, @args) = @_;
 647     # @args left here rather than just a $options, $server for back compat with the
 648     # old style scripts which send a few args, then a hashref
 649
 650     # They should never actually be used in the normal case as the Plack engine is
 651     # passed in got all the 'standard' args via the loader in the script already.
 652
 653     # FIXME - we should stash the options in an attribute so that custom args
 654     # like Gitalist's --git_dir are possible to get from the app without stupid tricks.
 655     my $server = pop @args if (scalar @args && blessed $args[-1]);
 656     my $options = pop @args if (scalar @args && ref($args[-1]) eq 'HASH');
 657     # Back compat hack for applications with old (non Catalyst::Script) scripts to work in FCGI.
 658     if (scalar @args && !ref($args[0])) {
 659         if (my $listen = shift @args) {
 660             $options->{listen} ||= [$listen];
 661         }
 662     }
 663     if (! $server ) {
 664         $server = Catalyst::EngineLoader->new(application_name => ref($self))->auto(%$options);
 665         # We're not being called from a script, so auto detect what backend to
 666         # run on.  This should never happen, as mod_perl never calls ->run,
 667         # instead the $app->handle method is called per request.
 668         $app->log->warn("Not supplied a Plack engine, falling back to engine auto-loader (are your scripts ancient?)")
 669     }
 670     $app->run_options($options);
 671     $server->run($psgi, $options);
 672 }
 673
 674 =head2 build_psgi_app ($app, @args)
 675
 676 Builds and returns a PSGI application closure. (Raw, not wrapped in middleware)
 677
 678 =cut
 679
 680 sub build_psgi_app {
 681     my ($self, $app, @args) = @_;
 682
 683     return sub {
 684         my ($env) = @_;
 685
 686         return sub {
 687             my ($respond) = @_;
 688             confess("Did not get a response callback for writer, cannot continiue") unless $respond;
 689             $app->handle_request(env => $env, response_cb => $respond);
 690         };
 691     };
 692 }
 693
 694 =head2 $self->unescape_uri($uri)
 695
 696 Unescapes a given URI using the most efficient method available.  Engines such
 697 as Apache may implement this using Apache's C-based modules, for example.
 698
 699 =cut
 700
 701 sub unescape_uri {
 702     my ( $self, $str ) = @_;
 703
 704     $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
 705
 706     return $str;
 707 }
 708
 709 =head2 $self->finalize_output
 710
 711 <obsolete>, see finalize_body
 712
 713 =head2 $self->env
 714
 715 Hash containing environment variables including many special variables inserted
 716 by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
 717
 718 Before accessing environment variables consider whether the same information is
 719 not directly available via Catalyst objects $c->request, $c->engine ...
 720
 721 BEWARE: If you really need to access some environment variable from your Catalyst
 722 application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
 723 as in some environments the %ENV hash does not contain what you would expect.
 724
 725 =head1 AUTHORS
 726
 727 Catalyst Contributors, see Catalyst.pm
 728
 729 =head1 COPYRIGHT
 730
 731 This library is free software. You can redistribute it and/or modify it under
 732 the same terms as Perl itself.
 733
 734 =cut
 735
 736 __PACKAGE__->meta->make_immutable;
 737
 738 1;