lib/Catalyst/Engine.pm

   1 package Catalyst::Engine;
   2
   3 use strict;
   4 use base 'Class::Accessor::Fast';
   5 use CGI::Simple::Cookie;
   6 use Data::Dump qw/dump/;
   7 use HTML::Entities;
   8 use HTTP::Body;
   9 use HTTP::Headers;
  10 use URI::Escape ();
  11 use URI::QueryParam;
  12 use Scalar::Util ();
  13
  14 # input position and length
  15 __PACKAGE__->mk_accessors(qw/read_position read_length/);
  16
  17 # Stringify to class
  18 use overload '""' => sub { return ref shift }, fallback => 1;
  19
  20 # Amount of data to read from input on each pass
  21 our $CHUNKSIZE = 64 * 1024;
  22
  23 # See if we can use libapreq2 for URI unescaping
  24 use constant HAS_APR => eval {
  25     require APR::Request;
  26 };
  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
  75     foreach my $name ( keys %{ $c->response->cookies } ) {
  76
  77         my $val = $c->response->cookies->{$name};
  78
  79         my $cookie = (
  80             Scalar::Util::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         $c->res->headers->push_header( 'Set-Cookie' => $cookie );
  97     }
  98 }
  99
 100 =head2 $self->finalize_error($c)
 101
 102 Output an apropriate 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         delete $c->req->{_context};
 130         delete $c->res->{_context};
 131
 132         # Don't show body parser in the dump
 133         delete $c->req->{_body};
 134
 135         # Don't show response header state in dump
 136         delete $c->res->{_finalized_headers};
 137
 138         my @infos;
 139         my $i = 0;
 140         for my $dump ( $c->dump_these ) {
 141             my $name  = $dump->[0];
 142             my $value = encode_entities( dump( $dump->[1] ));
 143             push @infos, sprintf <<"EOF", $name, $value;
 144 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
 145 <div id="dump_$i">
 146     <pre wrap="">%s</pre>
 147 </div>
 148 EOF
 149             $i++;
 150         }
 151         $infos = join "\n", @infos;
 152     }
 153     else {
 154         $title = $name;
 155         $error = '';
 156         $infos = <<"";
 157 <pre>
 158 (en) Please come back later
 159 (fr) SVP veuillez revenir plus tard
 160 (de) Bitte versuchen sie es spaeter nocheinmal
 161 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
 162 (no) Vennligst prov igjen senere
 163 (dk) Venligst prov igen senere
 164 (pl) Prosze sprobowac pozniej
 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     my ( $self, $c ) = @_;
 290
 291     undef $self->{_prepared_read};
 292 }
 293
 294 =head2 $self->finalize_uploads($c)
 295
 296 Clean up after uploads, deleting temp files.
 297
 298 =cut
 299
 300 sub finalize_uploads {
 301     my ( $self, $c ) = @_;
 302
 303     if ( keys %{ $c->request->uploads } ) {
 304         for my $key ( keys %{ $c->request->uploads } ) {
 305             my $upload = $c->request->uploads->{$key};
 306             unlink map { $_->tempname }
 307               grep     { -e $_->tempname }
 308               ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
 309         }
 310     }
 311 }
 312
 313 =head2 $self->prepare_body($c)
 314
 315 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
 316
 317 =cut
 318
 319 sub prepare_body {
 320     my ( $self, $c ) = @_;
 321
 322     my $length = $c->request->header('Content-Length') || 0;
 323
 324     $self->read_length( $length );
 325
 326     if ( $length > 0 ) {
 327         unless ( $c->request->{_body} ) {
 328             my $type = $c->request->header('Content-Type');
 329             $c->request->{_body} = HTTP::Body->new( $type, $length );
 330             $c->request->{_body}->{tmpdir} = $c->config->{uploadtmp}
 331               if exists $c->config->{uploadtmp};
 332         }
 333
 334         while ( my $buffer = $self->read($c) ) {
 335             $c->prepare_body_chunk($buffer);
 336         }
 337
 338         # paranoia against wrong Content-Length header
 339         my $remaining = $length - $self->read_position;
 340         if ( $remaining > 0 ) {
 341             $self->finalize_read($c);
 342             Catalyst::Exception->throw(
 343                 "Wrong Content-Length value: $length" );
 344         }
 345     }
 346     else {
 347         # Defined but will cause all body code to be skipped
 348         $c->request->{_body} = 0;
 349     }
 350 }
 351
 352 =head2 $self->prepare_body_chunk($c)
 353
 354 Add a chunk to the request body.
 355
 356 =cut
 357
 358 sub prepare_body_chunk {
 359     my ( $self, $c, $chunk ) = @_;
 360
 361     $c->request->{_body}->add($chunk);
 362 }
 363
 364 =head2 $self->prepare_body_parameters($c)
 365
 366 Sets up parameters from body.
 367
 368 =cut
 369
 370 sub prepare_body_parameters {
 371     my ( $self, $c ) = @_;
 372
 373     return unless $c->request->{_body};
 374
 375     $c->request->body_parameters( $c->request->{_body}->param );
 376 }
 377
 378 =head2 $self->prepare_connection($c)
 379
 380 Abstract method implemented in engines.
 381
 382 =cut
 383
 384 sub prepare_connection { }
 385
 386 =head2 $self->prepare_cookies($c)
 387
 388 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
 389
 390 =cut
 391
 392 sub prepare_cookies {
 393     my ( $self, $c ) = @_;
 394
 395     if ( my $header = $c->request->header('Cookie') ) {
 396         $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
 397     }
 398 }
 399
 400 =head2 $self->prepare_headers($c)
 401
 402 =cut
 403
 404 sub prepare_headers { }
 405
 406 =head2 $self->prepare_parameters($c)
 407
 408 sets up parameters from query and post parameters.
 409
 410 =cut
 411
 412 sub prepare_parameters {
 413     my ( $self, $c ) = @_;
 414
 415     # We copy, no references
 416     foreach my $name ( keys %{ $c->request->query_parameters } ) {
 417         my $param = $c->request->query_parameters->{$name};
 418         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 419         $c->request->parameters->{$name} = $param;
 420     }
 421
 422     # Merge query and body parameters
 423     foreach my $name ( keys %{ $c->request->body_parameters } ) {
 424         my $param = $c->request->body_parameters->{$name};
 425         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 426         if ( my $old_param = $c->request->parameters->{$name} ) {
 427             if ( ref $old_param eq 'ARRAY' ) {
 428                 push @{ $c->request->parameters->{$name} },
 429                   ref $param eq 'ARRAY' ? @$param : $param;
 430             }
 431             else { $c->request->parameters->{$name} = [ $old_param, $param ] }
 432         }
 433         else { $c->request->parameters->{$name} = $param }
 434     }
 435 }
 436
 437 =head2 $self->prepare_path($c)
 438
 439 abstract method, implemented by engines.
 440
 441 =cut
 442
 443 sub prepare_path { }
 444
 445 =head2 $self->prepare_request($c)
 446
 447 =head2 $self->prepare_query_parameters($c)
 448
 449 process the query string and extract query parameters.
 450
 451 =cut
 452
 453 sub prepare_query_parameters {
 454     my ( $self, $c, $query_string ) = @_;
 455
 456     # Check for keywords (no = signs)
 457     if ( index( $query_string, '=' ) < 0 ) {
 458         $c->request->keywords( $self->unescape_uri($query_string) );
 459         return;
 460     }
 461
 462     my %query;
 463
 464     # replace semi-colons
 465     $query_string =~ s/;/&/g;
 466
 467     my @params = split /&/, $query_string;
 468
 469     for my $item ( @params ) {
 470
 471         my ($param, $value)
 472             = map { $self->unescape_uri($_) }
 473               split( /=/, $item );
 474
 475         $param = $self->unescape_uri($item) unless defined $param;
 476
 477         if ( exists $query{$param} ) {
 478             if ( ref $query{$param} ) {
 479                 push @{ $query{$param} }, $value;
 480             }
 481             else {
 482                 $query{$param} = [ $query{$param}, $value ];
 483             }
 484         }
 485         else {
 486             $query{$param} = $value;
 487         }
 488     }
 489
 490     $c->request->query_parameters( \%query );
 491 }
 492
 493 =head2 $self->prepare_read($c)
 494
 495 prepare to read from the engine.
 496
 497 =cut
 498
 499 sub prepare_read {
 500     my ( $self, $c ) = @_;
 501
 502     # Reset the read position
 503     $self->read_position(0);
 504 }
 505
 506 =head2 $self->prepare_request(@arguments)
 507
 508 Populate the context object from the request object.
 509
 510 =cut
 511
 512 sub prepare_request { }
 513
 514 =head2 $self->prepare_uploads($c)
 515
 516 =cut
 517
 518 sub prepare_uploads {
 519     my ( $self, $c ) = @_;
 520
 521     return unless $c->request->{_body};
 522
 523     my $uploads = $c->request->{_body}->upload;
 524     for my $name ( keys %$uploads ) {
 525         my $files = $uploads->{$name};
 526         $files = ref $files eq 'ARRAY' ? $files : [$files];
 527         my @uploads;
 528         for my $upload (@$files) {
 529             my $u = Catalyst::Request::Upload->new;
 530             $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
 531             $u->type( $u->headers->content_type );
 532             $u->tempname( $upload->{tempname} );
 533             $u->size( $upload->{size} );
 534             $u->filename( $upload->{filename} );
 535             push @uploads, $u;
 536         }
 537         $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
 538
 539         # support access to the filename as a normal param
 540         my @filenames = map { $_->{filename} } @uploads;
 541         # append, if there's already params with this name
 542         if (exists $c->request->parameters->{$name}) {
 543             if (ref $c->request->parameters->{$name} eq 'ARRAY') {
 544                 push @{ $c->request->parameters->{$name} }, @filenames;
 545             }
 546             else {
 547                 $c->request->parameters->{$name} =
 548                     [ $c->request->parameters->{$name}, @filenames ];
 549             }
 550         }
 551         else {
 552             $c->request->parameters->{$name} =
 553                 @filenames > 1 ? \@filenames : $filenames[0];
 554         }
 555     }
 556 }
 557
 558 =head2 $self->prepare_write($c)
 559
 560 Abstract method. Implemented by the engines.
 561
 562 =cut
 563
 564 sub prepare_write { }
 565
 566 =head2 $self->read($c, [$maxlength])
 567
 568 =cut
 569
 570 sub read {
 571     my ( $self, $c, $maxlength ) = @_;
 572
 573     unless ( $self->{_prepared_read} ) {
 574         $self->prepare_read($c);
 575         $self->{_prepared_read} = 1;
 576     }
 577
 578     my $remaining = $self->read_length - $self->read_position;
 579     $maxlength ||= $CHUNKSIZE;
 580
 581     # Are we done reading?
 582     if ( $remaining <= 0 ) {
 583         $self->finalize_read($c);
 584         return;
 585     }
 586
 587     my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
 588     my $rc = $self->read_chunk( $c, my $buffer, $readlen );
 589     if ( defined $rc ) {
 590         $self->read_position( $self->read_position + $rc );
 591         return $buffer;
 592     }
 593     else {
 594         Catalyst::Exception->throw(
 595             message => "Unknown error reading input: $!" );
 596     }
 597 }
 598
 599 =head2 $self->read_chunk($c, $buffer, $length)
 600
 601 Each engine inplements read_chunk as its preferred way of reading a chunk
 602 of data.
 603
 604 =cut
 605
 606 sub read_chunk { }
 607
 608 =head2 $self->read_length
 609
 610 The length of input data to be read.  This is obtained from the Content-Length
 611 header.
 612
 613 =head2 $self->read_position
 614
 615 The amount of input data that has already been read.
 616
 617 =head2 $self->run($c)
 618
 619 Start the engine. Implemented by the various engine classes.
 620
 621 =cut
 622
 623 sub run { }
 624
 625 =head2 $self->write($c, $buffer)
 626
 627 Writes the buffer to the client. Can only be called once for a request.
 628
 629 =cut
 630
 631 sub write {
 632     my ( $self, $c, $buffer ) = @_;
 633
 634     unless ( $self->{_prepared_write} ) {
 635         $self->prepare_write($c);
 636         $self->{_prepared_write} = 1;
 637     }
 638
 639     print STDOUT $buffer;
 640 }
 641
 642 =head2 $self->unescape_uri($uri)
 643
 644 Unescapes a given URI using the most efficient method available.  Engines
 645 can subclass to provide faster implementations.
 646
 647 =cut
 648
 649 sub unescape_uri {
 650     my $self = shift;
 651
 652     if ( HAS_APR ) {
 653         # This function is ~12x faster than URI::Escape
 654         return APR::Request::decode(@_);
 655     }
 656
 657     my $e = URI::Escape::uri_unescape(@_);
 658     $e =~ s/\+/ /g;
 659
 660     return $e;
 661 }
 662
 663 =head2 $self->finalize_output
 664
 665 <obsolete>, see finalize_body
 666
 667 =head1 AUTHORS
 668
 669 Sebastian Riedel, <sri@cpan.org>
 670
 671 Andy Grundman, <andy@hybridized.org>
 672
 673 =head1 COPYRIGHT
 674
 675 This program is free software, you can redistribute it and/or modify it under
 676 the same terms as Perl itself.
 677
 678 =cut
 679
 680 1;