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