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 </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     if ( keys %{ $c->request->uploads } ) {
 296         for my $key ( keys %{ $c->request->uploads } ) {
 297             my $upload = $c->request->uploads->{$key};
 298             unlink map { $_->tempname }
 299               grep     { -e $_->tempname }
 300               ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
 301         }
 302     }
 303 }
 304
 305 =head2 $self->prepare_body($c)
 306
 307 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
 308
 309 =cut
 310
 311 sub prepare_body {
 312     my ( $self, $c ) = @_;
 313
 314     if ( my $length = $self->read_length ) {
 315         unless ( $c->request->{_body} ) {
 316             my $type = $c->request->header('Content-Type');
 317             $c->request->{_body} = HTTP::Body->new( $type, $length );
 318             $c->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     # We copy, no references
 404     foreach my $name ( keys %{ $c->request->query_parameters } ) {
 405         my $param = $c->request->query_parameters->{$name};
 406         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 407         $c->request->parameters->{$name} = $param;
 408     }
 409
 410     # Merge query and body parameters
 411     foreach my $name ( keys %{ $c->request->body_parameters } ) {
 412         my $param = $c->request->body_parameters->{$name};
 413         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 414         if ( my $old_param = $c->request->parameters->{$name} ) {
 415             if ( ref $old_param eq 'ARRAY' ) {
 416                 push @{ $c->request->parameters->{$name} },
 417                   ref $param eq 'ARRAY' ? @$param : $param;
 418             }
 419             else { $c->request->parameters->{$name} = [ $old_param, $param ] }
 420         }
 421         else { $c->request->parameters->{$name} = $param }
 422     }
 423 }
 424
 425 =head2 $self->prepare_path($c)
 426
 427 abstract method, implemented by engines.
 428
 429 =cut
 430
 431 sub prepare_path { }
 432
 433 =head2 $self->prepare_request($c)
 434
 435 =head2 $self->prepare_query_parameters($c)
 436
 437 process the query string and extract query parameters.
 438
 439 =cut
 440
 441 sub prepare_query_parameters {
 442     my ( $self, $c, $query_string ) = @_;
 443
 444     # Check for keywords (no = signs)
 445     # (yes, index() is faster than a regex :))
 446     if ( index( $query_string, '=' ) < 0 ) {
 447         $c->request->query_keywords( $self->unescape_uri($query_string) );
 448         return;
 449     }
 450
 451     my %query;
 452
 453     # replace semi-colons
 454     $query_string =~ s/;/&/g;
 455
 456     my @params = grep { length $_ } split /&/, $query_string;
 457
 458     for my $item ( @params ) {
 459
 460         my ($param, $value)
 461             = map { $self->unescape_uri($_) }
 462               split( /=/, $item, 2 );
 463
 464         $param = $self->unescape_uri($item) unless defined $param;
 465
 466         if ( exists $query{$param} ) {
 467             if ( ref $query{$param} ) {
 468                 push @{ $query{$param} }, $value;
 469             }
 470             else {
 471                 $query{$param} = [ $query{$param}, $value ];
 472             }
 473         }
 474         else {
 475             $query{$param} = $value;
 476         }
 477     }
 478
 479     $c->request->query_parameters( \%query );
 480 }
 481
 482 =head2 $self->prepare_read($c)
 483
 484 prepare to read from the engine.
 485
 486 =cut
 487
 488 sub prepare_read {
 489     my ( $self, $c ) = @_;
 490
 491     # Initialize the read position
 492     $self->read_position(0);
 493
 494     # Initialize the amount of data we think we need to read
 495     $self->read_length( $c->request->header('Content-Length') || 0 );
 496 }
 497
 498 =head2 $self->prepare_request(@arguments)
 499
 500 Populate the context object from the request object.
 501
 502 =cut
 503
 504 sub prepare_request { }
 505
 506 =head2 $self->prepare_uploads($c)
 507
 508 =cut
 509
 510 sub prepare_uploads {
 511     my ( $self, $c ) = @_;
 512
 513     return unless $c->request->{_body};
 514
 515     my $uploads = $c->request->{_body}->upload;
 516     for my $name ( keys %$uploads ) {
 517         my $files = $uploads->{$name};
 518         $files = ref $files eq 'ARRAY' ? $files : [$files];
 519         my @uploads;
 520         for my $upload (@$files) {
 521             my $u = Catalyst::Request::Upload->new;
 522             $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
 523             $u->type( $u->headers->content_type );
 524             $u->tempname( $upload->{tempname} );
 525             $u->size( $upload->{size} );
 526             $u->filename( $upload->{filename} );
 527             push @uploads, $u;
 528         }
 529         $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
 530
 531         # support access to the filename as a normal param
 532         my @filenames = map { $_->{filename} } @uploads;
 533         # append, if there's already params with this name
 534         if (exists $c->request->parameters->{$name}) {
 535             if (ref $c->request->parameters->{$name} eq 'ARRAY') {
 536                 push @{ $c->request->parameters->{$name} }, @filenames;
 537             }
 538             else {
 539                 $c->request->parameters->{$name} =
 540                     [ $c->request->parameters->{$name}, @filenames ];
 541             }
 542         }
 543         else {
 544             $c->request->parameters->{$name} =
 545                 @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 Catalyst Contributors, see Catalyst.pm
 675
 676 =head1 COPYRIGHT
 677
 678 This program is free software, you can redistribute it and/or modify it under
 679 the same terms as Perl itself.
 680
 681 =cut
 682
 683 1;