lib/Catalyst/Engine.pm

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