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::Dump qw/dump/;
   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
  34 =head2 $self->finalize_body($c)
  35
  36 Finalize body.  Prints the response output.
  37
  38 =cut
  39
  40 sub finalize_body {
  41     my ( $self, $c ) = @_;
  42     my $body = $c->response->body;
  43     if ( ref $body && ( $body->can('read') || ref($body) eq 'GLOB' ) ) {
  44         while ( !eof $body ) {
  45             read $body, my ($buffer), $CHUNKSIZE;
  46             last unless $self->write( $c, $buffer );
  47         }
  48         close $body;
  49     }
  50     else {
  51         $self->write( $c, $body );
  52     }
  53 }
  54
  55 =head2 $self->finalize_cookies($c)
  56
  57 Create CGI::Cookies from $c->res->cookies, and set them as response headers.
  58
  59 =cut
  60
  61 sub finalize_cookies {
  62     my ( $self, $c ) = @_;
  63
  64     my @cookies;
  65
  66     foreach my $name ( keys %{ $c->response->cookies } ) {
  67
  68         my $val = $c->response->cookies->{$name};
  69
  70         my $cookie = CGI::Cookie->new(
  71             -name    => $name,
  72             -value   => $val->{value},
  73             -expires => $val->{expires},
  74             -domain  => $val->{domain},
  75             -path    => $val->{path},
  76             -secure  => $val->{secure} || 0
  77         );
  78
  79         push @cookies, $cookie->as_string;
  80     }
  81
  82     for my $cookie (@cookies) {
  83         $c->res->headers->push_header( 'Set-Cookie' => $cookie );
  84     }
  85 }
  86
  87 =head2 $self->finalize_error($c)
  88
  89 Output an apropriate error message, called if there's an error in $c
  90 after the dispatch has finished. Will output debug messages if Catalyst
  91 is in debug mode, or a `please come back later` message otherwise.
  92
  93 =cut
  94
  95 sub finalize_error {
  96     my ( $self, $c ) = @_;
  97
  98     $c->res->content_type('text/html; charset=utf-8');
  99     my $name = $c->config->{name} || join(' ', split('::', ref $c));
 100
 101     my ( $title, $error, $infos );
 102     if ( $c->debug ) {
 103
 104         # For pretty dumps
 105         $error = join '', map {
 106                 '<p><code class="error">'
 107               . encode_entities($_)
 108               . '</code></p>'
 109         } @{ $c->error };
 110         $error ||= 'No output';
 111         $error = qq{<pre wrap="">$error</pre>};
 112         $title = $name = "$name on Catalyst $Catalyst::VERSION";
 113         $name  = "<h1>$name</h1>";
 114
 115         # Don't show context in the dump
 116         delete $c->req->{_context};
 117         delete $c->res->{_context};
 118
 119         # Don't show body parser in the dump
 120         delete $c->req->{_body};
 121
 122         # Don't show response header state in dump
 123         delete $c->res->{_finalized_headers};
 124
 125         my @infos;
 126         my $i = 0;
 127         for my $dump ( $c->dump_these ) {
 128             my $name  = $dump->[0];
 129             my $value = encode_entities( dump( $dump->[1] ));
 130             push @infos, sprintf <<"EOF", $name, $value;
 131 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
 132 <div id="dump_$i">
 133     <pre wrap="">%s</pre>
 134 </div>
 135 EOF
 136             $i++;
 137         }
 138         $infos = join "\n", @infos;
 139     }
 140     else {
 141         $title = $name;
 142         $error = '';
 143         $infos = <<"";
 144 <pre>
 145 (en) Please come back later
 146 (fr) SVP veuillez revenir plus tard
 147 (de) Bitte versuchen sie es spaeter nocheinmal
 148 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
 149 (no) Vennligst prov igjen senere
 150 (dk) Venligst prov igen senere
 151 (pl) Prosze sprobowac pozniej
 152 </pre>
 153
 154         $name = '';
 155     }
 156     $c->res->body( <<"" );
 157 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 158     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 159 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
 160 <head>
 161     <meta http-equiv="Content-Language" content="en" />
 162     <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
 163     <title>$title</title>
 164     <script type="text/javascript">
 165         <!--
 166         function toggleDump (dumpElement) {
 167             var e = document.getElementById( dumpElement );
 168             if (e.style.display == "none") {
 169                 e.style.display = "";
 170             }
 171             else {
 172                 e.style.display = "none";
 173             }
 174         }
 175         -->
 176     </script>
 177     <style type="text/css">
 178         body {
 179             font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
 180                          Tahoma, Arial, helvetica, sans-serif;
 181             color: #333;
 182             background-color: #eee;
 183             margin: 0px;
 184             padding: 0px;
 185         }
 186         :link, :link:hover, :visited, :visited:hover {
 187             color: #000;
 188         }
 189         div.box {
 190             position: relative;
 191             background-color: #ccc;
 192             border: 1px solid #aaa;
 193             padding: 4px;
 194             margin: 10px;
 195         }
 196         div.error {
 197             background-color: #cce;
 198             border: 1px solid #755;
 199             padding: 8px;
 200             margin: 4px;
 201             margin-bottom: 10px;
 202         }
 203         div.infos {
 204             background-color: #eee;
 205             border: 1px solid #575;
 206             padding: 8px;
 207             margin: 4px;
 208             margin-bottom: 10px;
 209         }
 210         div.name {
 211             background-color: #cce;
 212             border: 1px solid #557;
 213             padding: 8px;
 214             margin: 4px;
 215         }
 216         code.error {
 217             display: block;
 218             margin: 1em 0;
 219             overflow: auto;
 220         }
 221         div.name h1, div.error p {
 222             margin: 0;
 223         }
 224         h2 {
 225             margin-top: 0;
 226             margin-bottom: 10px;
 227             font-size: medium;
 228             font-weight: bold;
 229             text-decoration: underline;
 230         }
 231         h1 {
 232             font-size: medium;
 233             font-weight: normal;
 234         }
 235         /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
 236         /* Browser specific (not valid) styles to make preformatted text wrap */
 237         pre {
 238             white-space: pre-wrap;       /* css-3 */
 239             white-space: -moz-pre-wrap;  /* Mozilla, since 1999 */
 240             white-space: -pre-wrap;      /* Opera 4-6 */
 241             white-space: -o-pre-wrap;    /* Opera 7 */
 242             word-wrap: break-word;       /* Internet Explorer 5.5+ */
 243         }
 244     </style>
 245 </head>
 246 <body>
 247     <div class="box">
 248         <div class="error">$error</div>
 249         <div class="infos">$infos</div>
 250         <div class="name">$name</div>
 251     </div>
 252 </body>
 253 </html>
 254
 255
 256     # Trick IE
 257     $c->res->{body} .= ( ' ' x 512 );
 258
 259     # Return 500
 260     $c->res->status(500);
 261 }
 262
 263 =head2 $self->finalize_headers($c)
 264
 265 Abstract method, allows engines to write headers to response
 266
 267 =cut
 268
 269 sub finalize_headers { }
 270
 271 =head2 $self->finalize_read($c)
 272
 273 =cut
 274
 275 sub finalize_read {
 276     my ( $self, $c ) = @_;
 277
 278     undef $self->{_prepared_read};
 279 }
 280
 281 =head2 $self->finalize_uploads($c)
 282
 283 Clean up after uploads, deleting temp files.
 284
 285 =cut
 286
 287 sub finalize_uploads {
 288     my ( $self, $c ) = @_;
 289
 290     if ( keys %{ $c->request->uploads } ) {
 291         for my $key ( keys %{ $c->request->uploads } ) {
 292             my $upload = $c->request->uploads->{$key};
 293             unlink map { $_->tempname }
 294               grep     { -e $_->tempname }
 295               ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
 296         }
 297     }
 298 }
 299
 300 =head2 $self->prepare_body($c)
 301
 302 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
 303
 304 =cut
 305
 306 sub prepare_body {
 307     my ( $self, $c ) = @_;
 308
 309     $self->read_length( $c->request->header('Content-Length') || 0 );
 310     my $type = $c->request->header('Content-Type');
 311
 312     unless ( $c->request->{_body} ) {
 313         $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
 314         $c->request->{_body}->{tmpdir} = $c->config->{uploadtmp}
 315           if exists $c->config->{uploadtmp};
 316     }
 317
 318     if ( $self->read_length > 0 ) {
 319         while ( my $buffer = $self->read($c) ) {
 320             $c->prepare_body_chunk($buffer);
 321         }
 322
 323         # paranoia against wrong Content-Length header
 324         my $remaining = $self->read_length - $self->read_position;
 325         if ( $remaining > 0 ) {
 326             $self->finalize_read($c);
 327             Catalyst::Exception->throw(
 328                 "Wrong Content-Length value: " . $self->read_length );
 329         }
 330     }
 331 }
 332
 333 =head2 $self->prepare_body_chunk($c)
 334
 335 Add a chunk to the request body.
 336
 337 =cut
 338
 339 sub prepare_body_chunk {
 340     my ( $self, $c, $chunk ) = @_;
 341
 342     $c->request->{_body}->add($chunk);
 343 }
 344
 345 =head2 $self->prepare_body_parameters($c)
 346
 347 Sets up parameters from body.
 348
 349 =cut
 350
 351 sub prepare_body_parameters {
 352     my ( $self, $c ) = @_;
 353     $c->request->body_parameters( $c->request->{_body}->param );
 354 }
 355
 356 =head2 $self->prepare_connection($c)
 357
 358 Abstract method implemented in engines.
 359
 360 =cut
 361
 362 sub prepare_connection { }
 363
 364 =head2 $self->prepare_cookies($c)
 365
 366 Parse cookies from header. Sets a L<CGI::Cookie> object.
 367
 368 =cut
 369
 370 sub prepare_cookies {
 371     my ( $self, $c ) = @_;
 372
 373     if ( my $header = $c->request->header('Cookie') ) {
 374         $c->req->cookies( { CGI::Cookie->parse($header) } );
 375     }
 376 }
 377
 378 =head2 $self->prepare_headers($c)
 379
 380 =cut
 381
 382 sub prepare_headers { }
 383
 384 =head2 $self->prepare_parameters($c)
 385
 386 sets up parameters from query and post parameters.
 387
 388 =cut
 389
 390 sub prepare_parameters {
 391     my ( $self, $c ) = @_;
 392
 393     # We copy, no references
 394     foreach my $name ( keys %{ $c->request->query_parameters } ) {
 395         my $param = $c->request->query_parameters->{$name};
 396         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 397         $c->request->parameters->{$name} = $param;
 398     }
 399
 400     # Merge query and body parameters
 401     foreach my $name ( keys %{ $c->request->body_parameters } ) {
 402         my $param = $c->request->body_parameters->{$name};
 403         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 404         if ( my $old_param = $c->request->parameters->{$name} ) {
 405             if ( ref $old_param eq 'ARRAY' ) {
 406                 push @{ $c->request->parameters->{$name} },
 407                   ref $param eq 'ARRAY' ? @$param : $param;
 408             }
 409             else { $c->request->parameters->{$name} = [ $old_param, $param ] }
 410         }
 411         else { $c->request->parameters->{$name} = $param }
 412     }
 413 }
 414
 415 =head2 $self->prepare_path($c)
 416
 417 abstract method, implemented by engines.
 418
 419 =cut
 420
 421 sub prepare_path { }
 422
 423 =head2 $self->prepare_request($c)
 424
 425 =head2 $self->prepare_query_parameters($c)
 426
 427 process the query string and extract query parameters.
 428
 429 =cut
 430
 431 sub prepare_query_parameters {
 432     my ( $self, $c, $query_string ) = @_;
 433
 434     # replace semi-colons
 435     $query_string =~ s/;/&/g;
 436
 437     my $u = URI->new( '', 'http' );
 438     $u->query($query_string);
 439     for my $key ( $u->query_param ) {
 440         my @vals = $u->query_param($key);
 441         $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
 442     }
 443 }
 444
 445 =head2 $self->prepare_read($c)
 446
 447 prepare to read from the engine.
 448
 449 =cut
 450
 451 sub prepare_read {
 452     my ( $self, $c ) = @_;
 453
 454     # Reset the read position
 455     $self->read_position(0);
 456 }
 457
 458 =head2 $self->prepare_request(@arguments)
 459
 460 Populate the context object from the request object.
 461
 462 =cut
 463
 464 sub prepare_request { }
 465
 466 =head2 $self->prepare_uploads($c)
 467
 468 =cut
 469
 470 sub prepare_uploads {
 471     my ( $self, $c ) = @_;
 472     my $uploads = $c->request->{_body}->upload;
 473     for my $name ( keys %$uploads ) {
 474         my $files = $uploads->{$name};
 475         $files = ref $files eq 'ARRAY' ? $files : [$files];
 476         my @uploads;
 477         for my $upload (@$files) {
 478             my $u = Catalyst::Request::Upload->new;
 479             $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
 480             $u->type( $u->headers->content_type );
 481             $u->tempname( $upload->{tempname} );
 482             $u->size( $upload->{size} );
 483             $u->filename( $upload->{filename} );
 484             push @uploads, $u;
 485         }
 486         $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
 487
 488         # support access to the filename as a normal param
 489         my @filenames = map { $_->{filename} } @uploads;
 490         $c->request->parameters->{$name} =
 491           @filenames > 1 ? \@filenames : $filenames[0];
 492     }
 493 }
 494
 495 =head2 $self->prepare_write($c)
 496
 497 Abstract method. Implemented by the engines.
 498
 499 =cut
 500
 501 sub prepare_write { }
 502
 503 =head2 $self->read($c, [$maxlength])
 504
 505 =cut
 506
 507 sub read {
 508     my ( $self, $c, $maxlength ) = @_;
 509
 510     unless ( $self->{_prepared_read} ) {
 511         $self->prepare_read($c);
 512         $self->{_prepared_read} = 1;
 513     }
 514
 515     my $remaining = $self->read_length - $self->read_position;
 516     $maxlength ||= $CHUNKSIZE;
 517
 518     # Are we done reading?
 519     if ( $remaining <= 0 ) {
 520         $self->finalize_read($c);
 521         return;
 522     }
 523
 524     my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
 525     my $rc = $self->read_chunk( $c, my $buffer, $readlen );
 526     if ( defined $rc ) {
 527         $self->read_position( $self->read_position + $rc );
 528         return $buffer;
 529     }
 530     else {
 531         Catalyst::Exception->throw(
 532             message => "Unknown error reading input: $!" );
 533     }
 534 }
 535
 536 =head2 $self->read_chunk($c, $buffer, $length)
 537
 538 Each engine inplements read_chunk as its preferred way of reading a chunk
 539 of data.
 540
 541 =cut
 542
 543 sub read_chunk { }
 544
 545 =head2 $self->read_length
 546
 547 The length of input data to be read.  This is obtained from the Content-Length
 548 header.
 549
 550 =head2 $self->read_position
 551
 552 The amount of input data that has already been read.
 553
 554 =head2 $self->run($c)
 555
 556 Start the engine. Implemented by the various engine classes.
 557
 558 =cut
 559
 560 sub run { }
 561
 562 =head2 $self->write($c, $buffer)
 563
 564 Writes the buffer to the client. Can only be called once for a request.
 565
 566 =cut
 567
 568 sub write {
 569     my ( $self, $c, $buffer ) = @_;
 570
 571     unless ( $self->{_prepared_write} ) {
 572         $self->prepare_write($c);
 573         $self->{_prepared_write} = 1;
 574     }
 575
 576     print STDOUT $buffer;
 577 }
 578
 579
 580 =head2 $self->finalize_output
 581
 582 <obsolete>, see finalize_body
 583
 584 =head1 AUTHORS
 585
 586 Sebastian Riedel, <sri@cpan.org>
 587
 588 Andy Grundman, <andy@hybridized.org>
 589
 590 =head1 COPYRIGHT
 591
 592 This program is free software, you can redistribute it and/or modify it under
 593 the same terms as Perl itself.
 594
 595 =cut
 596
 597 1;