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