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