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