lib/Catalyst/Engine.pm

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