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     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     $self->read_length( $c->request->header('Content-Length') || 0 );
 317     my $type = $c->request->header('Content-Type');
 318
 319     unless ( $c->request->{_body} ) {
 320         $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
 321         $c->request->{_body}->{tmpdir} = $c->config->{uploadtmp}
 322           if exists $c->config->{uploadtmp};
 323     }
 324
 325     if ( $self->read_length > 0 ) {
 326         while ( my $buffer = $self->read($c) ) {
 327             $c->prepare_body_chunk($buffer);
 328         }
 329
 330         # paranoia against wrong Content-Length header
 331         my $remaining = $self->read_length - $self->read_position;
 332         if ( $remaining > 0 ) {
 333             $self->finalize_read($c);
 334             Catalyst::Exception->throw(
 335                 "Wrong Content-Length value: " . $self->read_length );
 336         }
 337     }
 338 }
 339
 340 =head2 $self->prepare_body_chunk($c)
 341
 342 Add a chunk to the request body.
 343
 344 =cut
 345
 346 sub prepare_body_chunk {
 347     my ( $self, $c, $chunk ) = @_;
 348
 349     $c->request->{_body}->add($chunk);
 350 }
 351
 352 =head2 $self->prepare_body_parameters($c)
 353
 354 Sets up parameters from body.
 355
 356 =cut
 357
 358 sub prepare_body_parameters {
 359     my ( $self, $c ) = @_;
 360     $c->request->body_parameters( $c->request->{_body}->param );
 361 }
 362
 363 =head2 $self->prepare_connection($c)
 364
 365 Abstract method implemented in engines.
 366
 367 =cut
 368
 369 sub prepare_connection { }
 370
 371 =head2 $self->prepare_cookies($c)
 372
 373 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
 374
 375 =cut
 376
 377 sub prepare_cookies {
 378     my ( $self, $c ) = @_;
 379
 380     if ( my $header = $c->request->header('Cookie') ) {
 381         $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
 382     }
 383 }
 384
 385 =head2 $self->prepare_headers($c)
 386
 387 =cut
 388
 389 sub prepare_headers { }
 390
 391 =head2 $self->prepare_parameters($c)
 392
 393 sets up parameters from query and post parameters.
 394
 395 =cut
 396
 397 sub prepare_parameters {
 398     my ( $self, $c ) = @_;
 399
 400     # We copy, no references
 401     foreach my $name ( keys %{ $c->request->query_parameters } ) {
 402         my $param = $c->request->query_parameters->{$name};
 403         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 404         $c->request->parameters->{$name} = $param;
 405     }
 406
 407     # Merge query and body parameters
 408     foreach my $name ( keys %{ $c->request->body_parameters } ) {
 409         my $param = $c->request->body_parameters->{$name};
 410         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 411         if ( my $old_param = $c->request->parameters->{$name} ) {
 412             if ( ref $old_param eq 'ARRAY' ) {
 413                 push @{ $c->request->parameters->{$name} },
 414                   ref $param eq 'ARRAY' ? @$param : $param;
 415             }
 416             else { $c->request->parameters->{$name} = [ $old_param, $param ] }
 417         }
 418         else { $c->request->parameters->{$name} = $param }
 419     }
 420 }
 421
 422 =head2 $self->prepare_path($c)
 423
 424 abstract method, implemented by engines.
 425
 426 =cut
 427
 428 sub prepare_path { }
 429
 430 =head2 $self->prepare_request($c)
 431
 432 =head2 $self->prepare_query_parameters($c)
 433
 434 process the query string and extract query parameters.
 435
 436 =cut
 437
 438 sub prepare_query_parameters {
 439     my ( $self, $c, $query_string ) = @_;
 440
 441     # replace semi-colons
 442     $query_string =~ s/;/&/g;
 443
 444     my $u = URI->new( '', 'http' );
 445     $u->query($query_string);
 446     for my $key ( $u->query_param ) {
 447         my @vals = $u->query_param($key);
 448         $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
 449     }
 450 }
 451
 452 =head2 $self->prepare_read($c)
 453
 454 prepare to read from the engine.
 455
 456 =cut
 457
 458 sub prepare_read {
 459     my ( $self, $c ) = @_;
 460
 461     # Reset the read position
 462     $self->read_position(0);
 463 }
 464
 465 =head2 $self->prepare_request(@arguments)
 466
 467 Populate the context object from the request object.
 468
 469 =cut
 470
 471 sub prepare_request { }
 472
 473 =head2 $self->prepare_uploads($c)
 474
 475 =cut
 476
 477 sub prepare_uploads {
 478     my ( $self, $c ) = @_;
 479     my $uploads = $c->request->{_body}->upload;
 480     for my $name ( keys %$uploads ) {
 481         my $files = $uploads->{$name};
 482         $files = ref $files eq 'ARRAY' ? $files : [$files];
 483         my @uploads;
 484         for my $upload (@$files) {
 485             my $u = Catalyst::Request::Upload->new;
 486             $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
 487             $u->type( $u->headers->content_type );
 488             $u->tempname( $upload->{tempname} );
 489             $u->size( $upload->{size} );
 490             $u->filename( $upload->{filename} );
 491             push @uploads, $u;
 492         }
 493         $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
 494
 495         # support access to the filename as a normal param
 496         my @filenames = map { $_->{filename} } @uploads;
 497         # append, if there's already params with this name
 498         if (exists $c->request->parameters->{$name}) {
 499             if (ref $c->request->parameters->{$name} eq 'ARRAY') {
 500                 push @{ $c->request->parameters->{$name} }, @filenames;
 501             }
 502             else {
 503                 $c->request->parameters->{$name} =
 504                     [ $c->request->parameters->{$name}, @filenames ];
 505             }
 506         }
 507         else {
 508             $c->request->parameters->{$name} =
 509                 @filenames > 1 ? \@filenames : $filenames[0];
 510         }
 511     }
 512 }
 513
 514 =head2 $self->prepare_write($c)
 515
 516 Abstract method. Implemented by the engines.
 517
 518 =cut
 519
 520 sub prepare_write { }
 521
 522 =head2 $self->read($c, [$maxlength])
 523
 524 =cut
 525
 526 sub read {
 527     my ( $self, $c, $maxlength ) = @_;
 528
 529     unless ( $self->{_prepared_read} ) {
 530         $self->prepare_read($c);
 531         $self->{_prepared_read} = 1;
 532     }
 533
 534     my $remaining = $self->read_length - $self->read_position;
 535     $maxlength ||= $CHUNKSIZE;
 536
 537     # Are we done reading?
 538     if ( $remaining <= 0 ) {
 539         $self->finalize_read($c);
 540         return;
 541     }
 542
 543     my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
 544     my $rc = $self->read_chunk( $c, my $buffer, $readlen );
 545     if ( defined $rc ) {
 546         $self->read_position( $self->read_position + $rc );
 547         return $buffer;
 548     }
 549     else {
 550         Catalyst::Exception->throw(
 551             message => "Unknown error reading input: $!" );
 552     }
 553 }
 554
 555 =head2 $self->read_chunk($c, $buffer, $length)
 556
 557 Each engine inplements read_chunk as its preferred way of reading a chunk
 558 of data.
 559
 560 =cut
 561
 562 sub read_chunk { }
 563
 564 =head2 $self->read_length
 565
 566 The length of input data to be read.  This is obtained from the Content-Length
 567 header.
 568
 569 =head2 $self->read_position
 570
 571 The amount of input data that has already been read.
 572
 573 =head2 $self->run($c)
 574
 575 Start the engine. Implemented by the various engine classes.
 576
 577 =cut
 578
 579 sub run { }
 580
 581 =head2 $self->write($c, $buffer)
 582
 583 Writes the buffer to the client. Can only be called once for a request.
 584
 585 =cut
 586
 587 sub write {
 588     my ( $self, $c, $buffer ) = @_;
 589
 590     unless ( $self->{_prepared_write} ) {
 591         $self->prepare_write($c);
 592         $self->{_prepared_write} = 1;
 593     }
 594
 595     print STDOUT $buffer;
 596 }
 597
 598
 599 =head2 $self->finalize_output
 600
 601 <obsolete>, see finalize_body
 602
 603 =head1 AUTHORS
 604
 605 Sebastian Riedel, <sri@cpan.org>
 606
 607 Andy Grundman, <andy@hybridized.org>
 608
 609 =head1 COPYRIGHT
 610
 611 This program is free software, you can redistribute it and/or modify it under
 612 the same terms as Perl itself.
 613
 614 =cut
 615
 616 1;