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