lib/Catalyst/Engine.pm

   1 package Catalyst::Engine;
   2
   3 use Moose;
   4 with 'MooseX::Emulate::Class::Accessor::Fast';
   5
   6 use CGI::Simple::Cookie;
   7 use Data::Dump qw/dump/;
   8 use Errno 'EWOULDBLOCK';
   9 use HTML::Entities;
  10 use HTTP::Body;
  11 use HTTP::Headers;
  12 use URI::QueryParam;
  13 use Scalar::Util ();
  14
  15 # input position and length
  16 has read_length => (is => 'rw');
  17 has read_position => (is => 'rw');
  18
  19 # Stringify to class
  20 use overload '""' => sub { return ref shift }, fallback => 1;
  21
  22 # Amount of data to read from input on each pass
  23 our $CHUNKSIZE = 64 * 1024;
  24
  25 =head1 NAME
  26
  27 Catalyst::Engine - The Catalyst Engine
  28
  29 =head1 SYNOPSIS
  30
  31 See L<Catalyst>.
  32
  33 =head1 DESCRIPTION
  34
  35 =head1 METHODS
  36
  37
  38 =head2 $self->finalize_body($c)
  39
  40 Finalize body.  Prints the response output.
  41
  42 =cut
  43
  44 sub finalize_body {
  45     my ( $self, $c ) = @_;
  46     my $body = $c->response->body;
  47     no warnings 'uninitialized';
  48     if ( Scalar::Util::blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
  49         while ( !eof $body ) {
  50             read $body, my ($buffer), $CHUNKSIZE;
  51             last unless $self->write( $c, $buffer );
  52         }
  53         close $body;
  54     }
  55     else {
  56         $self->write( $c, $body );
  57     }
  58 }
  59
  60 =head2 $self->finalize_cookies($c)
  61
  62 Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
  63 response headers.
  64
  65 =cut
  66
  67 sub finalize_cookies {
  68     my ( $self, $c ) = @_;
  69
  70     my @cookies;
  71     my $response = $c->response;
  72
  73     foreach my $name (keys %{ $response->cookies }) {
  74
  75         my $val = $response->cookies->{$name};
  76
  77         my $cookie = (
  78             Scalar::Util::blessed($val)
  79             ? $val
  80             : CGI::Simple::Cookie->new(
  81                 -name    => $name,
  82                 -value   => $val->{value},
  83                 -expires => $val->{expires},
  84                 -domain  => $val->{domain},
  85                 -path    => $val->{path},
  86                 -secure  => $val->{secure} || 0
  87             )
  88         );
  89
  90         push @cookies, $cookie->as_string;
  91     }
  92
  93     for my $cookie (@cookies) {
  94         $response->headers->push_header( 'Set-Cookie' => $cookie );
  95     }
  96 }
  97
  98 =head2 $self->finalize_error($c)
  99
 100 Output an apropriate error message, called if there's an error in $c
 101 after the dispatch has finished. Will output debug messages if Catalyst
 102 is in debug mode, or a `please come back later` message otherwise.
 103
 104 =cut
 105
 106 sub finalize_error {
 107     my ( $self, $c ) = @_;
 108
 109     $c->res->content_type('text/html; charset=utf-8');
 110     my $name = $c->config->{name} || join(' ', split('::', ref $c));
 111
 112     my ( $title, $error, $infos );
 113     if ( $c->debug ) {
 114
 115         # For pretty dumps
 116         $error = join '', map {
 117                 '<p><code class="error">'
 118               . encode_entities($_)
 119               . '</code></p>'
 120         } @{ $c->error };
 121         $error ||= 'No output';
 122         $error = qq{<pre wrap="">$error</pre>};
 123         $title = $name = "$name on Catalyst $Catalyst::VERSION";
 124         $name  = "<h1>$name</h1>";
 125
 126         # Don't show context in the dump
 127         delete $c->req->{_context};
 128         delete $c->res->{_context};
 129
 130         # Don't show body parser in the dump
 131         delete $c->req->{_body};
 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
 285 =head2 $self->finalize_uploads($c)
 286
 287 Clean up after uploads, deleting temp files.
 288
 289 =cut
 290
 291 sub finalize_uploads {
 292     my ( $self, $c ) = @_;
 293
 294     my $request = $c->request;
 295     foreach my $key (keys %{ $request->uploads }) {
 296         my $upload = $request->uploads->{$key};
 297         unlink grep { -e $_ } map { $_->tempname }
 298           (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
 299     }
 300
 301 }
 302
 303 =head2 $self->prepare_body($c)
 304
 305 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
 306
 307 =cut
 308
 309 sub prepare_body {
 310     my ( $self, $c ) = @_;
 311
 312     if ( my $length = $self->read_length ) {
 313         my $request = $c->request;
 314         unless ( $request->{_body} ) {
 315             my $type = $request->header('Content-Type');
 316             $request->{_body} = HTTP::Body->new( $type, $length );
 317             $request->{_body}->{tmpdir} = $c->config->{uploadtmp}
 318               if exists $c->config->{uploadtmp};
 319         }
 320
 321         while ( my $buffer = $self->read($c) ) {
 322             $c->prepare_body_chunk($buffer);
 323         }
 324
 325         # paranoia against wrong Content-Length header
 326         my $remaining = $length - $self->read_position;
 327         if ( $remaining > 0 ) {
 328             $self->finalize_read($c);
 329             Catalyst::Exception->throw(
 330                 "Wrong Content-Length value: $length" );
 331         }
 332     }
 333     else {
 334         # Defined but will cause all body code to be skipped
 335         $c->request->{_body} = 0;
 336     }
 337 }
 338
 339 =head2 $self->prepare_body_chunk($c)
 340
 341 Add a chunk to the request body.
 342
 343 =cut
 344
 345 sub prepare_body_chunk {
 346     my ( $self, $c, $chunk ) = @_;
 347
 348     $c->request->{_body}->add($chunk);
 349 }
 350
 351 =head2 $self->prepare_body_parameters($c)
 352
 353 Sets up parameters from body.
 354
 355 =cut
 356
 357 sub prepare_body_parameters {
 358     my ( $self, $c ) = @_;
 359
 360     return unless $c->request->{_body};
 361
 362     $c->request->body_parameters( $c->request->{_body}->param );
 363 }
 364
 365 =head2 $self->prepare_connection($c)
 366
 367 Abstract method implemented in engines.
 368
 369 =cut
 370
 371 sub prepare_connection { }
 372
 373 =head2 $self->prepare_cookies($c)
 374
 375 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
 376
 377 =cut
 378
 379 sub prepare_cookies {
 380     my ( $self, $c ) = @_;
 381
 382     if ( my $header = $c->request->header('Cookie') ) {
 383         $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
 384     }
 385 }
 386
 387 =head2 $self->prepare_headers($c)
 388
 389 =cut
 390
 391 sub prepare_headers { }
 392
 393 =head2 $self->prepare_parameters($c)
 394
 395 sets up parameters from query and post parameters.
 396
 397 =cut
 398
 399 sub prepare_parameters {
 400     my ( $self, $c ) = @_;
 401
 402     my $request = $c->request;
 403     my $parameters = $request->parameters;
 404     my $body_parameters = $request->body_parameters;
 405     my $query_parameters = $request->query_parameters;
 406     # We copy, no references
 407     foreach my $name (keys %$query_parameters) {
 408         my $param = $query_parameters->{$name};
 409         $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
 410     }
 411
 412     # Merge query and body parameters
 413     foreach my $name (keys %$body_parameters) {
 414         my $param = $body_parameters->{$name};
 415         my @values = ref $param eq 'ARRAY' ? @$param : ($param);
 416         if ( my $existing = $parameters->{$name} ) {
 417           unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
 418         }
 419         $parameters->{$name} = @values > 1 ? \@values : $values[0];
 420     }
 421 }
 422
 423 =head2 $self->prepare_path($c)
 424
 425 abstract method, implemented by engines.
 426
 427 =cut
 428
 429 sub prepare_path { }
 430
 431 =head2 $self->prepare_request($c)
 432
 433 =head2 $self->prepare_query_parameters($c)
 434
 435 process the query string and extract query parameters.
 436
 437 =cut
 438
 439 sub prepare_query_parameters {
 440     my ( $self, $c, $query_string ) = @_;
 441
 442     # Check for keywords (no = signs)
 443     # (yes, index() is faster than a regex :))
 444     if ( index( $query_string, '=' ) < 0 ) {
 445         $c->request->query_keywords( $self->unescape_uri($query_string) );
 446         return;
 447     }
 448
 449     my %query;
 450
 451     # replace semi-colons
 452     $query_string =~ s/;/&/g;
 453
 454     my @params = split /&/, $query_string;
 455
 456     for my $item ( @params ) {
 457
 458         my ($param, $value)
 459             = map { $self->unescape_uri($_) }
 460               split( /=/, $item, 2 );
 461
 462         $param = $self->unescape_uri($item) unless defined $param;
 463
 464         if ( exists $query{$param} ) {
 465             if ( ref $query{$param} ) {
 466                 push @{ $query{$param} }, $value;
 467             }
 468             else {
 469                 $query{$param} = [ $query{$param}, $value ];
 470             }
 471         }
 472         else {
 473             $query{$param} = $value;
 474         }
 475     }
 476
 477     $c->request->query_parameters( \%query );
 478 }
 479
 480 =head2 $self->prepare_read($c)
 481
 482 prepare to read from the engine.
 483
 484 =cut
 485
 486 sub prepare_read {
 487     my ( $self, $c ) = @_;
 488
 489     # Initialize the read position
 490     $self->read_position(0);
 491
 492     # Initialize the amount of data we think we need to read
 493     $self->read_length( $c->request->header('Content-Length') || 0 );
 494 }
 495
 496 =head2 $self->prepare_request(@arguments)
 497
 498 Populate the context object from the request object.
 499
 500 =cut
 501
 502 sub prepare_request { }
 503
 504 =head2 $self->prepare_uploads($c)
 505
 506 =cut
 507
 508 sub prepare_uploads {
 509     my ( $self, $c ) = @_;
 510
 511     my $request = $c->request;
 512     return unless $request->{_body};
 513
 514     my $uploads = $request->{_body}->upload;
 515     my $parameters = $request->parameters;
 516     foreach my $name (keys %$uploads) {
 517         my $files = $uploads->{$name};
 518         my @uploads;
 519         for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
 520             my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
 521             my $u = Catalyst::Request::Upload->new
 522               (
 523                size => $upload->{size},
 524                type => $headers->content_type,
 525                headers => $headers,
 526                tempname => $upload->{tempname},
 527                filename => $upload->{filename},
 528               );
 529             push @uploads, $u;
 530         }
 531         $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 $parameters->{$name}) {
 537             if (ref $parameters->{$name} eq 'ARRAY') {
 538                 push @{ $parameters->{$name} }, @filenames;
 539             }
 540             else {
 541                 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
 542             }
 543         }
 544         else {
 545             $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
 546         }
 547     }
 548 }
 549
 550 =head2 $self->prepare_write($c)
 551
 552 Abstract method. Implemented by the engines.
 553
 554 =cut
 555
 556 sub prepare_write { }
 557
 558 =head2 $self->read($c, [$maxlength])
 559
 560 =cut
 561
 562 sub read {
 563     my ( $self, $c, $maxlength ) = @_;
 564
 565     my $remaining = $self->read_length - $self->read_position;
 566     $maxlength ||= $CHUNKSIZE;
 567
 568     # Are we done reading?
 569     if ( $remaining <= 0 ) {
 570         $self->finalize_read($c);
 571         return;
 572     }
 573
 574     my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
 575     my $rc = $self->read_chunk( $c, my $buffer, $readlen );
 576     if ( defined $rc ) {
 577         $self->read_position( $self->read_position + $rc );
 578         return $buffer;
 579     }
 580     else {
 581         Catalyst::Exception->throw(
 582             message => "Unknown error reading input: $!" );
 583     }
 584 }
 585
 586 =head2 $self->read_chunk($c, $buffer, $length)
 587
 588 Each engine inplements read_chunk as its preferred way of reading a chunk
 589 of data.
 590
 591 =cut
 592
 593 sub read_chunk { }
 594
 595 =head2 $self->read_length
 596
 597 The length of input data to be read.  This is obtained from the Content-Length
 598 header.
 599
 600 =head2 $self->read_position
 601
 602 The amount of input data that has already been read.
 603
 604 =head2 $self->run($c)
 605
 606 Start the engine. Implemented by the various engine classes.
 607
 608 =cut
 609
 610 sub run { }
 611
 612 =head2 $self->write($c, $buffer)
 613
 614 Writes the buffer to the client.
 615
 616 =cut
 617
 618 sub write {
 619     my ( $self, $c, $buffer ) = @_;
 620
 621     unless ( $self->{_prepared_write} ) {
 622         $self->prepare_write($c);
 623         $self->{_prepared_write} = 1;
 624     }
 625
 626     my $len   = length($buffer);
 627     my $wrote = syswrite STDOUT, $buffer;
 628
 629     if ( !defined $wrote && $! == EWOULDBLOCK ) {
 630         # Unable to write on the first try, will retry in the loop below
 631         $wrote = 0;
 632     }
 633
 634     if ( defined $wrote && $wrote < $len ) {
 635         # We didn't write the whole buffer
 636         while (1) {
 637             my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
 638             if ( defined $ret ) {
 639                 $wrote += $ret;
 640             }
 641             else {
 642                 next if $! == EWOULDBLOCK;
 643                 return;
 644             }
 645
 646             last if $wrote >= $len;
 647         }
 648     }
 649
 650     return $wrote;
 651 }
 652
 653 =head2 $self->unescape_uri($uri)
 654
 655 Unescapes a given URI using the most efficient method available.  Engines such
 656 as Apache may implement this using Apache's C-based modules, for example.
 657
 658 =cut
 659
 660 sub unescape_uri {
 661     my ( $self, $str ) = @_;
 662
 663     $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
 664
 665     return $str;
 666 }
 667
 668 =head2 $self->finalize_output
 669
 670 <obsolete>, see finalize_body
 671
 672 =head1 AUTHORS
 673
 674 Sebastian Riedel, <sri@cpan.org>
 675
 676 Andy Grundman, <andy@hybridized.org>
 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;