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 (fr) SVP veuillez revenir plus tard
 149 (de) Bitte versuchen sie es spaeter nocheinmal
 150 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
 151 (no) Vennligst prov igjen senere
 152 (dk) Venligst prov igen senere
 153 (pl) Prosze sprobowac pozniej
 154 </pre>
 155
 156         $name = '';
 157     }
 158     $c->res->body( <<"" );
 159 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 160     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 161 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
 162 <head>
 163     <meta http-equiv="Content-Language" content="en" />
 164     <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
 165     <title>$title</title>
 166     <script type="text/javascript">
 167         <!--
 168         function toggleDump (dumpElement) {
 169             var e = document.getElementById( dumpElement );
 170             if (e.style.display == "none") {
 171                 e.style.display = "";
 172             }
 173             else {
 174                 e.style.display = "none";
 175             }
 176         }
 177         -->
 178     </script>
 179     <style type="text/css">
 180         body {
 181             font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
 182                          Tahoma, Arial, helvetica, sans-serif;
 183             color: #ddd;
 184             background-color: #eee;
 185             margin: 0px;
 186             padding: 0px;
 187         }
 188         :link, :link:hover, :visited, :visited:hover {
 189             color: #ddd;
 190         }
 191         div.box {
 192             position: relative;
 193             background-color: #ccc;
 194             border: 1px solid #aaa;
 195             padding: 4px;
 196             margin: 10px;
 197             -moz-border-radius: 10px;
 198         }
 199         div.error {
 200             background-color: #977;
 201             border: 1px solid #755;
 202             padding: 8px;
 203             margin: 4px;
 204             margin-bottom: 10px;
 205             -moz-border-radius: 10px;
 206         }
 207         div.infos {
 208             background-color: #797;
 209             border: 1px solid #575;
 210             padding: 8px;
 211             margin: 4px;
 212             margin-bottom: 10px;
 213             -moz-border-radius: 10px;
 214         }
 215         div.name {
 216             background-color: #779;
 217             border: 1px solid #557;
 218             padding: 8px;
 219             margin: 4px;
 220             -moz-border-radius: 10px;
 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} if exists $c->config->{uploadtmp};
 321     }
 322
 323     if ( $self->read_length > 0 ) {
 324         while ( my $buffer = $self->read($c) ) {
 325             $c->prepare_body_chunk($buffer);
 326         }
 327
 328         # paranoia against wrong Content-Length header
 329         my $remaining = $self->read_length - $self->read_position;
 330         if ($remaining > 0) {
 331             $self->finalize_read($c);
 332             Catalyst::Exception->throw("Wrong Content-Length value: ". $self->read_length);
 333         }
 334     }
 335 }
 336
 337 =head2 $self->prepare_body_chunk($c)
 338
 339 Add a chunk to the request body.
 340
 341 =cut
 342
 343 sub prepare_body_chunk {
 344     my ( $self, $c, $chunk ) = @_;
 345
 346     $c->request->{_body}->add($chunk);
 347 }
 348
 349 =head2 $self->prepare_body_parameters($c)
 350
 351 Sets up parameters from body.
 352
 353 =cut
 354
 355 sub prepare_body_parameters {
 356     my ( $self, $c ) = @_;
 357     $c->request->body_parameters( $c->request->{_body}->param );
 358 }
 359
 360 =head2 $self->prepare_connection($c)
 361
 362 Abstract method implemented in engines.
 363
 364 =cut
 365
 366 sub prepare_connection { }
 367
 368 =head2 $self->prepare_cookies($c)
 369
 370 Parse cookies from header. Sets a L<CGI::Cookie> object.
 371
 372 =cut
 373
 374 sub prepare_cookies {
 375     my ( $self, $c ) = @_;
 376
 377     if ( my $header = $c->request->header('Cookie') ) {
 378         $c->req->cookies( { CGI::Cookie->parse($header) } );
 379     }
 380 }
 381
 382 =head2 $self->prepare_headers($c)
 383
 384 =cut
 385
 386 sub prepare_headers { }
 387
 388 =head2 $self->prepare_parameters($c)
 389
 390 sets up parameters from query and post parameters.
 391
 392 =cut
 393
 394 sub prepare_parameters {
 395     my ( $self, $c ) = @_;
 396
 397     # We copy, no references
 398     while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
 399         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 400         $c->request->parameters->{$name} = $param;
 401     }
 402
 403     # Merge query and body parameters
 404     while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
 405         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 406         if ( my $old_param = $c->request->parameters->{$name} ) {
 407             if ( ref $old_param eq 'ARRAY' ) {
 408                 push @{ $c->request->parameters->{$name} },
 409                   ref $param eq 'ARRAY' ? @$param : $param;
 410             }
 411             else { $c->request->parameters->{$name} = [ $old_param, $param ] }
 412         }
 413         else { $c->request->parameters->{$name} = $param }
 414     }
 415 }
 416
 417 =head2 $self->prepare_path($c)
 418
 419 abstract method, implemented by engines.
 420
 421 =cut
 422
 423 sub prepare_path { }
 424
 425 =head2 $self->prepare_request($c)
 426
 427 =head2 $self->prepare_query_parameters($c)
 428
 429 process the query string and extract query parameters.
 430
 431 =cut
 432
 433 sub prepare_query_parameters {
 434     my ( $self, $c, $query_string ) = @_;
 435
 436     # replace semi-colons
 437     $query_string =~ s/;/&/g;
 438
 439     my $u = URI->new( '', 'http' );
 440     $u->query($query_string);
 441     for my $key ( $u->query_param ) {
 442         my @vals = $u->query_param($key);
 443         $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
 444     }
 445 }
 446
 447 =head2 $self->prepare_read($c)
 448
 449 prepare to read from the engine.
 450
 451 =cut
 452
 453 sub prepare_read {
 454     my ( $self, $c ) = @_;
 455
 456     # Reset the read position
 457     $self->read_position(0);
 458 }
 459
 460 =head2 $self->prepare_request(@arguments)
 461
 462 Populate the context object from the request object.
 463
 464 =cut
 465
 466 sub prepare_request { }
 467
 468 =head2 $self->prepare_uploads($c)
 469
 470 =cut
 471
 472 sub prepare_uploads {
 473     my ( $self, $c ) = @_;
 474     my $uploads = $c->request->{_body}->upload;
 475     for my $name ( keys %$uploads ) {
 476         my $files = $uploads->{$name};
 477         $files = ref $files eq 'ARRAY' ? $files : [$files];
 478         my @uploads;
 479         for my $upload (@$files) {
 480             my $u = Catalyst::Request::Upload->new;
 481             $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
 482             $u->type( $u->headers->content_type );
 483             $u->tempname( $upload->{tempname} );
 484             $u->size( $upload->{size} );
 485             $u->filename( $upload->{filename} );
 486             push @uploads, $u;
 487         }
 488         $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
 489
 490         # support access to the filename as a normal param
 491         my @filenames = map { $_->{filename} } @uploads;
 492         $c->request->parameters->{$name} =
 493           @filenames > 1 ? \@filenames : $filenames[0];
 494     }
 495 }
 496
 497 =head2 $self->prepare_write($c)
 498
 499 Abstract method. Implemented by the engines.
 500
 501 =cut
 502
 503 sub prepare_write { }
 504
 505 =head2 $self->read($c, [$maxlength])
 506
 507 =cut
 508
 509 sub read {
 510     my ( $self, $c, $maxlength ) = @_;
 511
 512     unless ( $self->{_prepared_read} ) {
 513         $self->prepare_read($c);
 514         $self->{_prepared_read} = 1;
 515     }
 516
 517     my $remaining = $self->read_length - $self->read_position;
 518     $maxlength ||= $CHUNKSIZE;
 519
 520     # Are we done reading?
 521     if ( $remaining <= 0 ) {
 522         $self->finalize_read($c);
 523         return;
 524     }
 525
 526     my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
 527     my $rc = $self->read_chunk( $c, my $buffer, $readlen );
 528     if ( defined $rc ) {
 529         $self->read_position( $self->read_position + $rc );
 530         return $buffer;
 531     }
 532     else {
 533         Catalyst::Exception->throw(
 534             message => "Unknown error reading input: $!" );
 535     }
 536 }
 537
 538 =head2 $self->read_chunk($c, $buffer, $length)
 539
 540 Each engine inplements read_chunk as its preferred way of reading a chunk
 541 of data.
 542
 543 =cut
 544
 545 sub read_chunk { }
 546
 547 =head2 $self->read_length
 548
 549 The length of input data to be read.  This is obtained from the Content-Length
 550 header.
 551
 552 =head2 $self->read_position
 553
 554 The amount of input data that has already been read.
 555
 556 =head2 $self->run($c)
 557
 558 Start the engine. Implemented by the various engine classes.
 559
 560 =cut
 561
 562 sub run { }
 563
 564 =head2 $self->write($c, $buffer)
 565
 566 Writes the buffer to the client. Can only be called once for a request.
 567
 568 =cut
 569
 570 sub write {
 571     my ( $self, $c, $buffer ) = @_;
 572
 573     unless ( $self->{_prepared_write} ) {
 574         $self->prepare_write($c);
 575         $self->{_prepared_write} = 1;
 576     }
 577
 578     print STDOUT $buffer;
 579 }
 580
 581 =head2 $self->finalize_output
 582
 583 <obsolete>, see finalize_body
 584
 585 =head1 AUTHORS
 586
 587 Sebastian Riedel, <sri@cpan.org>
 588
 589 Andy Grundman, <andy@hybridized.org>
 590
 591 =head1 COPYRIGHT
 592
 593 This program is free software, you can redistribute it and/or modify it under
 594 the same terms as Perl itself.
 595
 596 =cut
 597
 598 1;