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