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