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 Errno 'EWOULDBLOCK';
   8 use HTML::Entities;
   9 use HTTP::Body;
  10 use HTTP::Headers;
  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 (pt) Por favor volte mais tarde
 161 (ru) Попробуйте еще раз позже
 162 (ua) Спробуйте ще раз пізніше
 163 </pre>
 164
 165         $name = '';
 166     }
 167     $c->res->body( <<"" );
 168 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 169     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 170 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
 171 <head>
 172     <meta http-equiv="Content-Language" content="en" />
 173     <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
 174     <title>$title</title>
 175     <script type="text/javascript">
 176         <!--
 177         function toggleDump (dumpElement) {
 178             var e = document.getElementById( dumpElement );
 179             if (e.style.display == "none") {
 180                 e.style.display = "";
 181             }
 182             else {
 183                 e.style.display = "none";
 184             }
 185         }
 186         -->
 187     </script>
 188     <style type="text/css">
 189         body {
 190             font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
 191                          Tahoma, Arial, helvetica, sans-serif;
 192             color: #333;
 193             background-color: #eee;
 194             margin: 0px;
 195             padding: 0px;
 196         }
 197         :link, :link:hover, :visited, :visited:hover {
 198             color: #000;
 199         }
 200         div.box {
 201             position: relative;
 202             background-color: #ccc;
 203             border: 1px solid #aaa;
 204             padding: 4px;
 205             margin: 10px;
 206         }
 207         div.error {
 208             background-color: #cce;
 209             border: 1px solid #755;
 210             padding: 8px;
 211             margin: 4px;
 212             margin-bottom: 10px;
 213         }
 214         div.infos {
 215             background-color: #eee;
 216             border: 1px solid #575;
 217             padding: 8px;
 218             margin: 4px;
 219             margin-bottom: 10px;
 220         }
 221         div.name {
 222             background-color: #cce;
 223             border: 1px solid #557;
 224             padding: 8px;
 225             margin: 4px;
 226         }
 227         code.error {
 228             display: block;
 229             margin: 1em 0;
 230             overflow: auto;
 231         }
 232         div.name h1, div.error p {
 233             margin: 0;
 234         }
 235         h2 {
 236             margin-top: 0;
 237             margin-bottom: 10px;
 238             font-size: medium;
 239             font-weight: bold;
 240             text-decoration: underline;
 241         }
 242         h1 {
 243             font-size: medium;
 244             font-weight: normal;
 245         }
 246         /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
 247         /* Browser specific (not valid) styles to make preformatted text wrap */
 248         pre {
 249             white-space: pre-wrap;       /* css-3 */
 250             white-space: -moz-pre-wrap;  /* Mozilla, since 1999 */
 251             white-space: -pre-wrap;      /* Opera 4-6 */
 252             white-space: -o-pre-wrap;    /* Opera 7 */
 253             word-wrap: break-word;       /* Internet Explorer 5.5+ */
 254         }
 255     </style>
 256 </head>
 257 <body>
 258     <div class="box">
 259         <div class="error">$error</div>
 260         <div class="infos">$infos</div>
 261         <div class="name">$name</div>
 262     </div>
 263 </body>
 264 </html>
 265
 266
 267     # Trick IE
 268     $c->res->{body} .= ( ' ' x 512 );
 269
 270     # Return 500
 271     $c->res->status(500);
 272 }
 273
 274 =head2 $self->finalize_headers($c)
 275
 276 Abstract method, allows engines to write headers to response
 277
 278 =cut
 279
 280 sub finalize_headers { }
 281
 282 =head2 $self->finalize_read($c)
 283
 284 =cut
 285
 286 sub finalize_read { }
 287
 288 =head2 $self->finalize_uploads($c)
 289
 290 Clean up after uploads, deleting temp files.
 291
 292 =cut
 293
 294 sub finalize_uploads {
 295     my ( $self, $c ) = @_;
 296
 297     if ( keys %{ $c->request->uploads } ) {
 298         for my $key ( keys %{ $c->request->uploads } ) {
 299             my $upload = $c->request->uploads->{$key};
 300             unlink map { $_->tempname }
 301               grep     { -e $_->tempname }
 302               ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
 303         }
 304     }
 305 }
 306
 307 =head2 $self->prepare_body($c)
 308
 309 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
 310
 311 =cut
 312
 313 sub prepare_body {
 314     my ( $self, $c ) = @_;
 315
 316     if ( my $length = $self->read_length ) {
 317         unless ( $c->request->{_body} ) {
 318             my $type = $c->request->header('Content-Type');
 319             $c->request->{_body} = HTTP::Body->new( $type, $length );
 320             $c->request->{_body}->tmpdir( $c->config->{uploadtmp} )
 321               if exists $c->config->{uploadtmp};
 322         }
 323
 324         while ( my $buffer = $self->read($c) ) {
 325             $c->prepare_body_chunk($buffer);
 326         }
 327
 328         # paranoia against wrong Content-Length header
 329         my $remaining = $length - $self->read_position;
 330         if ( $remaining > 0 ) {
 331             $self->finalize_read($c);
 332             Catalyst::Exception->throw(
 333                 "Wrong Content-Length value: $length" );
 334         }
 335     }
 336     else {
 337         # Defined but will cause all body code to be skipped
 338         $c->request->{_body} = 0;
 339     }
 340 }
 341
 342 =head2 $self->prepare_body_chunk($c)
 343
 344 Add a chunk to the request body.
 345
 346 =cut
 347
 348 sub prepare_body_chunk {
 349     my ( $self, $c, $chunk ) = @_;
 350
 351     $c->request->{_body}->add($chunk);
 352 }
 353
 354 =head2 $self->prepare_body_parameters($c)
 355
 356 Sets up parameters from body.
 357
 358 =cut
 359
 360 sub prepare_body_parameters {
 361     my ( $self, $c ) = @_;
 362
 363     return unless $c->request->{_body};
 364
 365     $c->request->body_parameters( $c->request->{_body}->param );
 366 }
 367
 368 =head2 $self->prepare_connection($c)
 369
 370 Abstract method implemented in engines.
 371
 372 =cut
 373
 374 sub prepare_connection { }
 375
 376 =head2 $self->prepare_cookies($c)
 377
 378 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
 379
 380 =cut
 381
 382 sub prepare_cookies {
 383     my ( $self, $c ) = @_;
 384
 385     if ( my $header = $c->request->header('Cookie') ) {
 386         $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
 387     }
 388 }
 389
 390 =head2 $self->prepare_headers($c)
 391
 392 =cut
 393
 394 sub prepare_headers { }
 395
 396 =head2 $self->prepare_parameters($c)
 397
 398 sets up parameters from query and post parameters.
 399
 400 =cut
 401
 402 sub prepare_parameters {
 403     my ( $self, $c ) = @_;
 404
 405     # We copy, no references
 406     foreach my $name ( keys %{ $c->request->query_parameters } ) {
 407         my $param = $c->request->query_parameters->{$name};
 408         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 409         $c->request->parameters->{$name} = $param;
 410     }
 411
 412     # Merge query and body parameters
 413     foreach my $name ( keys %{ $c->request->body_parameters } ) {
 414         my $param = $c->request->body_parameters->{$name};
 415         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 416         if ( my $old_param = $c->request->parameters->{$name} ) {
 417             if ( ref $old_param eq 'ARRAY' ) {
 418                 push @{ $c->request->parameters->{$name} },
 419                   ref $param eq 'ARRAY' ? @$param : $param;
 420             }
 421             else { $c->request->parameters->{$name} = [ $old_param, $param ] }
 422         }
 423         else { $c->request->parameters->{$name} = $param }
 424     }
 425 }
 426
 427 =head2 $self->prepare_path($c)
 428
 429 abstract method, implemented by engines.
 430
 431 =cut
 432
 433 sub prepare_path { }
 434
 435 =head2 $self->prepare_request($c)
 436
 437 =head2 $self->prepare_query_parameters($c)
 438
 439 process the query string and extract query parameters.
 440
 441 =cut
 442
 443 sub prepare_query_parameters {
 444     my ( $self, $c, $query_string ) = @_;
 445
 446     # Check for keywords (no = signs)
 447     # (yes, index() is faster than a regex :))
 448     if ( index( $query_string, '=' ) < 0 ) {
 449         $c->request->query_keywords( $self->unescape_uri($query_string) );
 450         return;
 451     }
 452
 453     my %query;
 454
 455     # replace semi-colons
 456     $query_string =~ s/;/&/g;
 457
 458     my @params = grep { length $_ } split /&/, $query_string;
 459
 460     for my $item ( @params ) {
 461
 462         my ($param, $value)
 463             = map { $self->unescape_uri($_) }
 464               split( /=/, $item, 2 );
 465
 466         $param = $self->unescape_uri($item) unless defined $param;
 467
 468         if ( exists $query{$param} ) {
 469             if ( ref $query{$param} ) {
 470                 push @{ $query{$param} }, $value;
 471             }
 472             else {
 473                 $query{$param} = [ $query{$param}, $value ];
 474             }
 475         }
 476         else {
 477             $query{$param} = $value;
 478         }
 479     }
 480
 481     $c->request->query_parameters( \%query );
 482 }
 483
 484 =head2 $self->prepare_read($c)
 485
 486 prepare to read from the engine.
 487
 488 =cut
 489
 490 sub prepare_read {
 491     my ( $self, $c ) = @_;
 492
 493     # Initialize the read position
 494     $self->read_position(0);
 495
 496     # Initialize the amount of data we think we need to read
 497     $self->read_length( $c->request->header('Content-Length') || 0 );
 498 }
 499
 500 =head2 $self->prepare_request(@arguments)
 501
 502 Populate the context object from the request object.
 503
 504 =cut
 505
 506 sub prepare_request { }
 507
 508 =head2 $self->prepare_uploads($c)
 509
 510 =cut
 511
 512 sub prepare_uploads {
 513     my ( $self, $c ) = @_;
 514
 515     return unless $c->request->{_body};
 516
 517     my $uploads = $c->request->{_body}->upload;
 518     for my $name ( keys %$uploads ) {
 519         my $files = $uploads->{$name};
 520         $files = ref $files eq 'ARRAY' ? $files : [$files];
 521         my @uploads;
 522         for my $upload (@$files) {
 523             my $u = Catalyst::Request::Upload->new;
 524             $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
 525             $u->type( $u->headers->content_type );
 526             $u->tempname( $upload->{tempname} );
 527             $u->size( $upload->{size} );
 528             $u->filename( $upload->{filename} );
 529             push @uploads, $u;
 530         }
 531         $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
 532
 533         # support access to the filename as a normal param
 534         my @filenames = map { $_->{filename} } @uploads;
 535         # append, if there's already params with this name
 536         if (exists $c->request->parameters->{$name}) {
 537             if (ref $c->request->parameters->{$name} eq 'ARRAY') {
 538                 push @{ $c->request->parameters->{$name} }, @filenames;
 539             }
 540             else {
 541                 $c->request->parameters->{$name} =
 542                     [ $c->request->parameters->{$name}, @filenames ];
 543             }
 544         }
 545         else {
 546             $c->request->parameters->{$name} =
 547                 @filenames > 1 ? \@filenames : $filenames[0];
 548         }
 549     }
 550 }
 551
 552 =head2 $self->prepare_write($c)
 553
 554 Abstract method. Implemented by the engines.
 555
 556 =cut
 557
 558 sub prepare_write { }
 559
 560 =head2 $self->read($c, [$maxlength])
 561
 562 =cut
 563
 564 sub read {
 565     my ( $self, $c, $maxlength ) = @_;
 566
 567     my $remaining = $self->read_length - $self->read_position;
 568     $maxlength ||= $CHUNKSIZE;
 569
 570     # Are we done reading?
 571     if ( $remaining <= 0 ) {
 572         $self->finalize_read($c);
 573         return;
 574     }
 575
 576     my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
 577     my $rc = $self->read_chunk( $c, my $buffer, $readlen );
 578     if ( defined $rc ) {
 579         $self->read_position( $self->read_position + $rc );
 580         return $buffer;
 581     }
 582     else {
 583         Catalyst::Exception->throw(
 584             message => "Unknown error reading input: $!" );
 585     }
 586 }
 587
 588 =head2 $self->read_chunk($c, $buffer, $length)
 589
 590 Each engine inplements read_chunk as its preferred way of reading a chunk
 591 of data.
 592
 593 =cut
 594
 595 sub read_chunk { }
 596
 597 =head2 $self->read_length
 598
 599 The length of input data to be read.  This is obtained from the Content-Length
 600 header.
 601
 602 =head2 $self->read_position
 603
 604 The amount of input data that has already been read.
 605
 606 =head2 $self->run($c)
 607
 608 Start the engine. Implemented by the various engine classes.
 609
 610 =cut
 611
 612 sub run { }
 613
 614 =head2 $self->write($c, $buffer)
 615
 616 Writes the buffer to the client.
 617
 618 =cut
 619
 620 sub write {
 621     my ( $self, $c, $buffer ) = @_;
 622
 623     unless ( $self->{_prepared_write} ) {
 624         $self->prepare_write($c);
 625         $self->{_prepared_write} = 1;
 626     }
 627
 628     my $len   = length($buffer);
 629     my $wrote = syswrite STDOUT, $buffer;
 630
 631     if ( !defined $wrote && $! == EWOULDBLOCK ) {
 632         # Unable to write on the first try, will retry in the loop below
 633         $wrote = 0;
 634     }
 635
 636     if ( defined $wrote && $wrote < $len ) {
 637         # We didn't write the whole buffer
 638         while (1) {
 639             my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
 640             if ( defined $ret ) {
 641                 $wrote += $ret;
 642             }
 643             else {
 644                 next if $! == EWOULDBLOCK;
 645                 return;
 646             }
 647
 648             last if $wrote >= $len;
 649         }
 650     }
 651
 652     return $wrote;
 653 }
 654
 655 =head2 $self->unescape_uri($uri)
 656
 657 Unescapes a given URI using the most efficient method available.  Engines such
 658 as Apache may implement this using Apache's C-based modules, for example.
 659
 660 =cut
 661
 662 sub unescape_uri {
 663     my ( $self, $str ) = @_;
 664
 665     $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
 666
 667     return $str;
 668 }
 669
 670 =head2 $self->finalize_output
 671
 672 <obsolete>, see finalize_body
 673
 674 =head1 AUTHORS
 675
 676 Catalyst Contributors, see Catalyst.pm
 677
 678 =head1 COPYRIGHT
 679
 680 This program is free software, you can redistribute it and/or modify it under
 681 the same terms as Perl itself.
 682
 683 =cut
 684
 685 1;