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 =over 4
  34
  35 =item $self->finalize_output
  36
  37 <obsolete>, see finalize_body
  38
  39 =item $self->finalize_body($c)
  40
  41 Finalize body.  Prints the response output.
  42
  43 =cut
  44
  45 sub finalize_body {
  46     my ( $self, $c ) = @_;
  47     if ( ref $c->response->body && $c->response->body->can('read') ) {
  48         while ( !$c->response->body->eof() ) {
  49             $c->response->body->read( my $buffer, $CHUNKSIZE );
  50             $self->write( $c, $buffer );
  51         }
  52         $c->response->body->close();
  53     }
  54     else {
  55         $self->write( $c, $c->response->body );
  56     }
  57 }
  58
  59 =item $self->finalize_cookies($c)
  60
  61 =cut
  62
  63 sub finalize_cookies {
  64     my ( $self, $c ) = @_;
  65
  66     my @cookies;
  67     while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
  68
  69         my $cookie = CGI::Cookie->new(
  70             -name    => $name,
  71             -value   => $cookie->{value},
  72             -expires => $cookie->{expires},
  73             -domain  => $cookie->{domain},
  74             -path    => $cookie->{path},
  75             -secure  => $cookie->{secure} || 0
  76         );
  77
  78         push @cookies, $cookie->as_string;
  79     }
  80
  81     if (@cookies) {
  82         $c->res->headers->push_header( 'Set-Cookie' => join ',', @cookies );
  83     }
  84 }
  85
  86 =item $self->finalize_error($c)
  87
  88 =cut
  89
  90 sub finalize_error {
  91     my ( $self, $c ) = @_;
  92
  93     $c->res->content_type('text/html; charset=utf-8');
  94     my $name = $c->config->{name} || 'Catalyst Application';
  95
  96     my ( $title, $error, $infos );
  97     if ( $c->debug ) {
  98
  99         # For pretty dumps
 100         local $Data::Dumper::Terse = 1;
 101         $error = join '',
 102           map { '<code class="error">' . encode_entities($_) . '</code>' }
 103           @{ $c->error };
 104         $error ||= 'No output';
 105         $title = $name = "$name on Catalyst $Catalyst::VERSION";
 106
 107         # Don't show context in the dump
 108         delete $c->req->{_context};
 109         delete $c->res->{_context};
 110
 111         # Don't show body parser in the dump
 112         delete $c->req->{_body};
 113
 114         # Don't show response header state in dump
 115         delete $c->res->{_finalized_headers};
 116
 117         my $req   = encode_entities Dumper $c->req;
 118         my $res   = encode_entities Dumper $c->res;
 119         my $stash = encode_entities Dumper $c->stash;
 120
 121         my @infos;
 122         my $i = 0;
 123         for my $dump ( $c->dump_these ) {
 124             my $name  = $dump->[0];
 125             my $value = encode_entities( Dumper $dump->[1] );
 126             push @infos, sprintf <<"EOF", $name, $value;
 127 <div>
 128     <b><u>
 129         <a href="#" onclick="toggleDump('dump_$i'); return false">%s</a>
 130     </u></b>
 131 </div>
 132 <br/>
 133 <div id="dump_$i">
 134     <pre>%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 (de) Bitte versuchen sie es spaeter nocheinmal
 148 (nl) Gelieve te komen later terug
 149 (no) Vennligst prov igjen senere
 150 (fr) Veuillez revenir plus tard
 151 (es) Vuelto por favor mas adelante
 152 (pt) Voltado por favor mais tarde
 153 (it) Ritornato prego più successivamente
 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             background-color: #ccc;
 193             border: 1px solid #aaa;
 194             padding: 4px;
 195             margin: 10px;
 196             -moz-border-radius: 10px;
 197         }
 198         div.error {
 199             background-color: #977;
 200             border: 1px solid #755;
 201             padding: 8px;
 202             margin: 4px;
 203             margin-bottom: 10px;
 204             -moz-border-radius: 10px;
 205         }
 206         div.infos {
 207             background-color: #797;
 208             border: 1px solid #575;
 209             padding: 8px;
 210             margin: 4px;
 211             margin-bottom: 10px;
 212             -moz-border-radius: 10px;
 213         }
 214         div.name {
 215             background-color: #779;
 216             border: 1px solid #557;
 217             padding: 8px;
 218             margin: 4px;
 219             -moz-border-radius: 10px;
 220         }
 221         code.error {
 222             display: block;
 223             margin: 1em 0;
 224             overflow: auto;
 225             white-space: pre;
 226         }
 227     </style>
 228 </head>
 229 <body>
 230     <div class="box">
 231         <div class="error">$error</div>
 232         <div class="infos">$infos</div>
 233         <div class="name">$name</div>
 234     </div>
 235 </body>
 236 </html>
 237
 238 }
 239
 240 =item $self->finalize_headers($c)
 241
 242 =cut
 243
 244 sub finalize_headers { }
 245
 246 =item $self->finalize_read($c)
 247
 248 =cut
 249
 250 sub finalize_read {
 251     my ( $self, $c ) = @_;
 252
 253     undef $self->{_prepared_read};
 254 }
 255
 256 =item $self->finalize_uploads($c)
 257
 258 =cut
 259
 260 sub finalize_uploads {
 261     my ( $self, $c ) = @_;
 262
 263     if ( keys %{ $c->request->uploads } ) {
 264         for my $key ( keys %{ $c->request->uploads } ) {
 265             my $upload = $c->request->uploads->{$key};
 266             unlink map { $_->tempname }
 267               grep     { -e $_->tempname }
 268               ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
 269         }
 270     }
 271 }
 272
 273 =item $self->prepare_body($c)
 274
 275 =cut
 276
 277 sub prepare_body {
 278     my ( $self, $c ) = @_;
 279
 280     $self->read_length( $c->request->header('Content-Length') || 0 );
 281     my $type = $c->request->header('Content-Type');
 282
 283     unless ( $c->request->{_body} ) {
 284         $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
 285     }
 286
 287     if ( $self->read_length > 0 ) {
 288         while ( my $buffer = $self->read($c) ) {
 289             $c->prepare_body_chunk($buffer);
 290         }
 291     }
 292 }
 293
 294 =item $self->prepare_body_chunk($c)
 295
 296 =cut
 297
 298 sub prepare_body_chunk {
 299     my ( $self, $c, $chunk ) = @_;
 300
 301     $c->request->{_body}->add($chunk);
 302 }
 303
 304 =item $self->prepare_body_parameters($c)
 305
 306 =cut
 307
 308 sub prepare_body_parameters {
 309     my ( $self, $c ) = @_;
 310     $c->request->body_parameters( $c->request->{_body}->param );
 311 }
 312
 313 =item $self->prepare_connection($c)
 314
 315 =cut
 316
 317 sub prepare_connection { }
 318
 319 =item $self->prepare_cookies($c)
 320
 321 =cut
 322
 323 sub prepare_cookies {
 324     my ( $self, $c ) = @_;
 325
 326     if ( my $header = $c->request->header('Cookie') ) {
 327         $c->req->cookies( { CGI::Cookie->parse($header) } );
 328     }
 329 }
 330
 331 =item $self->prepare_headers($c)
 332
 333 =cut
 334
 335 sub prepare_headers { }
 336
 337 =item $self->prepare_parameters($c)
 338
 339 =cut
 340
 341 sub prepare_parameters {
 342     my ( $self, $c ) = @_;
 343
 344     # We copy, no references
 345     while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
 346         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 347         $c->request->parameters->{$name} = $param;
 348     }
 349
 350     # Merge query and body parameters
 351     while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
 352         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 353         if ( my $old_param = $c->request->parameters->{$name} ) {
 354             if ( ref $old_param eq 'ARRAY' ) {
 355                 push @{ $c->request->parameters->{$name} },
 356                   ref $param eq 'ARRAY' ? @$param : $param;
 357             }
 358             else { $c->request->parameters->{$name} = [ $old_param, $param ] }
 359         }
 360         else { $c->request->parameters->{$name} = $param }
 361     }
 362 }
 363
 364 =item $self->prepare_path($c)
 365
 366 =cut
 367
 368 sub prepare_path { }
 369
 370 =item $self->prepare_request($c)
 371
 372 =item $self->prepare_query_parameters($c)
 373
 374 =cut
 375
 376 sub prepare_query_parameters {
 377     my ( $self, $c, $query_string ) = @_;
 378
 379     # replace semi-colons
 380     $query_string =~ s/;/&/g;
 381
 382     my $u = URI->new( '', 'http' );
 383     $u->query($query_string);
 384     for my $key ( $u->query_param ) {
 385         my @vals = $u->query_param($key);
 386         $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
 387     }
 388 }
 389
 390 =item $self->prepare_read($c)
 391
 392 =cut
 393
 394 sub prepare_read {
 395     my ( $self, $c ) = @_;
 396
 397     # Reset the read position
 398     $self->read_position(0);
 399 }
 400
 401 =item $self->prepare_request(@arguments)
 402
 403 =cut
 404
 405 sub prepare_request { }
 406
 407 =item $self->prepare_uploads($c)
 408
 409 =cut
 410
 411 sub prepare_uploads {
 412     my ( $self, $c ) = @_;
 413     my $uploads = $c->request->{_body}->upload;
 414     for my $name ( keys %$uploads ) {
 415         my $files = $uploads->{$name};
 416         $files = ref $files eq 'ARRAY' ? $files : [$files];
 417         my @uploads;
 418         for my $upload (@$files) {
 419             my $u = Catalyst::Request::Upload->new;
 420             $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
 421             $u->type( $u->headers->content_type );
 422             $u->tempname( $upload->{tempname} );
 423             $u->size( $upload->{size} );
 424             $u->filename( $upload->{filename} );
 425             push @uploads, $u;
 426         }
 427         $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
 428
 429         # support access to the filename as a normal param
 430         my @filenames = map { $_->{filename} } @uploads;
 431         $c->request->parameters->{$name} =
 432           @filenames > 1 ? \@filenames : $filenames[0];
 433     }
 434 }
 435
 436 =item $self->prepare_write($c)
 437
 438 =cut
 439
 440 sub prepare_write { }
 441
 442 =item $self->read($c, [$maxlength])
 443
 444 =cut
 445
 446 sub read {
 447     my ( $self, $c, $maxlength ) = @_;
 448
 449     unless ( $self->{_prepared_read} ) {
 450         $self->prepare_read($c);
 451         $self->{_prepared_read} = 1;
 452     }
 453
 454     my $remaining = $self->read_length - $self->read_position;
 455     $maxlength ||= $CHUNKSIZE;
 456
 457     # Are we done reading?
 458     if ( $remaining <= 0 ) {
 459         $self->finalize_read($c);
 460         return;
 461     }
 462
 463     my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
 464     my $rc = $self->read_chunk( $c, my $buffer, $readlen );
 465     if ( defined $rc ) {
 466         $self->read_position( $self->read_position + $rc );
 467         return $buffer;
 468     }
 469     else {
 470         Catalyst::Exception->throw(
 471             message => "Unknown error reading input: $!" );
 472     }
 473 }
 474
 475 =item $self->read_chunk($c, $buffer, $length)
 476
 477 Each engine inplements read_chunk as its preferred way of reading a chunk
 478 of data.
 479
 480 =cut
 481
 482 sub read_chunk { }
 483
 484 =item $self->read_length
 485
 486 The length of input data to be read.  This is obtained from the Content-Length
 487 header.
 488
 489 =item $self->read_position
 490
 491 The amount of input data that has already been read.
 492
 493 =item $self->run($c)
 494
 495 =cut
 496
 497 sub run { }
 498
 499 =item $self->write($c, $buffer)
 500
 501 =cut
 502
 503 sub write {
 504     my ( $self, $c, $buffer ) = @_;
 505
 506     unless ( $self->{_prepared_write} ) {
 507         $self->prepare_write($c);
 508         $self->{_prepared_write} = 1;
 509     }
 510
 511     print STDOUT $buffer;
 512 }
 513
 514 =back
 515
 516 =head1 AUTHORS
 517
 518 Sebastian Riedel, <sri@cpan.org>
 519
 520 Andy Grundman, <andy@hybridized.org>
 521
 522 =head1 COPYRIGHT
 523
 524 This program is free software, you can redistribute it and/or modify it under
 525 the same terms as Perl itself.
 526
 527 =cut
 528
 529 1;