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