lib/Catalyst/Engine.pm

   1 package Catalyst::Engine;
   2
   3 use strict;
   4 use base 'Class::Accessor::Fast';
   5 use CGI::Simple::Cookie;
   6 use Data::Dump qw/dump/;
   7 use HTML::Entities;
   8 use HTTP::Body;
   9 use HTTP::Headers;
  10 use URI::QueryParam;
  11 use Scalar::Util ();
  12
  13 # input position and length
  14 __PACKAGE__->mk_accessors(qw/read_position read_length/);
  15
  16 # Stringify to class
  17 use overload '""' => sub { return ref shift }, fallback => 1;
  18
  19 # Amount of data to read from input on each pass
  20 our $CHUNKSIZE = 64 * 1024;
  21
  22 =head1 NAME
  23
  24 Catalyst::Engine - The Catalyst Engine
  25
  26 =head1 SYNOPSIS
  27
  28 See L<Catalyst>.
  29
  30 =head1 DESCRIPTION
  31
  32 =head1 METHODS
  33
  34
  35 =head2 $self->finalize_body($c)
  36
  37 Finalize body.  Prints the response output.
  38
  39 =cut
  40
  41 sub finalize_body {
  42     my ( $self, $c ) = @_;
  43     my $body = $c->response->body;
  44     no warnings 'uninitialized';
  45     if ( Scalar::Util::blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
  46         while ( !eof $body ) {
  47             read $body, my ($buffer), $CHUNKSIZE;
  48             last unless $self->write( $c, $buffer );
  49         }
  50         close $body;
  51     }
  52     else {
  53         $self->write( $c, $body );
  54     }
  55 }
  56
  57 =head2 $self->finalize_cookies($c)
  58
  59 Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
  60 response headers.
  61
  62 =cut
  63
  64 sub finalize_cookies {
  65     my ( $self, $c ) = @_;
  66
  67     my @cookies;
  68
  69     foreach my $name ( keys %{ $c->response->cookies } ) {
  70
  71         my $val = $c->response->cookies->{$name};
  72
  73         my $cookie = (
  74             Scalar::Util::blessed($val)
  75             ? $val
  76             : CGI::Simple::Cookie->new(
  77                 -name    => $name,
  78                 -value   => $val->{value},
  79                 -expires => $val->{expires},
  80                 -domain  => $val->{domain},
  81                 -path    => $val->{path},
  82                 -secure  => $val->{secure} || 0
  83             )
  84         );
  85
  86         push @cookies, $cookie->as_string;
  87     }
  88
  89     for my $cookie (@cookies) {
  90         $c->res->headers->push_header( 'Set-Cookie' => $cookie );
  91     }
  92 }
  93
  94 =head2 $self->finalize_error($c)
  95
  96 Output an apropriate error message, called if there's an error in $c
  97 after the dispatch has finished. Will output debug messages if Catalyst
  98 is in debug mode, or a `please come back later` message otherwise.
  99
 100 =cut
 101
 102 sub finalize_error {
 103     my ( $self, $c ) = @_;
 104
 105     $c->res->content_type('text/html; charset=utf-8');
 106     my $name = $c->config->{name} || join(' ', split('::', ref $c));
 107
 108     my ( $title, $error, $infos );
 109     if ( $c->debug ) {
 110
 111         # For pretty dumps
 112         $error = join '', map {
 113                 '<p><code class="error">'
 114               . encode_entities($_)
 115               . '</code></p>'
 116         } @{ $c->error };
 117         $error ||= 'No output';
 118         $error = qq{<pre wrap="">$error</pre>};
 119         $title = $name = "$name on Catalyst $Catalyst::VERSION";
 120         $name  = "<h1>$name</h1>";
 121
 122         # Don't show context in the dump
 123         delete $c->req->{_context};
 124         delete $c->res->{_context};
 125
 126         # Don't show body parser in the dump
 127         delete $c->req->{_body};
 128
 129         # Don't show response header state in dump
 130         delete $c->res->{_finalized_headers};
 131
 132         my @infos;
 133         my $i = 0;
 134         for my $dump ( $c->dump_these ) {
 135             my $name  = $dump->[0];
 136             my $value = encode_entities( dump( $dump->[1] ));
 137             push @infos, sprintf <<"EOF", $name, $value;
 138 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
 139 <div id="dump_$i">
 140     <pre wrap="">%s</pre>
 141 </div>
 142 EOF
 143             $i++;
 144         }
 145         $infos = join "\n", @infos;
 146     }
 147     else {
 148         $title = $name;
 149         $error = '';
 150         $infos = <<"";
 151 <pre>
 152 (en) Please come back later
 153 (fr) SVP veuillez revenir plus tard
 154 (de) Bitte versuchen sie es spaeter nocheinmal
 155 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
 156 (no) Vennligst prov igjen senere
 157 (dk) Venligst prov igen senere
 158 (pl) Prosze sprobowac pozniej
 159 </pre>
 160
 161         $name = '';
 162     }
 163     $c->res->body( <<"" );
 164 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 165     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 166 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
 167 <head>
 168     <meta http-equiv="Content-Language" content="en" />
 169     <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
 170     <title>$title</title>
 171     <script type="text/javascript">
 172         <!--
 173         function toggleDump (dumpElement) {
 174             var e = document.getElementById( dumpElement );
 175             if (e.style.display == "none") {
 176                 e.style.display = "";
 177             }
 178             else {
 179                 e.style.display = "none";
 180             }
 181         }
 182         -->
 183     </script>
 184     <style type="text/css">
 185         body {
 186             font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
 187                          Tahoma, Arial, helvetica, sans-serif;
 188             color: #333;
 189             background-color: #eee;
 190             margin: 0px;
 191             padding: 0px;
 192         }
 193         :link, :link:hover, :visited, :visited:hover {
 194             color: #000;
 195         }
 196         div.box {
 197             position: relative;
 198             background-color: #ccc;
 199             border: 1px solid #aaa;
 200             padding: 4px;
 201             margin: 10px;
 202         }
 203         div.error {
 204             background-color: #cce;
 205             border: 1px solid #755;
 206             padding: 8px;
 207             margin: 4px;
 208             margin-bottom: 10px;
 209         }
 210         div.infos {
 211             background-color: #eee;
 212             border: 1px solid #575;
 213             padding: 8px;
 214             margin: 4px;
 215             margin-bottom: 10px;
 216         }
 217         div.name {
 218             background-color: #cce;
 219             border: 1px solid #557;
 220             padding: 8px;
 221             margin: 4px;
 222         }
 223         code.error {
 224             display: block;
 225             margin: 1em 0;
 226             overflow: auto;
 227         }
 228         div.name h1, div.error p {
 229             margin: 0;
 230         }
 231         h2 {
 232             margin-top: 0;
 233             margin-bottom: 10px;
 234             font-size: medium;
 235             font-weight: bold;
 236             text-decoration: underline;
 237         }
 238         h1 {
 239             font-size: medium;
 240             font-weight: normal;
 241         }
 242         /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
 243         /* Browser specific (not valid) styles to make preformatted text wrap */
 244         pre {
 245             white-space: pre-wrap;       /* css-3 */
 246             white-space: -moz-pre-wrap;  /* Mozilla, since 1999 */
 247             white-space: -pre-wrap;      /* Opera 4-6 */
 248             white-space: -o-pre-wrap;    /* Opera 7 */
 249             word-wrap: break-word;       /* Internet Explorer 5.5+ */
 250         }
 251     </style>
 252 </head>
 253 <body>
 254     <div class="box">
 255         <div class="error">$error</div>
 256         <div class="infos">$infos</div>
 257         <div class="name">$name</div>
 258     </div>
 259 </body>
 260 </html>
 261
 262
 263     # Trick IE
 264     $c->res->{body} .= ( ' ' x 512 );
 265
 266     # Return 500
 267     $c->res->status(500);
 268 }
 269
 270 =head2 $self->finalize_headers($c)
 271
 272 Abstract method, allows engines to write headers to response
 273
 274 =cut
 275
 276 sub finalize_headers { }
 277
 278 =head2 $self->finalize_read($c)
 279
 280 =cut
 281
 282 sub finalize_read {
 283     my ( $self, $c ) = @_;
 284
 285     undef $self->{_prepared_read};
 286 }
 287
 288 =head2 $self->finalize_uploads($c)
 289
 290 Clean up after uploads, deleting temp files.
 291
 292 =cut
 293
 294 sub finalize_uploads {
 295     my ( $self, $c ) = @_;
 296
 297     if ( keys %{ $c->request->uploads } ) {
 298         for my $key ( keys %{ $c->request->uploads } ) {
 299             my $upload = $c->request->uploads->{$key};
 300             unlink map { $_->tempname }
 301               grep     { -e $_->tempname }
 302               ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
 303         }
 304     }
 305 }
 306
 307 =head2 $self->prepare_body($c)
 308
 309 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
 310
 311 =cut
 312
 313 sub prepare_body {
 314     my ( $self, $c ) = @_;
 315
 316     my $length = $c->request->header('Content-Length') || 0;
 317
 318     $self->read_length( $length );
 319
 320     if ( $length > 0 ) {
 321         unless ( $c->request->{_body} ) {
 322             my $type = $c->request->header('Content-Type');
 323             $c->request->{_body} = HTTP::Body->new( $type, $length );
 324             $c->request->{_body}->{tmpdir} = $c->config->{uploadtmp}
 325               if exists $c->config->{uploadtmp};
 326         }
 327
 328         while ( my $buffer = $self->read($c) ) {
 329             $c->prepare_body_chunk($buffer);
 330         }
 331
 332         # paranoia against wrong Content-Length header
 333         my $remaining = $length - $self->read_position;
 334         if ( $remaining > 0 ) {
 335             $self->finalize_read($c);
 336             Catalyst::Exception->throw(
 337                 "Wrong Content-Length value: $length" );
 338         }
 339     }
 340     else {
 341         # Defined but will cause all body code to be skipped
 342         $c->request->{_body} = 0;
 343     }
 344 }
 345
 346 =head2 $self->prepare_body_chunk($c)
 347
 348 Add a chunk to the request body.
 349
 350 =cut
 351
 352 sub prepare_body_chunk {
 353     my ( $self, $c, $chunk ) = @_;
 354
 355     $c->request->{_body}->add($chunk);
 356 }
 357
 358 =head2 $self->prepare_body_parameters($c)
 359
 360 Sets up parameters from body.
 361
 362 =cut
 363
 364 sub prepare_body_parameters {
 365     my ( $self, $c ) = @_;
 366
 367     return unless $c->request->{_body};
 368
 369     $c->request->body_parameters( $c->request->{_body}->param );
 370 }
 371
 372 =head2 $self->prepare_connection($c)
 373
 374 Abstract method implemented in engines.
 375
 376 =cut
 377
 378 sub prepare_connection { }
 379
 380 =head2 $self->prepare_cookies($c)
 381
 382 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
 383
 384 =cut
 385
 386 sub prepare_cookies {
 387     my ( $self, $c ) = @_;
 388
 389     if ( my $header = $c->request->header('Cookie') ) {
 390         $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
 391     }
 392 }
 393
 394 =head2 $self->prepare_headers($c)
 395
 396 =cut
 397
 398 sub prepare_headers { }
 399
 400 =head2 $self->prepare_parameters($c)
 401
 402 sets up parameters from query and post parameters.
 403
 404 =cut
 405
 406 sub prepare_parameters {
 407     my ( $self, $c ) = @_;
 408
 409     # We copy, no references
 410     foreach my $name ( keys %{ $c->request->query_parameters } ) {
 411         my $param = $c->request->query_parameters->{$name};
 412         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 413         $c->request->parameters->{$name} = $param;
 414     }
 415
 416     # Merge query and body parameters
 417     foreach my $name ( keys %{ $c->request->body_parameters } ) {
 418         my $param = $c->request->body_parameters->{$name};
 419         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 420         if ( my $old_param = $c->request->parameters->{$name} ) {
 421             if ( ref $old_param eq 'ARRAY' ) {
 422                 push @{ $c->request->parameters->{$name} },
 423                   ref $param eq 'ARRAY' ? @$param : $param;
 424             }
 425             else { $c->request->parameters->{$name} = [ $old_param, $param ] }
 426         }
 427         else { $c->request->parameters->{$name} = $param }
 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     # Make sure query has params
 451     if ( index( $query_string, '=' ) < 0 ) {
 452         return;
 453     }
 454
 455     my %query;
 456
 457     # replace semi-colons
 458     $query_string =~ s/;/&/g;
 459
 460     my @params = split /&/, $query_string;
 461
 462     for my $item ( @params ) {
 463
 464         my ($param, $value)
 465             = map { $self->unescape_uri($_) }
 466               split( /=/, $item );
 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     # Reset the read position
 496     $self->read_position(0);
 497 }
 498
 499 =head2 $self->prepare_request(@arguments)
 500
 501 Populate the context object from the request object.
 502
 503 =cut
 504
 505 sub prepare_request { }
 506
 507 =head2 $self->prepare_uploads($c)
 508
 509 =cut
 510
 511 sub prepare_uploads {
 512     my ( $self, $c ) = @_;
 513
 514     return unless $c->request->{_body};
 515
 516     my $uploads = $c->request->{_body}->upload;
 517     for my $name ( keys %$uploads ) {
 518         my $files = $uploads->{$name};
 519         $files = ref $files eq 'ARRAY' ? $files : [$files];
 520         my @uploads;
 521         for my $upload (@$files) {
 522             my $u = Catalyst::Request::Upload->new;
 523             $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
 524             $u->type( $u->headers->content_type );
 525             $u->tempname( $upload->{tempname} );
 526             $u->size( $upload->{size} );
 527             $u->filename( $upload->{filename} );
 528             push @uploads, $u;
 529         }
 530         $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
 531
 532         # support access to the filename as a normal param
 533         my @filenames = map { $_->{filename} } @uploads;
 534         # append, if there's already params with this name
 535         if (exists $c->request->parameters->{$name}) {
 536             if (ref $c->request->parameters->{$name} eq 'ARRAY') {
 537                 push @{ $c->request->parameters->{$name} }, @filenames;
 538             }
 539             else {
 540                 $c->request->parameters->{$name} =
 541                     [ $c->request->parameters->{$name}, @filenames ];
 542             }
 543         }
 544         else {
 545             $c->request->parameters->{$name} =
 546                 @filenames > 1 ? \@filenames : $filenames[0];
 547         }
 548     }
 549 }
 550
 551 =head2 $self->prepare_write($c)
 552
 553 Abstract method. Implemented by the engines.
 554
 555 =cut
 556
 557 sub prepare_write { }
 558
 559 =head2 $self->read($c, [$maxlength])
 560
 561 =cut
 562
 563 sub read {
 564     my ( $self, $c, $maxlength ) = @_;
 565
 566     unless ( $self->{_prepared_read} ) {
 567         $self->prepare_read($c);
 568         $self->{_prepared_read} = 1;
 569     }
 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 inplements 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. Can only be called once for a request.
 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     print STDOUT $buffer;
 633 }
 634
 635 =head2 $self->unescape_uri($uri)
 636
 637 Unescapes a given URI using the most efficient method available.  Engines such
 638 as Apache may implement this using Apache's C-based modules, for example.
 639
 640 =cut
 641
 642 sub unescape_uri {
 643     my ( $self, $str ) = @_;
 644
 645     $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 646     $str =~ s/\+/ /g;
 647
 648     return $str;
 649 }
 650
 651 =head2 $self->finalize_output
 652
 653 <obsolete>, see finalize_body
 654
 655 =head1 AUTHORS
 656
 657 Sebastian Riedel, <sri@cpan.org>
 658
 659 Andy Grundman, <andy@hybridized.org>
 660
 661 =head1 COPYRIGHT
 662
 663 This program is free software, you can redistribute it and/or modify it under
 664 the same terms as Perl itself.
 665
 666 =cut
 667
 668 1;