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 = "<pre>$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>%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     </style>
 237 </head>
 238 <body>
 239     <div class="box">
 240         <div class="error">$error</div>
 241         <div class="infos">$infos</div>
 242         <div class="name">$name</div>
 243     </div>
 244 </body>
 245 </html>
 246
 247
 248     # Trick IE
 249     $c->res->{body} .= ( ' ' x 512 );
 250
 251     # Return 500
 252     $c->res->status(500) unless $c->res->status;
 253 }
 254
 255 =head2 $self->finalize_headers($c)
 256
 257 =cut
 258
 259 sub finalize_headers { }
 260
 261 =head2 $self->finalize_read($c)
 262
 263 =cut
 264
 265 sub finalize_read {
 266     my ( $self, $c ) = @_;
 267
 268     undef $self->{_prepared_read};
 269 }
 270
 271 =head2 $self->finalize_uploads($c)
 272
 273 =cut
 274
 275 sub finalize_uploads {
 276     my ( $self, $c ) = @_;
 277
 278     if ( keys %{ $c->request->uploads } ) {
 279         for my $key ( keys %{ $c->request->uploads } ) {
 280             my $upload = $c->request->uploads->{$key};
 281             unlink map { $_->tempname }
 282               grep     { -e $_->tempname }
 283               ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
 284         }
 285     }
 286 }
 287
 288 =head2 $self->prepare_body($c)
 289
 290 =cut
 291
 292 sub prepare_body {
 293     my ( $self, $c ) = @_;
 294
 295     $self->read_length( $c->request->header('Content-Length') || 0 );
 296     my $type = $c->request->header('Content-Type');
 297
 298     unless ( $c->request->{_body} ) {
 299         $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
 300     }
 301
 302     if ( $self->read_length > 0 ) {
 303         while ( my $buffer = $self->read($c) ) {
 304             $c->prepare_body_chunk($buffer);
 305         }
 306     }
 307 }
 308
 309 =head2 $self->prepare_body_chunk($c)
 310
 311 =cut
 312
 313 sub prepare_body_chunk {
 314     my ( $self, $c, $chunk ) = @_;
 315
 316     $c->request->{_body}->add($chunk);
 317 }
 318
 319 =head2 $self->prepare_body_parameters($c)
 320
 321 =cut
 322
 323 sub prepare_body_parameters {
 324     my ( $self, $c ) = @_;
 325     $c->request->body_parameters( $c->request->{_body}->param );
 326 }
 327
 328 =head2 $self->prepare_connection($c)
 329
 330 =cut
 331
 332 sub prepare_connection { }
 333
 334 =head2 $self->prepare_cookies($c)
 335
 336 =cut
 337
 338 sub prepare_cookies {
 339     my ( $self, $c ) = @_;
 340
 341     if ( my $header = $c->request->header('Cookie') ) {
 342         $c->req->cookies( { CGI::Cookie->parse($header) } );
 343     }
 344 }
 345
 346 =head2 $self->prepare_headers($c)
 347
 348 =cut
 349
 350 sub prepare_headers { }
 351
 352 =head2 $self->prepare_parameters($c)
 353
 354 =cut
 355
 356 sub prepare_parameters {
 357     my ( $self, $c ) = @_;
 358
 359     # We copy, no references
 360     while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
 361         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 362         $c->request->parameters->{$name} = $param;
 363     }
 364
 365     # Merge query and body parameters
 366     while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
 367         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 368         if ( my $old_param = $c->request->parameters->{$name} ) {
 369             if ( ref $old_param eq 'ARRAY' ) {
 370                 push @{ $c->request->parameters->{$name} },
 371                   ref $param eq 'ARRAY' ? @$param : $param;
 372             }
 373             else { $c->request->parameters->{$name} = [ $old_param, $param ] }
 374         }
 375         else { $c->request->parameters->{$name} = $param }
 376     }
 377 }
 378
 379 =head2 $self->prepare_path($c)
 380
 381 =cut
 382
 383 sub prepare_path { }
 384
 385 =head2 $self->prepare_request($c)
 386
 387 =head2 $self->prepare_query_parameters($c)
 388
 389 =cut
 390
 391 sub prepare_query_parameters {
 392     my ( $self, $c, $query_string ) = @_;
 393
 394     # replace semi-colons
 395     $query_string =~ s/;/&/g;
 396
 397     my $u = URI->new( '', 'http' );
 398     $u->query($query_string);
 399     for my $key ( $u->query_param ) {
 400         my @vals = $u->query_param($key);
 401         $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
 402     }
 403 }
 404
 405 =head2 $self->prepare_read($c)
 406
 407 =cut
 408
 409 sub prepare_read {
 410     my ( $self, $c ) = @_;
 411
 412     # Reset the read position
 413     $self->read_position(0);
 414 }
 415
 416 =head2 $self->prepare_request(@arguments)
 417
 418 =cut
 419
 420 sub prepare_request { }
 421
 422 =head2 $self->prepare_uploads($c)
 423
 424 =cut
 425
 426 sub prepare_uploads {
 427     my ( $self, $c ) = @_;
 428     my $uploads = $c->request->{_body}->upload;
 429     for my $name ( keys %$uploads ) {
 430         my $files = $uploads->{$name};
 431         $files = ref $files eq 'ARRAY' ? $files : [$files];
 432         my @uploads;
 433         for my $upload (@$files) {
 434             my $u = Catalyst::Request::Upload->new;
 435             $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
 436             $u->type( $u->headers->content_type );
 437             $u->tempname( $upload->{tempname} );
 438             $u->size( $upload->{size} );
 439             $u->filename( $upload->{filename} );
 440             push @uploads, $u;
 441         }
 442         $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
 443
 444         # support access to the filename as a normal param
 445         my @filenames = map { $_->{filename} } @uploads;
 446         $c->request->parameters->{$name} =
 447           @filenames > 1 ? \@filenames : $filenames[0];
 448     }
 449 }
 450
 451 =head2 $self->prepare_write($c)
 452
 453 =cut
 454
 455 sub prepare_write { }
 456
 457 =head2 $self->read($c, [$maxlength])
 458
 459 =cut
 460
 461 sub read {
 462     my ( $self, $c, $maxlength ) = @_;
 463
 464     unless ( $self->{_prepared_read} ) {
 465         $self->prepare_read($c);
 466         $self->{_prepared_read} = 1;
 467     }
 468
 469     my $remaining = $self->read_length - $self->read_position;
 470     $maxlength ||= $CHUNKSIZE;
 471
 472     # Are we done reading?
 473     if ( $remaining <= 0 ) {
 474         $self->finalize_read($c);
 475         return;
 476     }
 477
 478     my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
 479     my $rc = $self->read_chunk( $c, my $buffer, $readlen );
 480     if ( defined $rc ) {
 481         $self->read_position( $self->read_position + $rc );
 482         return $buffer;
 483     }
 484     else {
 485         Catalyst::Exception->throw(
 486             message => "Unknown error reading input: $!" );
 487     }
 488 }
 489
 490 =head2 $self->read_chunk($c, $buffer, $length)
 491
 492 Each engine inplements read_chunk as its preferred way of reading a chunk
 493 of data.
 494
 495 =cut
 496
 497 sub read_chunk { }
 498
 499 =head2 $self->read_length
 500
 501 The length of input data to be read.  This is obtained from the Content-Length
 502 header.
 503
 504 =head2 $self->read_position
 505
 506 The amount of input data that has already been read.
 507
 508 =head2 $self->run($c)
 509
 510 =cut
 511
 512 sub run { }
 513
 514 =head2 $self->write($c, $buffer)
 515
 516 =cut
 517
 518 sub write {
 519     my ( $self, $c, $buffer ) = @_;
 520
 521     unless ( $self->{_prepared_write} ) {
 522         $self->prepare_write($c);
 523         $self->{_prepared_write} = 1;
 524     }
 525
 526     print STDOUT $buffer;
 527 }
 528
 529 =head1 AUTHORS
 530
 531 Sebastian Riedel, <sri@cpan.org>
 532
 533 Andy Grundman, <andy@hybridized.org>
 534
 535 =head1 COPYRIGHT
 536
 537 This program is free software, you can redistribute it and/or modify it under
 538 the same terms as Perl itself.
 539
 540 =cut
 541
 542 1;