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