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