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