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