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         $title = $name = "$name on Catalyst $Catalyst::VERSION";
 106         $name = "<h1>$name</h1>";
 107
 108         # Don't show context in the dump
 109         delete $c->req->{_context};
 110         delete $c->res->{_context};
 111
 112         # Don't show body parser in the dump
 113         delete $c->req->{_body};
 114
 115         # Don't show response header state in dump
 116         delete $c->res->{_finalized_headers};
 117
 118         my $req   = encode_entities Dumper $c->req;
 119         my $res   = encode_entities Dumper $c->res;
 120         my $stash = encode_entities Dumper $c->stash;
 121
 122         my @infos;
 123         my $i = 0;
 124         for my $dump ( $c->dump_these ) {
 125             my $name  = $dump->[0];
 126             my $value = encode_entities( Dumper $dump->[1] );
 127             push @infos, sprintf <<"EOF", $name, $value;
 128 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
 129 <div id="dump_$i">
 130     <pre>%s</pre>
 131 </div>
 132 EOF
 133             $i++;
 134         }
 135         $infos = join "\n", @infos;
 136     }
 137     else {
 138         $title = $name;
 139         $error = '';
 140         $infos = <<"";
 141 <pre>
 142 (en) Please come back later
 143 (de) Bitte versuchen sie es spaeter nocheinmal
 144 (nl) Gelieve te komen later terug
 145 (no) Vennligst prov igjen senere
 146 (fr) Veuillez revenir plus tard
 147 (es) Vuelto por favor mas adelante
 148 (pt) Voltado por favor mais tarde
 149 (it) Ritornato prego più successivamente
 150 </pre>
 151
 152         $name = '';
 153     }
 154     $c->res->body( <<"" );
 155 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 156     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 157 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
 158 <head>
 159     <meta http-equiv="Content-Language" content="en" />
 160     <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
 161     <title>$title</title>
 162     <script type="text/javascript">
 163         <!--
 164         function toggleDump (dumpElement) {
 165             var e = document.getElementById( dumpElement );
 166             if (e.style.display == "none") {
 167                 e.style.display = "";
 168             }
 169             else {
 170                 e.style.display = "none";
 171             }
 172         }
 173         -->
 174     </script>
 175     <style type="text/css">
 176         body {
 177             font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
 178                          Tahoma, Arial, helvetica, sans-serif;
 179             color: #ddd;
 180             background-color: #eee;
 181             margin: 0px;
 182             padding: 0px;
 183         }
 184         :link, :link:hover, :visited, :visited:hover {
 185             color: #ddd;
 186         }
 187         div.box {
 188             position: relative;
 189             background-color: #ccc;
 190             border: 1px solid #aaa;
 191             padding: 4px;
 192             margin: 10px;
 193             -moz-border-radius: 10px;
 194         }
 195         div.error {
 196             background-color: #977;
 197             border: 1px solid #755;
 198             padding: 8px;
 199             margin: 4px;
 200             margin-bottom: 10px;
 201             -moz-border-radius: 10px;
 202         }
 203         div.infos {
 204             background-color: #797;
 205             border: 1px solid #575;
 206             padding: 8px;
 207             margin: 4px;
 208             margin-bottom: 10px;
 209             -moz-border-radius: 10px;
 210         }
 211         div.name {
 212             background-color: #779;
 213             border: 1px solid #557;
 214             padding: 8px;
 215             margin: 4px;
 216             -moz-border-radius: 10px;
 217         }
 218         code.error {
 219             display: block;
 220             margin: 1em 0;
 221             overflow: auto;
 222         }
 223         div.name h1, div.error p {
 224             margin: 0;
 225         }
 226         h2 {
 227             margin-top: 0;
 228             margin-bottom: 10px;
 229             font-size: medium;
 230             font-weight: bold;
 231             text-decoration: underline;
 232         }
 233         h1 {
 234             font-size: medium;
 235             font-weight: normal;
 236         }
 237     </style>
 238 </head>
 239 <body>
 240     <div class="box">
 241         <div class="error">$error</div>
 242         <div class="infos">$infos</div>
 243         <div class="name">$name</div>
 244     </div>
 245 </body>
 246 </html>
 247
 248 }
 249
 250 =head2 $self->finalize_headers($c)
 251
 252 =cut
 253
 254 sub finalize_headers { }
 255
 256 =head2 $self->finalize_read($c)
 257
 258 =cut
 259
 260 sub finalize_read {
 261     my ( $self, $c ) = @_;
 262
 263     undef $self->{_prepared_read};
 264 }
 265
 266 =head2 $self->finalize_uploads($c)
 267
 268 =cut
 269
 270 sub finalize_uploads {
 271     my ( $self, $c ) = @_;
 272
 273     if ( keys %{ $c->request->uploads } ) {
 274         for my $key ( keys %{ $c->request->uploads } ) {
 275             my $upload = $c->request->uploads->{$key};
 276             unlink map { $_->tempname }
 277               grep     { -e $_->tempname }
 278               ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
 279         }
 280     }
 281 }
 282
 283 =head2 $self->prepare_body($c)
 284
 285 =cut
 286
 287 sub prepare_body {
 288     my ( $self, $c ) = @_;
 289
 290     $self->read_length( $c->request->header('Content-Length') || 0 );
 291     my $type = $c->request->header('Content-Type');
 292
 293     unless ( $c->request->{_body} ) {
 294         $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
 295     }
 296
 297     if ( $self->read_length > 0 ) {
 298         while ( my $buffer = $self->read($c) ) {
 299             $c->prepare_body_chunk($buffer);
 300         }
 301     }
 302 }
 303
 304 =head2 $self->prepare_body_chunk($c)
 305
 306 =cut
 307
 308 sub prepare_body_chunk {
 309     my ( $self, $c, $chunk ) = @_;
 310
 311     $c->request->{_body}->add($chunk);
 312 }
 313
 314 =head2 $self->prepare_body_parameters($c)
 315
 316 =cut
 317
 318 sub prepare_body_parameters {
 319     my ( $self, $c ) = @_;
 320     $c->request->body_parameters( $c->request->{_body}->param );
 321 }
 322
 323 =head2 $self->prepare_connection($c)
 324
 325 =cut
 326
 327 sub prepare_connection { }
 328
 329 =head2 $self->prepare_cookies($c)
 330
 331 =cut
 332
 333 sub prepare_cookies {
 334     my ( $self, $c ) = @_;
 335
 336     if ( my $header = $c->request->header('Cookie') ) {
 337         $c->req->cookies( { CGI::Cookie->parse($header) } );
 338     }
 339 }
 340
 341 =head2 $self->prepare_headers($c)
 342
 343 =cut
 344
 345 sub prepare_headers { }
 346
 347 =head2 $self->prepare_parameters($c)
 348
 349 =cut
 350
 351 sub prepare_parameters {
 352     my ( $self, $c ) = @_;
 353
 354     # We copy, no references
 355     while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
 356         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 357         $c->request->parameters->{$name} = $param;
 358     }
 359
 360     # Merge query and body parameters
 361     while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
 362         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 363         if ( my $old_param = $c->request->parameters->{$name} ) {
 364             if ( ref $old_param eq 'ARRAY' ) {
 365                 push @{ $c->request->parameters->{$name} },
 366                   ref $param eq 'ARRAY' ? @$param : $param;
 367             }
 368             else { $c->request->parameters->{$name} = [ $old_param, $param ] }
 369         }
 370         else { $c->request->parameters->{$name} = $param }
 371     }
 372 }
 373
 374 =head2 $self->prepare_path($c)
 375
 376 =cut
 377
 378 sub prepare_path { }
 379
 380 =head2 $self->prepare_request($c)
 381
 382 =head2 $self->prepare_query_parameters($c)
 383
 384 =cut
 385
 386 sub prepare_query_parameters {
 387     my ( $self, $c, $query_string ) = @_;
 388
 389     # replace semi-colons
 390     $query_string =~ s/;/&/g;
 391
 392     my $u = URI->new( '', 'http' );
 393     $u->query($query_string);
 394     for my $key ( $u->query_param ) {
 395         my @vals = $u->query_param($key);
 396         $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
 397     }
 398 }
 399
 400 =head2 $self->prepare_read($c)
 401
 402 =cut
 403
 404 sub prepare_read {
 405     my ( $self, $c ) = @_;
 406
 407     # Reset the read position
 408     $self->read_position(0);
 409 }
 410
 411 =head2 $self->prepare_request(@arguments)
 412
 413 =cut
 414
 415 sub prepare_request { }
 416
 417 =head2 $self->prepare_uploads($c)
 418
 419 =cut
 420
 421 sub prepare_uploads {
 422     my ( $self, $c ) = @_;
 423     my $uploads = $c->request->{_body}->upload;
 424     for my $name ( keys %$uploads ) {
 425         my $files = $uploads->{$name};
 426         $files = ref $files eq 'ARRAY' ? $files : [$files];
 427         my @uploads;
 428         for my $upload (@$files) {
 429             my $u = Catalyst::Request::Upload->new;
 430             $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
 431             $u->type( $u->headers->content_type );
 432             $u->tempname( $upload->{tempname} );
 433             $u->size( $upload->{size} );
 434             $u->filename( $upload->{filename} );
 435             push @uploads, $u;
 436         }
 437         $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
 438
 439         # support access to the filename as a normal param
 440         my @filenames = map { $_->{filename} } @uploads;
 441         $c->request->parameters->{$name} =
 442           @filenames > 1 ? \@filenames : $filenames[0];
 443     }
 444 }
 445
 446 =head2 $self->prepare_write($c)
 447
 448 =cut
 449
 450 sub prepare_write { }
 451
 452 =head2 $self->read($c, [$maxlength])
 453
 454 =cut
 455
 456 sub read {
 457     my ( $self, $c, $maxlength ) = @_;
 458
 459     unless ( $self->{_prepared_read} ) {
 460         $self->prepare_read($c);
 461         $self->{_prepared_read} = 1;
 462     }
 463
 464     my $remaining = $self->read_length - $self->read_position;
 465     $maxlength ||= $CHUNKSIZE;
 466
 467     # Are we done reading?
 468     if ( $remaining <= 0 ) {
 469         $self->finalize_read($c);
 470         return;
 471     }
 472
 473     my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
 474     my $rc = $self->read_chunk( $c, my $buffer, $readlen );
 475     if ( defined $rc ) {
 476         $self->read_position( $self->read_position + $rc );
 477         return $buffer;
 478     }
 479     else {
 480         Catalyst::Exception->throw(
 481             message => "Unknown error reading input: $!" );
 482     }
 483 }
 484
 485 =head2 $self->read_chunk($c, $buffer, $length)
 486
 487 Each engine inplements read_chunk as its preferred way of reading a chunk
 488 of data.
 489
 490 =cut
 491
 492 sub read_chunk { }
 493
 494 =head2 $self->read_length
 495
 496 The length of input data to be read.  This is obtained from the Content-Length
 497 header.
 498
 499 =head2 $self->read_position
 500
 501 The amount of input data that has already been read.
 502
 503 =head2 $self->run($c)
 504
 505 =cut
 506
 507 sub run { }
 508
 509 =head2 $self->write($c, $buffer)
 510
 511 =cut
 512
 513 sub write {
 514     my ( $self, $c, $buffer ) = @_;
 515
 516     unless ( $self->{_prepared_write} ) {
 517         $self->prepare_write($c);
 518         $self->{_prepared_write} = 1;
 519     }
 520
 521     print STDOUT $buffer;
 522 }
 523
 524 =head1 AUTHORS
 525
 526 Sebastian Riedel, <sri@cpan.org>
 527
 528 Andy Grundman, <andy@hybridized.org>
 529
 530 =head1 COPYRIGHT
 531
 532 This program is free software, you can redistribute it and/or modify it under
 533 the same terms as Perl itself.
 534
 535 =cut
 536
 537 1;