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 =head2 $self->finalize_output
  34
  35 <obsolete>, see finalize_body
  36
  37 =head2 $self->finalize_body($c)
  38
  39 Finalize body.  Prints the response output.
  40
  41 =cut
  42
  43 sub finalize_body {
  44     my ( $self, $c ) = @_;
  45     if ( ref $c->response->body && $c->response->body->can('read') ) {
  46         while ( !$c->response->body->eof() ) {
  47             $c->response->body->read( my $buffer, $CHUNKSIZE );
  48             last unless $self->write( $c, $buffer );
  49         }
  50         $c->response->body->close();
  51     }
  52     else {
  53         $self->write( $c, $c->response->body );
  54     }
  55 }
  56
  57 =head2 $self->finalize_cookies($c)
  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 =cut
  87
  88 sub finalize_error {
  89     my ( $self, $c ) = @_;
  90
  91     $c->res->content_type('text/html; charset=utf-8');
  92     my $name = $c->config->{name} || 'Catalyst Application';
  93
  94     my ( $title, $error, $infos );
  95     if ( $c->debug ) {
  96
  97         # For pretty dumps
  98         local $Data::Dumper::Terse = 1;
  99         $error = join '', map {
 100                 '<p><code class="error">'
 101               . encode_entities($_)
 102               . '</code></p>'
 103         } @{ $c->error };
 104         $error ||= 'No output';
 105         $error = qq{<pre wrap="">$error</pre>};
 106         $title = $name = "$name on Catalyst $Catalyst::VERSION";
 107         $name  = "<h1>$name</h1>";
 108
 109         # Don't show context in the dump
 110         delete $c->req->{_context};
 111         delete $c->res->{_context};
 112
 113         # Don't show body parser in the dump
 114         delete $c->req->{_body};
 115
 116         # Don't show response header state in dump
 117         delete $c->res->{_finalized_headers};
 118
 119         my $req   = encode_entities Dumper $c->req;
 120         my $res   = encode_entities Dumper $c->res;
 121         my $stash = encode_entities Dumper $c->stash;
 122
 123         my @infos;
 124         my $i = 0;
 125         for my $dump ( $c->dump_these ) {
 126             my $name  = $dump->[0];
 127             my $value = encode_entities( Dumper $dump->[1] );
 128             push @infos, sprintf <<"EOF", $name, $value;
 129 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
 130 <div id="dump_$i">
 131     <pre wrap="">%s</pre>
 132 </div>
 133 EOF
 134             $i++;
 135         }
 136         $infos = join "\n", @infos;
 137     }
 138     else {
 139         $title = $name;
 140         $error = '';
 141         $infos = <<"";
 142 <pre>
 143 (en) Please come back later
 144 (de) Bitte versuchen sie es spaeter nocheinmal
 145 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
 146 (no) Vennligst prov igjen senere
 147 (dk) Venligst prov igen senere
 148 (pl) Prosze sprobowac pozniej
 149 </pre>
 150
 151         $name = '';
 152     }
 153     $c->res->body( <<"" );
 154 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 155     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 156 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
 157 <head>
 158     <meta http-equiv="Content-Language" content="en" />
 159     <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
 160     <title>$title</title>
 161     <script type="text/javascript">
 162         <!--
 163         function toggleDump (dumpElement) {
 164             var e = document.getElementById( dumpElement );
 165             if (e.style.display == "none") {
 166                 e.style.display = "";
 167             }
 168             else {
 169                 e.style.display = "none";
 170             }
 171         }
 172         -->
 173     </script>
 174     <style type="text/css">
 175         body {
 176             font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
 177                          Tahoma, Arial, helvetica, sans-serif;
 178             color: #ddd;
 179             background-color: #eee;
 180             margin: 0px;
 181             padding: 0px;
 182         }
 183         :link, :link:hover, :visited, :visited:hover {
 184             color: #ddd;
 185         }
 186         div.box {
 187             position: relative;
 188             background-color: #ccc;
 189             border: 1px solid #aaa;
 190             padding: 4px;
 191             margin: 10px;
 192             -moz-border-radius: 10px;
 193         }
 194         div.error {
 195             background-color: #977;
 196             border: 1px solid #755;
 197             padding: 8px;
 198             margin: 4px;
 199             margin-bottom: 10px;
 200             -moz-border-radius: 10px;
 201         }
 202         div.infos {
 203             background-color: #797;
 204             border: 1px solid #575;
 205             padding: 8px;
 206             margin: 4px;
 207             margin-bottom: 10px;
 208             -moz-border-radius: 10px;
 209         }
 210         div.name {
 211             background-color: #779;
 212             border: 1px solid #557;
 213             padding: 8px;
 214             margin: 4px;
 215             -moz-border-radius: 10px;
 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 =cut
 267
 268 sub finalize_headers { }
 269
 270 =head2 $self->finalize_read($c)
 271
 272 =cut
 273
 274 sub finalize_read {
 275     my ( $self, $c ) = @_;
 276
 277     undef $self->{_prepared_read};
 278 }
 279
 280 =head2 $self->finalize_uploads($c)
 281
 282 =cut
 283
 284 sub finalize_uploads {
 285     my ( $self, $c ) = @_;
 286
 287     if ( keys %{ $c->request->uploads } ) {
 288         for my $key ( keys %{ $c->request->uploads } ) {
 289             my $upload = $c->request->uploads->{$key};
 290             unlink map { $_->tempname }
 291               grep     { -e $_->tempname }
 292               ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
 293         }
 294     }
 295 }
 296
 297 =head2 $self->prepare_body($c)
 298
 299 =cut
 300
 301 sub prepare_body {
 302     my ( $self, $c ) = @_;
 303
 304     $self->read_length( $c->request->header('Content-Length') || 0 );
 305     my $type = $c->request->header('Content-Type');
 306
 307     unless ( $c->request->{_body} ) {
 308         $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
 309     }
 310
 311     if ( $self->read_length > 0 ) {
 312         while ( my $buffer = $self->read($c) ) {
 313             $c->prepare_body_chunk($buffer);
 314         }
 315
 316         # paranoia against wrong Content-Length header
 317         my $remaining = $self->read_length - $self->read_position;
 318         if ($remaining > 0) {
 319             $self->finalize_read($c);
 320             Catalyst::Exception->throw("Wrong Content-Length value: ". $self->read_length);
 321         }
 322     }
 323 }
 324
 325 =head2 $self->prepare_body_chunk($c)
 326
 327 =cut
 328
 329 sub prepare_body_chunk {
 330     my ( $self, $c, $chunk ) = @_;
 331
 332     $c->request->{_body}->add($chunk);
 333 }
 334
 335 =head2 $self->prepare_body_parameters($c)
 336
 337 =cut
 338
 339 sub prepare_body_parameters {
 340     my ( $self, $c ) = @_;
 341     $c->request->body_parameters( $c->request->{_body}->param );
 342 }
 343
 344 =head2 $self->prepare_connection($c)
 345
 346 =cut
 347
 348 sub prepare_connection { }
 349
 350 =head2 $self->prepare_cookies($c)
 351
 352 =cut
 353
 354 sub prepare_cookies {
 355     my ( $self, $c ) = @_;
 356
 357     if ( my $header = $c->request->header('Cookie') ) {
 358         $c->req->cookies( { CGI::Cookie->parse($header) } );
 359     }
 360 }
 361
 362 =head2 $self->prepare_headers($c)
 363
 364 =cut
 365
 366 sub prepare_headers { }
 367
 368 =head2 $self->prepare_parameters($c)
 369
 370 =cut
 371
 372 sub prepare_parameters {
 373     my ( $self, $c ) = @_;
 374
 375     # We copy, no references
 376     while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
 377         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 378         $c->request->parameters->{$name} = $param;
 379     }
 380
 381     # Merge query and body parameters
 382     while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
 383         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 384         if ( my $old_param = $c->request->parameters->{$name} ) {
 385             if ( ref $old_param eq 'ARRAY' ) {
 386                 push @{ $c->request->parameters->{$name} },
 387                   ref $param eq 'ARRAY' ? @$param : $param;
 388             }
 389             else { $c->request->parameters->{$name} = [ $old_param, $param ] }
 390         }
 391         else { $c->request->parameters->{$name} = $param }
 392     }
 393 }
 394
 395 =head2 $self->prepare_path($c)
 396
 397 =cut
 398
 399 sub prepare_path { }
 400
 401 =head2 $self->prepare_request($c)
 402
 403 =head2 $self->prepare_query_parameters($c)
 404
 405 =cut
 406
 407 sub prepare_query_parameters {
 408     my ( $self, $c, $query_string ) = @_;
 409
 410     # replace semi-colons
 411     $query_string =~ s/;/&/g;
 412
 413     my $u = URI->new( '', 'http' );
 414     $u->query($query_string);
 415     for my $key ( $u->query_param ) {
 416         my @vals = $u->query_param($key);
 417         $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
 418     }
 419 }
 420
 421 =head2 $self->prepare_read($c)
 422
 423 =cut
 424
 425 sub prepare_read {
 426     my ( $self, $c ) = @_;
 427
 428     # Reset the read position
 429     $self->read_position(0);
 430 }
 431
 432 =head2 $self->prepare_request(@arguments)
 433
 434 =cut
 435
 436 sub prepare_request { }
 437
 438 =head2 $self->prepare_uploads($c)
 439
 440 =cut
 441
 442 sub prepare_uploads {
 443     my ( $self, $c ) = @_;
 444     my $uploads = $c->request->{_body}->upload;
 445     for my $name ( keys %$uploads ) {
 446         my $files = $uploads->{$name};
 447         $files = ref $files eq 'ARRAY' ? $files : [$files];
 448         my @uploads;
 449         for my $upload (@$files) {
 450             my $u = Catalyst::Request::Upload->new;
 451             $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
 452             $u->type( $u->headers->content_type );
 453             $u->tempname( $upload->{tempname} );
 454             $u->size( $upload->{size} );
 455             $u->filename( $upload->{filename} );
 456             push @uploads, $u;
 457         }
 458         $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
 459
 460         # support access to the filename as a normal param
 461         my @filenames = map { $_->{filename} } @uploads;
 462         $c->request->parameters->{$name} =
 463           @filenames > 1 ? \@filenames : $filenames[0];
 464     }
 465 }
 466
 467 =head2 $self->prepare_write($c)
 468
 469 =cut
 470
 471 sub prepare_write { }
 472
 473 =head2 $self->read($c, [$maxlength])
 474
 475 =cut
 476
 477 sub read {
 478     my ( $self, $c, $maxlength ) = @_;
 479
 480     unless ( $self->{_prepared_read} ) {
 481         $self->prepare_read($c);
 482         $self->{_prepared_read} = 1;
 483     }
 484
 485     my $remaining = $self->read_length - $self->read_position;
 486     $maxlength ||= $CHUNKSIZE;
 487
 488     # Are we done reading?
 489     if ( $remaining <= 0 ) {
 490         $self->finalize_read($c);
 491         return;
 492     }
 493
 494     my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
 495     my $rc = $self->read_chunk( $c, my $buffer, $readlen );
 496     if ( defined $rc ) {
 497         $self->read_position( $self->read_position + $rc );
 498         return $buffer;
 499     }
 500     else {
 501         Catalyst::Exception->throw(
 502             message => "Unknown error reading input: $!" );
 503     }
 504 }
 505
 506 =head2 $self->read_chunk($c, $buffer, $length)
 507
 508 Each engine inplements read_chunk as its preferred way of reading a chunk
 509 of data.
 510
 511 =cut
 512
 513 sub read_chunk { }
 514
 515 =head2 $self->read_length
 516
 517 The length of input data to be read.  This is obtained from the Content-Length
 518 header.
 519
 520 =head2 $self->read_position
 521
 522 The amount of input data that has already been read.
 523
 524 =head2 $self->run($c)
 525
 526 =cut
 527
 528 sub run { }
 529
 530 =head2 $self->write($c, $buffer)
 531
 532 =cut
 533
 534 sub write {
 535     my ( $self, $c, $buffer ) = @_;
 536
 537     unless ( $self->{_prepared_write} ) {
 538         $self->prepare_write($c);
 539         $self->{_prepared_write} = 1;
 540     }
 541
 542     print STDOUT $buffer;
 543 }
 544
 545 =head1 AUTHORS
 546
 547 Sebastian Riedel, <sri@cpan.org>
 548
 549 Andy Grundman, <andy@hybridized.org>
 550
 551 =head1 COPYRIGHT
 552
 553 This program is free software, you can redistribute it and/or modify it under
 554 the same terms as Perl itself.
 555
 556 =cut
 557
 558 1;