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     # replace semi-colons
 451     $query_string =~ s/;/&/g;
 452
 453     my $u = URI->new( '', 'http' );
 454     $u->query($query_string);
 455     for my $key ( $u->query_param ) {
 456         my @vals = $u->query_param($key);
 457         $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
 458     }
 459 }
 460
 461 =head2 $self->prepare_read($c)
 462
 463 prepare to read from the engine.
 464
 465 =cut
 466
 467 sub prepare_read {
 468     my ( $self, $c ) = @_;
 469
 470     # Reset the read position
 471     $self->read_position(0);
 472 }
 473
 474 =head2 $self->prepare_request(@arguments)
 475
 476 Populate the context object from the request object.
 477
 478 =cut
 479
 480 sub prepare_request { }
 481
 482 =head2 $self->prepare_uploads($c)
 483
 484 =cut
 485
 486 sub prepare_uploads {
 487     my ( $self, $c ) = @_;
 488
 489     return unless $c->request->{_body};
 490
 491     my $uploads = $c->request->{_body}->upload;
 492     for my $name ( keys %$uploads ) {
 493         my $files = $uploads->{$name};
 494         $files = ref $files eq 'ARRAY' ? $files : [$files];
 495         my @uploads;
 496         for my $upload (@$files) {
 497             my $u = Catalyst::Request::Upload->new;
 498             $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
 499             $u->type( $u->headers->content_type );
 500             $u->tempname( $upload->{tempname} );
 501             $u->size( $upload->{size} );
 502             $u->filename( $upload->{filename} );
 503             push @uploads, $u;
 504         }
 505         $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
 506
 507         # support access to the filename as a normal param
 508         my @filenames = map { $_->{filename} } @uploads;
 509         # append, if there's already params with this name
 510         if (exists $c->request->parameters->{$name}) {
 511             if (ref $c->request->parameters->{$name} eq 'ARRAY') {
 512                 push @{ $c->request->parameters->{$name} }, @filenames;
 513             }
 514             else {
 515                 $c->request->parameters->{$name} =
 516                     [ $c->request->parameters->{$name}, @filenames ];
 517             }
 518         }
 519         else {
 520             $c->request->parameters->{$name} =
 521                 @filenames > 1 ? \@filenames : $filenames[0];
 522         }
 523     }
 524 }
 525
 526 =head2 $self->prepare_write($c)
 527
 528 Abstract method. Implemented by the engines.
 529
 530 =cut
 531
 532 sub prepare_write { }
 533
 534 =head2 $self->read($c, [$maxlength])
 535
 536 =cut
 537
 538 sub read {
 539     my ( $self, $c, $maxlength ) = @_;
 540
 541     unless ( $self->{_prepared_read} ) {
 542         $self->prepare_read($c);
 543         $self->{_prepared_read} = 1;
 544     }
 545
 546     my $remaining = $self->read_length - $self->read_position;
 547     $maxlength ||= $CHUNKSIZE;
 548
 549     # Are we done reading?
 550     if ( $remaining <= 0 ) {
 551         $self->finalize_read($c);
 552         return;
 553     }
 554
 555     my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
 556     my $rc = $self->read_chunk( $c, my $buffer, $readlen );
 557     if ( defined $rc ) {
 558         $self->read_position( $self->read_position + $rc );
 559         return $buffer;
 560     }
 561     else {
 562         Catalyst::Exception->throw(
 563             message => "Unknown error reading input: $!" );
 564     }
 565 }
 566
 567 =head2 $self->read_chunk($c, $buffer, $length)
 568
 569 Each engine inplements read_chunk as its preferred way of reading a chunk
 570 of data.
 571
 572 =cut
 573
 574 sub read_chunk { }
 575
 576 =head2 $self->read_length
 577
 578 The length of input data to be read.  This is obtained from the Content-Length
 579 header.
 580
 581 =head2 $self->read_position
 582
 583 The amount of input data that has already been read.
 584
 585 =head2 $self->run($c)
 586
 587 Start the engine. Implemented by the various engine classes.
 588
 589 =cut
 590
 591 sub run { }
 592
 593 =head2 $self->write($c, $buffer)
 594
 595 Writes the buffer to the client. Can only be called once for a request.
 596
 597 =cut
 598
 599 sub write {
 600     my ( $self, $c, $buffer ) = @_;
 601
 602     unless ( $self->{_prepared_write} ) {
 603         $self->prepare_write($c);
 604         $self->{_prepared_write} = 1;
 605     }
 606
 607     print STDOUT $buffer;
 608 }
 609
 610
 611 =head2 $self->finalize_output
 612
 613 <obsolete>, see finalize_body
 614
 615 =head1 AUTHORS
 616
 617 Sebastian Riedel, <sri@cpan.org>
 618
 619 Andy Grundman, <andy@hybridized.org>
 620
 621 =head1 COPYRIGHT
 622
 623 This program is free software, you can redistribute it and/or modify it under
 624 the same terms as Perl itself.
 625
 626 =cut
 627
 628 1;