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