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
 284     $c->res->{body} .= ( ' ' x 512 );
 285
 286     # Return 500
 287     $c->res->status(500);
 288 }
 289
 290 =head2 $self->finalize_headers($c)
 291
 292 Abstract method, allows engines to write headers to response
 293
 294 =cut
 295
 296 sub finalize_headers { }
 297
 298 =head2 $self->finalize_read($c)
 299
 300 =cut
 301
 302 sub finalize_read { }
 303
 304 =head2 $self->finalize_uploads($c)
 305
 306 Clean up after uploads, deleting temp files.
 307
 308 =cut
 309
 310 sub finalize_uploads {
 311     my ( $self, $c ) = @_;
 312
 313     my $request = $c->request;
 314     foreach my $key (keys %{ $request->uploads }) {
 315         my $upload = $request->uploads->{$key};
 316         unlink grep { -e $_ } map { $_->tempname }
 317           (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
 318     }
 319
 320 }
 321
 322 =head2 $self->prepare_body($c)
 323
 324 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
 325
 326 =cut
 327
 328 sub prepare_body {
 329     my ( $self, $c ) = @_;
 330
 331     my $appclass = ref($c) || $c;
 332     if ( my $length = $self->read_length ) {
 333         my $request = $c->request;
 334         unless ( $request->_body ) {
 335             my $type = $request->header('Content-Type');
 336             $request->_body(HTTP::Body->new( $type, $length ));
 337             $request->_body->tmpdir( $appclass->config->{uploadtmp} )
 338               if exists $appclass->config->{uploadtmp};
 339         }
 340
 341         # Check for definedness as you could read '0'
 342         while ( defined ( my $buffer = $self->read($c) ) ) {
 343             $c->prepare_body_chunk($buffer);
 344         }
 345
 346         # paranoia against wrong Content-Length header
 347         my $remaining = $length - $self->read_position;
 348         if ( $remaining > 0 ) {
 349             $self->finalize_read($c);
 350             Catalyst::Exception->throw(
 351                 "Wrong Content-Length value: $length" );
 352         }
 353     }
 354     else {
 355         # Defined but will cause all body code to be skipped
 356         $c->request->_body(0);
 357     }
 358 }
 359
 360 =head2 $self->prepare_body_chunk($c)
 361
 362 Add a chunk to the request body.
 363
 364 =cut
 365
 366 sub prepare_body_chunk {
 367     my ( $self, $c, $chunk ) = @_;
 368
 369     $c->request->_body->add($chunk);
 370 }
 371
 372 =head2 $self->prepare_body_parameters($c)
 373
 374 Sets up parameters from body.
 375
 376 =cut
 377
 378 sub prepare_body_parameters {
 379     my ( $self, $c ) = @_;
 380
 381     return unless $c->request->_body;
 382
 383     $c->request->body_parameters( $c->request->_body->param );
 384 }
 385
 386 =head2 $self->prepare_connection($c)
 387
 388 Abstract method implemented in engines.
 389
 390 =cut
 391
 392 sub prepare_connection { }
 393
 394 =head2 $self->prepare_cookies($c)
 395
 396 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
 397
 398 =cut
 399
 400 sub prepare_cookies {
 401     my ( $self, $c ) = @_;
 402
 403     if ( my $header = $c->request->header('Cookie') ) {
 404         $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
 405     }
 406 }
 407
 408 =head2 $self->prepare_headers($c)
 409
 410 =cut
 411
 412 sub prepare_headers { }
 413
 414 =head2 $self->prepare_parameters($c)
 415
 416 sets up parameters from query and post parameters.
 417
 418 =cut
 419
 420 sub prepare_parameters {
 421     my ( $self, $c ) = @_;
 422
 423     my $request = $c->request;
 424     my $parameters = $request->parameters;
 425     my $body_parameters = $request->body_parameters;
 426     my $query_parameters = $request->query_parameters;
 427     # We copy, no references
 428     foreach my $name (keys %$query_parameters) {
 429         my $param = $query_parameters->{$name};
 430         $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
 431     }
 432
 433     # Merge query and body parameters
 434     foreach my $name (keys %$body_parameters) {
 435         my $param = $body_parameters->{$name};
 436         my @values = ref $param eq 'ARRAY' ? @$param : ($param);
 437         if ( my $existing = $parameters->{$name} ) {
 438           unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
 439         }
 440         $parameters->{$name} = @values > 1 ? \@values : $values[0];
 441     }
 442 }
 443
 444 =head2 $self->prepare_path($c)
 445
 446 abstract method, implemented by engines.
 447
 448 =cut
 449
 450 sub prepare_path { }
 451
 452 =head2 $self->prepare_request($c)
 453
 454 =head2 $self->prepare_query_parameters($c)
 455
 456 process the query string and extract query parameters.
 457
 458 =cut
 459
 460 sub prepare_query_parameters {
 461     my ( $self, $c, $query_string ) = @_;
 462
 463     # Check for keywords (no = signs)
 464     # (yes, index() is faster than a regex :))
 465     if ( index( $query_string, '=' ) < 0 ) {
 466         $c->request->query_keywords( $self->unescape_uri($query_string) );
 467         return;
 468     }
 469
 470     my %query;
 471
 472     # replace semi-colons
 473     $query_string =~ s/;/&/g;
 474
 475     my @params = grep { length $_ } split /&/, $query_string;
 476
 477     for my $item ( @params ) {
 478
 479         my ($param, $value)
 480             = map { $self->unescape_uri($_) }
 481               split( /=/, $item, 2 );
 482
 483         $param = $self->unescape_uri($item) unless defined $param;
 484
 485         if ( exists $query{$param} ) {
 486             if ( ref $query{$param} ) {
 487                 push @{ $query{$param} }, $value;
 488             }
 489             else {
 490                 $query{$param} = [ $query{$param}, $value ];
 491             }
 492         }
 493         else {
 494             $query{$param} = $value;
 495         }
 496     }
 497
 498     $c->request->query_parameters( \%query );
 499 }
 500
 501 =head2 $self->prepare_read($c)
 502
 503 prepare to read from the engine.
 504
 505 =cut
 506
 507 sub prepare_read {
 508     my ( $self, $c ) = @_;
 509
 510     # Initialize the read position
 511     $self->read_position(0);
 512
 513     # Initialize the amount of data we think we need to read
 514     $self->read_length( $c->request->header('Content-Length') || 0 );
 515 }
 516
 517 =head2 $self->prepare_request(@arguments)
 518
 519 Populate the context object from the request object.
 520
 521 =cut
 522
 523 sub prepare_request { }
 524
 525 =head2 $self->prepare_uploads($c)
 526
 527 =cut
 528
 529 sub prepare_uploads {
 530     my ( $self, $c ) = @_;
 531
 532     my $request = $c->request;
 533     return unless $request->_body;
 534
 535     my $uploads = $request->_body->upload;
 536     my $parameters = $request->parameters;
 537     foreach my $name (keys %$uploads) {
 538         my $files = $uploads->{$name};
 539         my @uploads;
 540         for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
 541             my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
 542             my $u = Catalyst::Request::Upload->new
 543               (
 544                size => $upload->{size},
 545                type => $headers->content_type,
 546                headers => $headers,
 547                tempname => $upload->{tempname},
 548                filename => $upload->{filename},
 549               );
 550             push @uploads, $u;
 551         }
 552         $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
 553
 554         # support access to the filename as a normal param
 555         my @filenames = map { $_->{filename} } @uploads;
 556         # append, if there's already params with this name
 557         if (exists $parameters->{$name}) {
 558             if (ref $parameters->{$name} eq 'ARRAY') {
 559                 push @{ $parameters->{$name} }, @filenames;
 560             }
 561             else {
 562                 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
 563             }
 564         }
 565         else {
 566             $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
 567         }
 568     }
 569 }
 570
 571 =head2 $self->prepare_write($c)
 572
 573 Abstract method. Implemented by the engines.
 574
 575 =cut
 576
 577 sub prepare_write { }
 578
 579 =head2 $self->read($c, [$maxlength])
 580
 581 Reads from the input stream by calling C<< $self->read_chunk >>.
 582
 583 Maintains the read_length and read_position counters as data is read.
 584
 585 =cut
 586
 587 sub read {
 588     my ( $self, $c, $maxlength ) = @_;
 589
 590     my $remaining = $self->read_length - $self->read_position;
 591     $maxlength ||= $CHUNKSIZE;
 592
 593     # Are we done reading?
 594     if ( $remaining <= 0 ) {
 595         $self->finalize_read($c);
 596         return;
 597     }
 598
 599     my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
 600     my $rc = $self->read_chunk( $c, my $buffer, $readlen );
 601     if ( defined $rc ) {
 602         if (0 == $rc) { # Nothing more to read even though Content-Length
 603                         # said there should be. FIXME - Warn in the log here?
 604             $self->finalize_read;
 605             return;
 606         }
 607         $self->read_position( $self->read_position + $rc );
 608         return $buffer;
 609     }
 610     else {
 611         Catalyst::Exception->throw(
 612             message => "Unknown error reading input: $!" );
 613     }
 614 }
 615
 616 =head2 $self->read_chunk($c, $buffer, $length)
 617
 618 Each engine implements read_chunk as its preferred way of reading a chunk
 619 of data. Returns the number of bytes read. A return of 0 indicates that
 620 there is no more data to be read.
 621
 622 =cut
 623
 624 sub read_chunk { }
 625
 626 =head2 $self->read_length
 627
 628 The length of input data to be read.  This is obtained from the Content-Length
 629 header.
 630
 631 =head2 $self->read_position
 632
 633 The amount of input data that has already been read.
 634
 635 =head2 $self->run($c)
 636
 637 Start the engine. Implemented by the various engine classes.
 638
 639 =cut
 640
 641 sub run { }
 642
 643 =head2 $self->write($c, $buffer)
 644
 645 Writes the buffer to the client.
 646
 647 =cut
 648
 649 sub write {
 650     my ( $self, $c, $buffer ) = @_;
 651
 652     unless ( $self->_prepared_write ) {
 653         $self->prepare_write($c);
 654         $self->_prepared_write(1);
 655     }
 656
 657     return 0 if !defined $buffer;
 658
 659     my $len   = length($buffer);
 660     my $wrote = syswrite STDOUT, $buffer;
 661
 662     if ( !defined $wrote && $! == EWOULDBLOCK ) {
 663         # Unable to write on the first try, will retry in the loop below
 664         $wrote = 0;
 665     }
 666
 667     if ( defined $wrote && $wrote < $len ) {
 668         # We didn't write the whole buffer
 669         while (1) {
 670             my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
 671             if ( defined $ret ) {
 672                 $wrote += $ret;
 673             }
 674             else {
 675                 next if $! == EWOULDBLOCK;
 676                 return;
 677             }
 678
 679             last if $wrote >= $len;
 680         }
 681     }
 682
 683     return $wrote;
 684 }
 685
 686 =head2 $self->unescape_uri($uri)
 687
 688 Unescapes a given URI using the most efficient method available.  Engines such
 689 as Apache may implement this using Apache's C-based modules, for example.
 690
 691 =cut
 692
 693 sub unescape_uri {
 694     my ( $self, $str ) = @_;
 695
 696     $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
 697
 698     return $str;
 699 }
 700
 701 =head2 $self->finalize_output
 702
 703 <obsolete>, see finalize_body
 704
 705 =head2 $self->env
 706
 707 Hash containing enviroment variables including many special variables inserted
 708 by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
 709
 710 Before accesing enviroment variables consider whether the same information is
 711 not directly available via Catalyst objects $c->request, $c->engine ...
 712
 713 BEWARE: If you really need to access some enviroment variable from your Catalyst
 714 application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
 715 as in some enviroments the %ENV hash does not contain what you would expect.
 716
 717 =head1 AUTHORS
 718
 719 Catalyst Contributors, see Catalyst.pm
 720
 721 =head1 COPYRIGHT
 722
 723 This library is free software. You can redistribute it and/or modify it under
 724 the same terms as Perl itself.
 725
 726 =cut
 727
 728 1;