lib/Catalyst/Engine.pm

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