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