lib/Catalyst/Engine.pm

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