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     # 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 = split /&/, $query_string;
 463
 464     for my $item ( @params ) {
 465
 466         my ($param, $value)
 467             = map { $self->unescape_uri($_) }
 468               split( /=/, $item );
 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     # Reset the read position
 498     $self->read_position(0);
 499 }
 500
 501 =head2 $self->prepare_request(@arguments)
 502
 503 Populate the context object from the request object.
 504
 505 =cut
 506
 507 sub prepare_request { }
 508
 509 =head2 $self->prepare_uploads($c)
 510
 511 =cut
 512
 513 sub prepare_uploads {
 514     my ( $self, $c ) = @_;
 515
 516     return unless $c->request->{_body};
 517
 518     my $uploads = $c->request->{_body}->upload;
 519     for my $name ( keys %$uploads ) {
 520         my $files = $uploads->{$name};
 521         $files = ref $files eq 'ARRAY' ? $files : [$files];
 522         my @uploads;
 523         for my $upload (@$files) {
 524             my $u = Catalyst::Request::Upload->new;
 525             $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
 526             $u->type( $u->headers->content_type );
 527             $u->tempname( $upload->{tempname} );
 528             $u->size( $upload->{size} );
 529             $u->filename( $upload->{filename} );
 530             push @uploads, $u;
 531         }
 532         $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
 533
 534         # support access to the filename as a normal param
 535         my @filenames = map { $_->{filename} } @uploads;
 536         # append, if there's already params with this name
 537         if (exists $c->request->parameters->{$name}) {
 538             if (ref $c->request->parameters->{$name} eq 'ARRAY') {
 539                 push @{ $c->request->parameters->{$name} }, @filenames;
 540             }
 541             else {
 542                 $c->request->parameters->{$name} =
 543                     [ $c->request->parameters->{$name}, @filenames ];
 544             }
 545         }
 546         else {
 547             $c->request->parameters->{$name} =
 548                 @filenames > 1 ? \@filenames : $filenames[0];
 549         }
 550     }
 551 }
 552
 553 =head2 $self->prepare_write($c)
 554
 555 Abstract method. Implemented by the engines.
 556
 557 =cut
 558
 559 sub prepare_write { }
 560
 561 =head2 $self->read($c, [$maxlength])
 562
 563 =cut
 564
 565 sub read {
 566     my ( $self, $c, $maxlength ) = @_;
 567
 568     unless ( $self->{_prepared_read} ) {
 569         $self->prepare_read($c);
 570         $self->{_prepared_read} = 1;
 571     }
 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 inplements 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. Can only be called once for a request.
 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     print STDOUT $buffer;
 635 }
 636
 637 =head2 $self->unescape_uri($uri)
 638
 639 Unescapes a given URI using the most efficient method available.  Engines such
 640 as Apache may implement this using Apache's C-based modules, for example.
 641
 642 =cut
 643
 644 sub unescape_uri {
 645     my ( $self, $str ) = @_;
 646
 647     $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 648     $str =~ s/\+/ /g;
 649
 650     return $str;
 651 }
 652
 653 =head2 $self->finalize_output
 654
 655 <obsolete>, see finalize_body
 656
 657 =head1 AUTHORS
 658
 659 Sebastian Riedel, <sri@cpan.org>
 660
 661 Andy Grundman, <andy@hybridized.org>
 662
 663 =head1 COPYRIGHT
 664
 665 This program is free software, you can redistribute it and/or modify it under
 666 the same terms as Perl itself.
 667
 668 =cut
 669
 670 1;