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