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