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