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