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
  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::Simple::Cookie objects from $c->res->cookies, and set them as
  58 response headers.
  59
  60 =cut
  61
  62 sub finalize_cookies {
  63     my ( $self, $c ) = @_;
  64
  65     my @cookies;
  66
  67     foreach my $name ( keys %{ $c->response->cookies } ) {
  68
  69         my $val = $c->response->cookies->{$name};
  70
  71         my $cookie = CGI::Simple::Cookie->new(
  72             -name    => $name,
  73             -value   => $val->{value},
  74             -expires => $val->{expires},
  75             -domain  => $val->{domain},
  76             -path    => $val->{path},
  77             -secure  => $val->{secure} || 0
  78         );
  79
  80         push @cookies, $cookie->as_string;
  81     }
  82
  83     for my $cookie (@cookies) {
  84         $c->res->headers->push_header( 'Set-Cookie' => $cookie );
  85     }
  86 }
  87
  88 =head2 $self->finalize_error($c)
  89
  90 Output an apropriate error message, called if there's an error in $c
  91 after the dispatch has finished. Will output debug messages if Catalyst
  92 is in debug mode, or a `please come back later` message otherwise.
  93
  94 =cut
  95
  96 sub finalize_error {
  97     my ( $self, $c ) = @_;
  98
  99     $c->res->content_type('text/html; charset=utf-8');
 100     my $name = $c->config->{name} || join(' ', split('::', ref $c));
 101
 102     my ( $title, $error, $infos );
 103     if ( $c->debug ) {
 104
 105         # For pretty dumps
 106         $error = join '', map {
 107                 '<p><code class="error">'
 108               . encode_entities($_)
 109               . '</code></p>'
 110         } @{ $c->error };
 111         $error ||= 'No output';
 112         $error = qq{<pre wrap="">$error</pre>};
 113         $title = $name = "$name on Catalyst $Catalyst::VERSION";
 114         $name  = "<h1>$name</h1>";
 115
 116         # Don't show context in the dump
 117         delete $c->req->{_context};
 118         delete $c->res->{_context};
 119
 120         # Don't show body parser in the dump
 121         delete $c->req->{_body};
 122
 123         # Don't show response header state in dump
 124         delete $c->res->{_finalized_headers};
 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( dump( $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 (fr) SVP veuillez revenir plus tard
 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: #333;
 183             background-color: #eee;
 184             margin: 0px;
 185             padding: 0px;
 186         }
 187         :link, :link:hover, :visited, :visited:hover {
 188             color: #000;
 189         }
 190         div.box {
 191             position: relative;
 192             background-color: #ccc;
 193             border: 1px solid #aaa;
 194             padding: 4px;
 195             margin: 10px;
 196         }
 197         div.error {
 198             background-color: #cce;
 199             border: 1px solid #755;
 200             padding: 8px;
 201             margin: 4px;
 202             margin-bottom: 10px;
 203         }
 204         div.infos {
 205             background-color: #eee;
 206             border: 1px solid #575;
 207             padding: 8px;
 208             margin: 4px;
 209             margin-bottom: 10px;
 210         }
 211         div.name {
 212             background-color: #cce;
 213             border: 1px solid #557;
 214             padding: 8px;
 215             margin: 4px;
 216         }
 217         code.error {
 218             display: block;
 219             margin: 1em 0;
 220             overflow: auto;
 221         }
 222         div.name h1, div.error p {
 223             margin: 0;
 224         }
 225         h2 {
 226             margin-top: 0;
 227             margin-bottom: 10px;
 228             font-size: medium;
 229             font-weight: bold;
 230             text-decoration: underline;
 231         }
 232         h1 {
 233             font-size: medium;
 234             font-weight: normal;
 235         }
 236         /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
 237         /* Browser specific (not valid) styles to make preformatted text wrap */
 238         pre {
 239             white-space: pre-wrap;       /* css-3 */
 240             white-space: -moz-pre-wrap;  /* Mozilla, since 1999 */
 241             white-space: -pre-wrap;      /* Opera 4-6 */
 242             white-space: -o-pre-wrap;    /* Opera 7 */
 243             word-wrap: break-word;       /* Internet Explorer 5.5+ */
 244         }
 245     </style>
 246 </head>
 247 <body>
 248     <div class="box">
 249         <div class="error">$error</div>
 250         <div class="infos">$infos</div>
 251         <div class="name">$name</div>
 252     </div>
 253 </body>
 254 </html>
 255
 256
 257     # Trick IE
 258     $c->res->{body} .= ( ' ' x 512 );
 259
 260     # Return 500
 261     $c->res->status(500);
 262 }
 263
 264 =head2 $self->finalize_headers($c)
 265
 266 Abstract method, allows engines to write headers to response
 267
 268 =cut
 269
 270 sub finalize_headers { }
 271
 272 =head2 $self->finalize_read($c)
 273
 274 =cut
 275
 276 sub finalize_read {
 277     my ( $self, $c ) = @_;
 278
 279     undef $self->{_prepared_read};
 280 }
 281
 282 =head2 $self->finalize_uploads($c)
 283
 284 Clean up after uploads, deleting temp files.
 285
 286 =cut
 287
 288 sub finalize_uploads {
 289     my ( $self, $c ) = @_;
 290
 291     if ( keys %{ $c->request->uploads } ) {
 292         for my $key ( keys %{ $c->request->uploads } ) {
 293             my $upload = $c->request->uploads->{$key};
 294             unlink map { $_->tempname }
 295               grep     { -e $_->tempname }
 296               ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
 297         }
 298     }
 299 }
 300
 301 =head2 $self->prepare_body($c)
 302
 303 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
 304
 305 =cut
 306
 307 sub prepare_body {
 308     my ( $self, $c ) = @_;
 309
 310     $self->read_length( $c->request->header('Content-Length') || 0 );
 311     my $type = $c->request->header('Content-Type');
 312
 313     unless ( $c->request->{_body} ) {
 314         $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
 315         $c->request->{_body}->{tmpdir} = $c->config->{uploadtmp}
 316           if exists $c->config->{uploadtmp};
 317     }
 318
 319     if ( $self->read_length > 0 ) {
 320         while ( my $buffer = $self->read($c) ) {
 321             $c->prepare_body_chunk($buffer);
 322         }
 323
 324         # paranoia against wrong Content-Length header
 325         my $remaining = $self->read_length - $self->read_position;
 326         if ( $remaining > 0 ) {
 327             $self->finalize_read($c);
 328             Catalyst::Exception->throw(
 329                 "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::Simple::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::Simple::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     foreach my $name ( keys %{ $c->request->query_parameters } ) {
 396         my $param = $c->request->query_parameters->{$name};
 397         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 398         $c->request->parameters->{$name} = $param;
 399     }
 400
 401     # Merge query and body parameters
 402     foreach my $name ( keys %{ $c->request->body_parameters } ) {
 403         my $param = $c->request->body_parameters->{$name};
 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
 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;