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