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 </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     if ( keys %{ $c->request->uploads } ) {
 295         for my $key ( keys %{ $c->request->uploads } ) {
 296             my $upload = $c->request->uploads->{$key};
 297             unlink map { $_->tempname }
 298               grep     { -e $_->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         unless ( $c->request->{_body} ) {
 315             my $type = $c->request->header('Content-Type');
 316             $c->request->{_body} = HTTP::Body->new( $type, $length );
 317             $c->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     # We copy, no references
 403     foreach my $name ( keys %{ $c->request->query_parameters } ) {
 404         my $param = $c->request->query_parameters->{$name};
 405         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 406         $c->request->parameters->{$name} = $param;
 407     }
 408
 409     # Merge query and body parameters
 410     foreach my $name ( keys %{ $c->request->body_parameters } ) {
 411         my $param = $c->request->body_parameters->{$name};
 412         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 413         if ( my $old_param = $c->request->parameters->{$name} ) {
 414             if ( ref $old_param eq 'ARRAY' ) {
 415                 push @{ $c->request->parameters->{$name} },
 416                   ref $param eq 'ARRAY' ? @$param : $param;
 417             }
 418             else { $c->request->parameters->{$name} = [ $old_param, $param ] }
 419         }
 420         else { $c->request->parameters->{$name} = $param }
 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     return unless $c->request->{_body};
 513
 514     my $uploads = $c->request->{_body}->upload;
 515     for my $name ( keys %$uploads ) {
 516         my $files = $uploads->{$name};
 517         $files = ref $files eq 'ARRAY' ? $files : [$files];
 518         my @uploads;
 519         for my $upload (@$files) {
 520             my $u = Catalyst::Request::Upload->new;
 521             $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
 522             $u->type( $u->headers->content_type );
 523             $u->tempname( $upload->{tempname} );
 524             $u->size( $upload->{size} );
 525             $u->filename( $upload->{filename} );
 526             push @uploads, $u;
 527         }
 528         $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
 529
 530         # support access to the filename as a normal param
 531         my @filenames = map { $_->{filename} } @uploads;
 532         # append, if there's already params with this name
 533         if (exists $c->request->parameters->{$name}) {
 534             if (ref $c->request->parameters->{$name} eq 'ARRAY') {
 535                 push @{ $c->request->parameters->{$name} }, @filenames;
 536             }
 537             else {
 538                 $c->request->parameters->{$name} =
 539                     [ $c->request->parameters->{$name}, @filenames ];
 540             }
 541         }
 542         else {
 543             $c->request->parameters->{$name} =
 544                 @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;