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
 284 =head2 $self->finalize_uploads($c)
 285
 286 Clean up after uploads, deleting temp files.
 287
 288 =cut
 289
 290 sub finalize_uploads {
 291     my ( $self, $c ) = @_;
 292
 293     if ( keys %{ $c->request->uploads } ) {
 294         for my $key ( keys %{ $c->request->uploads } ) {
 295             my $upload = $c->request->uploads->{$key};
 296             unlink map { $_->tempname }
 297               grep     { -e $_->tempname }
 298               ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
 299         }
 300     }
 301 }
 302
 303 =head2 $self->prepare_body($c)
 304
 305 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
 306
 307 =cut
 308
 309 sub prepare_body {
 310     my ( $self, $c ) = @_;
 311
 312     if ( my $length = $self->read_length ) {
 313         unless ( $c->request->{_body} ) {
 314             my $type = $c->request->header('Content-Type');
 315             $c->request->{_body} = HTTP::Body->new( $type, $length );
 316             $c->request->{_body}->{tmpdir} = $c->config->{uploadtmp}
 317               if exists $c->config->{uploadtmp};
 318         }
 319
 320         while ( my $buffer = $self->read($c) ) {
 321             $c->prepare_body_chunk($buffer);
 322         }
 323
 324         # paranoia against wrong Content-Length header
 325         my $remaining = $length - $self->read_position;
 326         if ( $remaining > 0 ) {
 327             $self->finalize_read($c);
 328             Catalyst::Exception->throw(
 329                 "Wrong Content-Length value: $length" );
 330         }
 331     }
 332     else {
 333         # Defined but will cause all body code to be skipped
 334         $c->request->{_body} = 0;
 335     }
 336 }
 337
 338 =head2 $self->prepare_body_chunk($c)
 339
 340 Add a chunk to the request body.
 341
 342 =cut
 343
 344 sub prepare_body_chunk {
 345     my ( $self, $c, $chunk ) = @_;
 346
 347     $c->request->{_body}->add($chunk);
 348 }
 349
 350 =head2 $self->prepare_body_parameters($c)
 351
 352 Sets up parameters from body.
 353
 354 =cut
 355
 356 sub prepare_body_parameters {
 357     my ( $self, $c ) = @_;
 358
 359     return unless $c->request->{_body};
 360
 361     $c->request->body_parameters( $c->request->{_body}->param );
 362 }
 363
 364 =head2 $self->prepare_connection($c)
 365
 366 Abstract method implemented in engines.
 367
 368 =cut
 369
 370 sub prepare_connection { }
 371
 372 =head2 $self->prepare_cookies($c)
 373
 374 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
 375
 376 =cut
 377
 378 sub prepare_cookies {
 379     my ( $self, $c ) = @_;
 380
 381     if ( my $header = $c->request->header('Cookie') ) {
 382         $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
 383     }
 384 }
 385
 386 =head2 $self->prepare_headers($c)
 387
 388 =cut
 389
 390 sub prepare_headers { }
 391
 392 =head2 $self->prepare_parameters($c)
 393
 394 sets up parameters from query and post parameters.
 395
 396 =cut
 397
 398 sub prepare_parameters {
 399     my ( $self, $c ) = @_;
 400
 401     # We copy, no references
 402     foreach my $name ( keys %{ $c->request->query_parameters } ) {
 403         my $param = $c->request->query_parameters->{$name};
 404         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 405         $c->request->parameters->{$name} = $param;
 406     }
 407
 408     # Merge query and body parameters
 409     foreach my $name ( keys %{ $c->request->body_parameters } ) {
 410         my $param = $c->request->body_parameters->{$name};
 411         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 412         if ( my $old_param = $c->request->parameters->{$name} ) {
 413             if ( ref $old_param eq 'ARRAY' ) {
 414                 push @{ $c->request->parameters->{$name} },
 415                   ref $param eq 'ARRAY' ? @$param : $param;
 416             }
 417             else { $c->request->parameters->{$name} = [ $old_param, $param ] }
 418         }
 419         else { $c->request->parameters->{$name} = $param }
 420     }
 421 }
 422
 423 =head2 $self->prepare_path($c)
 424
 425 abstract method, implemented by engines.
 426
 427 =cut
 428
 429 sub prepare_path { }
 430
 431 =head2 $self->prepare_request($c)
 432
 433 =head2 $self->prepare_query_parameters($c)
 434
 435 process the query string and extract query parameters.
 436
 437 =cut
 438
 439 sub prepare_query_parameters {
 440     my ( $self, $c, $query_string ) = @_;
 441
 442     # Check for keywords (no = signs)
 443     # (yes, index() is faster than a regex :))
 444     if ( index( $query_string, '=' ) < 0 ) {
 445         $c->request->query_keywords( $self->unescape_uri($query_string) );
 446         return;
 447     }
 448
 449     my %query;
 450
 451     # replace semi-colons
 452     $query_string =~ s/;/&/g;
 453
 454     my @params = split /&/, $query_string;
 455
 456     for my $item ( @params ) {
 457
 458         my ($param, $value)
 459             = map { $self->unescape_uri($_) }
 460               split( /=/, $item );
 461
 462         $param = $self->unescape_uri($item) unless defined $param;
 463
 464         if ( exists $query{$param} ) {
 465             if ( ref $query{$param} ) {
 466                 push @{ $query{$param} }, $value;
 467             }
 468             else {
 469                 $query{$param} = [ $query{$param}, $value ];
 470             }
 471         }
 472         else {
 473             $query{$param} = $value;
 474         }
 475     }
 476
 477     $c->request->query_parameters( \%query );
 478 }
 479
 480 =head2 $self->prepare_read($c)
 481
 482 prepare to read from the engine.
 483
 484 =cut
 485
 486 sub prepare_read {
 487     my ( $self, $c ) = @_;
 488
 489     # Initialize the read position
 490     $self->read_position(0);
 491
 492     # Initialize the amount of data we think we need to read
 493     $self->read_length( $c->request->header('Content-Length') || 0 );
 494 }
 495
 496 =head2 $self->prepare_request(@arguments)
 497
 498 Populate the context object from the request object.
 499
 500 =cut
 501
 502 sub prepare_request { }
 503
 504 =head2 $self->prepare_uploads($c)
 505
 506 =cut
 507
 508 sub prepare_uploads {
 509     my ( $self, $c ) = @_;
 510
 511     return unless $c->request->{_body};
 512
 513     my $uploads = $c->request->{_body}->upload;
 514     for my $name ( keys %$uploads ) {
 515         my $files = $uploads->{$name};
 516         $files = ref $files eq 'ARRAY' ? $files : [$files];
 517         my @uploads;
 518         for my $upload (@$files) {
 519             my $u = Catalyst::Request::Upload->new;
 520             $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
 521             $u->type( $u->headers->content_type );
 522             $u->tempname( $upload->{tempname} );
 523             $u->size( $upload->{size} );
 524             $u->filename( $upload->{filename} );
 525             push @uploads, $u;
 526         }
 527         $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
 528
 529         # support access to the filename as a normal param
 530         my @filenames = map { $_->{filename} } @uploads;
 531         # append, if there's already params with this name
 532         if (exists $c->request->parameters->{$name}) {
 533             if (ref $c->request->parameters->{$name} eq 'ARRAY') {
 534                 push @{ $c->request->parameters->{$name} }, @filenames;
 535             }
 536             else {
 537                 $c->request->parameters->{$name} =
 538                     [ $c->request->parameters->{$name}, @filenames ];
 539             }
 540         }
 541         else {
 542             $c->request->parameters->{$name} =
 543                 @filenames > 1 ? \@filenames : $filenames[0];
 544         }
 545     }
 546 }
 547
 548 =head2 $self->prepare_write($c)
 549
 550 Abstract method. Implemented by the engines.
 551
 552 =cut
 553
 554 sub prepare_write { }
 555
 556 =head2 $self->read($c, [$maxlength])
 557
 558 =cut
 559
 560 sub read {
 561     my ( $self, $c, $maxlength ) = @_;
 562
 563     my $remaining = $self->read_length - $self->read_position;
 564     $maxlength ||= $CHUNKSIZE;
 565
 566     # Are we done reading?
 567     if ( $remaining <= 0 ) {
 568         $self->finalize_read($c);
 569         return;
 570     }
 571
 572     my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
 573     my $rc = $self->read_chunk( $c, my $buffer, $readlen );
 574     if ( defined $rc ) {
 575         $self->read_position( $self->read_position + $rc );
 576         return $buffer;
 577     }
 578     else {
 579         Catalyst::Exception->throw(
 580             message => "Unknown error reading input: $!" );
 581     }
 582 }
 583
 584 =head2 $self->read_chunk($c, $buffer, $length)
 585
 586 Each engine inplements read_chunk as its preferred way of reading a chunk
 587 of data.
 588
 589 =cut
 590
 591 sub read_chunk { }
 592
 593 =head2 $self->read_length
 594
 595 The length of input data to be read.  This is obtained from the Content-Length
 596 header.
 597
 598 =head2 $self->read_position
 599
 600 The amount of input data that has already been read.
 601
 602 =head2 $self->run($c)
 603
 604 Start the engine. Implemented by the various engine classes.
 605
 606 =cut
 607
 608 sub run { }
 609
 610 =head2 $self->write($c, $buffer)
 611
 612 Writes the buffer to the client. Can only be called once for a request.
 613
 614 =cut
 615
 616 sub write {
 617     my ( $self, $c, $buffer ) = @_;
 618
 619     unless ( $self->{_prepared_write} ) {
 620         $self->prepare_write($c);
 621         $self->{_prepared_write} = 1;
 622     }
 623
 624     print STDOUT $buffer;
 625 }
 626
 627 =head2 $self->unescape_uri($uri)
 628
 629 Unescapes a given URI using the most efficient method available.  Engines such
 630 as Apache may implement this using Apache's C-based modules, for example.
 631
 632 =cut
 633
 634 sub unescape_uri {
 635     my ( $self, $str ) = @_;
 636
 637     $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 638     $str =~ s/\+/ /g;
 639
 640     return $str;
 641 }
 642
 643 =head2 $self->finalize_output
 644
 645 <obsolete>, see finalize_body
 646
 647 =head1 AUTHORS
 648
 649 Sebastian Riedel, <sri@cpan.org>
 650
 651 Andy Grundman, <andy@hybridized.org>
 652
 653 =head1 COPYRIGHT
 654
 655 This program is free software, you can redistribute it and/or modify it under
 656 the same terms as Perl itself.
 657
 658 =cut
 659
 660 1;