lib/Catalyst/Engine.pm

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