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