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