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