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 }
 317
 318 =head2 $self->prepare_body_chunk($c)
 319
 320 =cut
 321
 322 sub prepare_body_chunk {
 323     my ( $self, $c, $chunk ) = @_;
 324
 325     $c->request->{_body}->add($chunk);
 326 }
 327
 328 =head2 $self->prepare_body_parameters($c)
 329
 330 =cut
 331
 332 sub prepare_body_parameters {
 333     my ( $self, $c ) = @_;
 334     $c->request->body_parameters( $c->request->{_body}->param );
 335 }
 336
 337 =head2 $self->prepare_connection($c)
 338
 339 =cut
 340
 341 sub prepare_connection { }
 342
 343 =head2 $self->prepare_cookies($c)
 344
 345 =cut
 346
 347 sub prepare_cookies {
 348     my ( $self, $c ) = @_;
 349
 350     if ( my $header = $c->request->header('Cookie') ) {
 351         $c->req->cookies( { CGI::Cookie->parse($header) } );
 352     }
 353 }
 354
 355 =head2 $self->prepare_headers($c)
 356
 357 =cut
 358
 359 sub prepare_headers { }
 360
 361 =head2 $self->prepare_parameters($c)
 362
 363 =cut
 364
 365 sub prepare_parameters {
 366     my ( $self, $c ) = @_;
 367
 368     # We copy, no references
 369     while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
 370         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 371         $c->request->parameters->{$name} = $param;
 372     }
 373
 374     # Merge query and body parameters
 375     while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
 376         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 377         if ( my $old_param = $c->request->parameters->{$name} ) {
 378             if ( ref $old_param eq 'ARRAY' ) {
 379                 push @{ $c->request->parameters->{$name} },
 380                   ref $param eq 'ARRAY' ? @$param : $param;
 381             }
 382             else { $c->request->parameters->{$name} = [ $old_param, $param ] }
 383         }
 384         else { $c->request->parameters->{$name} = $param }
 385     }
 386 }
 387
 388 =head2 $self->prepare_path($c)
 389
 390 =cut
 391
 392 sub prepare_path { }
 393
 394 =head2 $self->prepare_request($c)
 395
 396 =head2 $self->prepare_query_parameters($c)
 397
 398 =cut
 399
 400 sub prepare_query_parameters {
 401     my ( $self, $c, $query_string ) = @_;
 402
 403     # replace semi-colons
 404     $query_string =~ s/;/&/g;
 405
 406     my $u = URI->new( '', 'http' );
 407     $u->query($query_string);
 408     for my $key ( $u->query_param ) {
 409         my @vals = $u->query_param($key);
 410         $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
 411     }
 412 }
 413
 414 =head2 $self->prepare_read($c)
 415
 416 =cut
 417
 418 sub prepare_read {
 419     my ( $self, $c ) = @_;
 420
 421     # Reset the read position
 422     $self->read_position(0);
 423 }
 424
 425 =head2 $self->prepare_request(@arguments)
 426
 427 =cut
 428
 429 sub prepare_request { }
 430
 431 =head2 $self->prepare_uploads($c)
 432
 433 =cut
 434
 435 sub prepare_uploads {
 436     my ( $self, $c ) = @_;
 437     my $uploads = $c->request->{_body}->upload;
 438     for my $name ( keys %$uploads ) {
 439         my $files = $uploads->{$name};
 440         $files = ref $files eq 'ARRAY' ? $files : [$files];
 441         my @uploads;
 442         for my $upload (@$files) {
 443             my $u = Catalyst::Request::Upload->new;
 444             $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
 445             $u->type( $u->headers->content_type );
 446             $u->tempname( $upload->{tempname} );
 447             $u->size( $upload->{size} );
 448             $u->filename( $upload->{filename} );
 449             push @uploads, $u;
 450         }
 451         $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
 452
 453         # support access to the filename as a normal param
 454         my @filenames = map { $_->{filename} } @uploads;
 455         $c->request->parameters->{$name} =
 456           @filenames > 1 ? \@filenames : $filenames[0];
 457     }
 458 }
 459
 460 =head2 $self->prepare_write($c)
 461
 462 =cut
 463
 464 sub prepare_write { }
 465
 466 =head2 $self->read($c, [$maxlength])
 467
 468 =cut
 469
 470 sub read {
 471     my ( $self, $c, $maxlength ) = @_;
 472
 473     unless ( $self->{_prepared_read} ) {
 474         $self->prepare_read($c);
 475         $self->{_prepared_read} = 1;
 476     }
 477
 478     my $remaining = $self->read_length - $self->read_position;
 479     $maxlength ||= $CHUNKSIZE;
 480
 481     # Are we done reading?
 482     if ( $remaining <= 0 ) {
 483         $self->finalize_read($c);
 484         return;
 485     }
 486
 487     my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
 488     my $rc = $self->read_chunk( $c, my $buffer, $readlen );
 489     if ( defined $rc ) {
 490         $self->read_position( $self->read_position + $rc );
 491         return $buffer;
 492     }
 493     else {
 494         Catalyst::Exception->throw(
 495             message => "Unknown error reading input: $!" );
 496     }
 497 }
 498
 499 =head2 $self->read_chunk($c, $buffer, $length)
 500
 501 Each engine inplements read_chunk as its preferred way of reading a chunk
 502 of data.
 503
 504 =cut
 505
 506 sub read_chunk { }
 507
 508 =head2 $self->read_length
 509
 510 The length of input data to be read.  This is obtained from the Content-Length
 511 header.
 512
 513 =head2 $self->read_position
 514
 515 The amount of input data that has already been read.
 516
 517 =head2 $self->run($c)
 518
 519 =cut
 520
 521 sub run { }
 522
 523 =head2 $self->write($c, $buffer)
 524
 525 =cut
 526
 527 sub write {
 528     my ( $self, $c, $buffer ) = @_;
 529
 530     unless ( $self->{_prepared_write} ) {
 531         $self->prepare_write($c);
 532         $self->{_prepared_write} = 1;
 533     }
 534
 535     print STDOUT $buffer;
 536 }
 537
 538 =head1 AUTHORS
 539
 540 Sebastian Riedel, <sri@cpan.org>
 541
 542 Andy Grundman, <andy@hybridized.org>
 543
 544 =head1 COPYRIGHT
 545
 546 This program is free software, you can redistribute it and/or modify it under
 547 the same terms as Perl itself.
 548
 549 =cut
 550
 551 1;