lib/Catalyst/Engine.pm

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