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 =over 4
  34
  35 =item $self->finalize_output
  36
  37 <obsolete>, see finalize_body
  38
  39 =item $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     if ( ref $c->response->body && $c->response->body->can('read') ) {
  48         while ( !$c->response->body->eof() ) {
  49             $c->response->body->read( my $buffer, $CHUNKSIZE );
  50             $self->write( $c, $buffer );
  51         }
  52         $c->response->body->close();
  53     }
  54     else {
  55         $self->write( $c, $c->response->body );
  56     }
  57 }
  58
  59 =item $self->finalize_cookies($c)
  60
  61 =cut
  62
  63 sub finalize_cookies {
  64     my ( $self, $c ) = @_;
  65
  66     my @cookies;
  67     while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
  68
  69         my $cookie = CGI::Cookie->new(
  70             -name    => $name,
  71             -value   => $cookie->{value},
  72             -expires => $cookie->{expires},
  73             -domain  => $cookie->{domain},
  74             -path    => $cookie->{path},
  75             -secure  => $cookie->{secure} || 0
  76         );
  77
  78         push @cookies, $cookie->as_string;
  79     }
  80
  81     if (@cookies) {
  82         $c->res->headers->push_header( 'Set-Cookie' => join ',', @cookies );
  83     }
  84 }
  85
  86 =item $self->finalize_error($c)
  87
  88 =cut
  89
  90 sub finalize_error {
  91     my ( $self, $c ) = @_;
  92
  93     $c->res->headers->content_type('text/html');
  94     my $name = $c->config->{name} || 'Catalyst Application';
  95
  96     my ( $title, $error, $infos );
  97     if ( $c->debug ) {
  98
  99         # For pretty dumps
 100         local $Data::Dumper::Terse = 1;
 101         $error = join '',
 102           map { '<code class="error">' . encode_entities($_) . '</code>' }
 103           @{ $c->error };
 104         $error ||= 'No output';
 105         $title = $name = "$name on Catalyst $Catalyst::VERSION";
 106
 107         # Don't show context in the dump
 108         delete $c->req->{_context};
 109         delete $c->res->{_context};
 110
 111         # Don't show body parser in the dump
 112         delete $c->req->{_body};
 113
 114         # Don't show response header state in dump
 115         delete $c->res->{_finalized_headers};
 116
 117         my $req   = encode_entities Dumper $c->req;
 118         my $res   = encode_entities Dumper $c->res;
 119         my $stash = encode_entities Dumper $c->stash;
 120
 121         my @infos;
 122         my $i = 0;
 123         warn "BAAR";
 124         for my $dump ( $c->dump_these ) {
 125             warn "FOOO";
 126             my $name  = $dump->[0];
 127             my $value = encode_entities( Dumper $dump->[1] );
 128             push @infos, sprintf <<"EOF", $name, $value;
 129 <div>
 130     <b><u>
 131         <a href="#" onclick="toggleDump(dump_$i); return false">%s</a>
 132     </u></b>
 133 </div>
 134 <br/>
 135 <div id="dump_$i">
 136     <pre>%s</pre>
 137 </div>
 138 EOF
 139             $i++;
 140         }
 141         $infos = join "\n", @infos;
 142     }
 143     else {
 144         $title = $name;
 145         $error = '';
 146         $infos = <<"";
 147 <pre>
 148 (en) Please come back later
 149 (de) Bitte versuchen sie es spaeter nocheinmal
 150 (nl) Gelieve te komen later terug
 151 (no) Vennligst prov igjen senere
 152 (fr) Veuillez revenir plus tard
 153 (es) Vuelto por favor mas adelante
 154 (pt) Voltado por favor mais tarde
 155 (it) Ritornato prego più successivamente
 156 </pre>
 157
 158         $name = '';
 159     }
 160     $c->res->body( <<"" );
 161 <html>
 162 <head>
 163     <title>$title</title>
 164     <script language="JavaScript">
 165         <!--
 166         function toggleDump (dumpElement) {
 167             if (dumpElement.style.display == "none") {
 168                 dumpElement.style.display = "";
 169             }
 170             else {
 171                 dumpElement.style.display = "none";
 172             }
 173         }
 174         -->
 175     </script>
 176     <style type="text/css">
 177         body {
 178             font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
 179                          Tahoma, Arial, helvetica, sans-serif;
 180             color: #ddd;
 181             background-color: #eee;
 182             margin: 0px;
 183             padding: 0px;
 184         }
 185         :link, :link:hover, :visited, :visited:hover {
 186             color: #ddd;
 187         }
 188         div.box {
 189             background-color: #ccc;
 190             border: 1px solid #aaa;
 191             padding: 4px;
 192             margin: 10px;
 193             -moz-border-radius: 10px;
 194         }
 195         div.error {
 196             background-color: #977;
 197             border: 1px solid #755;
 198             padding: 8px;
 199             margin: 4px;
 200             margin-bottom: 10px;
 201             -moz-border-radius: 10px;
 202         }
 203         div.infos {
 204             background-color: #797;
 205             border: 1px solid #575;
 206             padding: 8px;
 207             margin: 4px;
 208             margin-bottom: 10px;
 209             -moz-border-radius: 10px;
 210         }
 211         div.name {
 212             background-color: #779;
 213             border: 1px solid #557;
 214             padding: 8px;
 215             margin: 4px;
 216             -moz-border-radius: 10px;
 217         }
 218         code.error {
 219             display: block;
 220             margin: 1em 0;
 221             overflow: auto;
 222             white-space: pre;
 223         }
 224     </style>
 225 </head>
 226 <body>
 227     <div class="box">
 228         <div class="error">$error</div>
 229         <div class="infos">$infos</div>
 230         <div class="name">$name</div>
 231     </div>
 232 </body>
 233 </html>
 234
 235 }
 236
 237 =item $self->finalize_headers($c)
 238
 239 =cut
 240
 241 sub finalize_headers { }
 242
 243 =item $self->finalize_read($c)
 244
 245 =cut
 246
 247 sub finalize_read {
 248     my ( $self, $c ) = @_;
 249
 250     undef $self->{_prepared_read};
 251 }
 252
 253 =item $self->finalize_uploads($c)
 254
 255 =cut
 256
 257 sub finalize_uploads {
 258     my ( $self, $c ) = @_;
 259
 260     if ( keys %{ $c->request->uploads } ) {
 261         for my $key ( keys %{ $c->request->uploads } ) {
 262             my $upload = $c->request->uploads->{$key};
 263             unlink map { $_->tempname }
 264               grep     { -e $_->tempname }
 265               ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
 266         }
 267     }
 268 }
 269
 270 =item $self->prepare_body($c)
 271
 272 =cut
 273
 274 sub prepare_body {
 275     my ( $self, $c ) = @_;
 276
 277     $self->read_length( $c->request->header('Content-Length') || 0 );
 278     my $type = $c->request->header('Content-Type');
 279
 280     unless ( $c->request->{_body} ) {
 281         $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
 282     }
 283
 284     if ( $self->read_length > 0 ) {
 285         while ( my $buffer = $self->read($c) ) {
 286             $c->prepare_body_chunk($buffer);
 287         }
 288     }
 289 }
 290
 291 =item $self->prepare_body_chunk($c)
 292
 293 =cut
 294
 295 sub prepare_body_chunk {
 296     my ( $self, $c, $chunk ) = @_;
 297
 298     $c->request->{_body}->add($chunk);
 299 }
 300
 301 =item $self->prepare_body_parameters($c)
 302
 303 =cut
 304
 305 sub prepare_body_parameters {
 306     my ( $self, $c ) = @_;
 307     $c->request->body_parameters( $c->request->{_body}->param );
 308 }
 309
 310 =item $self->prepare_connection($c)
 311
 312 =cut
 313
 314 sub prepare_connection { }
 315
 316 =item $self->prepare_cookies($c)
 317
 318 =cut
 319
 320 sub prepare_cookies {
 321     my ( $self, $c ) = @_;
 322
 323     if ( my $header = $c->request->header('Cookie') ) {
 324         $c->req->cookies( { CGI::Cookie->parse($header) } );
 325     }
 326 }
 327
 328 =item $self->prepare_headers($c)
 329
 330 =cut
 331
 332 sub prepare_headers { }
 333
 334 =item $self->prepare_parameters($c)
 335
 336 =cut
 337
 338 sub prepare_parameters {
 339     my ( $self, $c ) = @_;
 340
 341     # We copy, no references
 342     while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
 343         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 344         $c->request->parameters->{$name} = $param;
 345     }
 346
 347     # Merge query and body parameters
 348     while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
 349         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 350         if ( my $old_param = $c->request->parameters->{$name} ) {
 351             if ( ref $old_param eq 'ARRAY' ) {
 352                 push @{ $c->request->parameters->{$name} },
 353                   ref $param eq 'ARRAY' ? @$param : $param;
 354             }
 355             else { $c->request->parameters->{$name} = [ $old_param, $param ] }
 356         }
 357         else { $c->request->parameters->{$name} = $param }
 358     }
 359 }
 360
 361 =item $self->prepare_path($c)
 362
 363 =cut
 364
 365 sub prepare_path { }
 366
 367 =item $self->prepare_request($c)
 368
 369 =item $self->prepare_query_parameters($c)
 370
 371 =cut
 372
 373 sub prepare_query_parameters {
 374     my ( $self, $c, $query_string ) = @_;
 375
 376     # replace semi-colons
 377     $query_string =~ s/;/&/g;
 378
 379     my $u = URI->new( '', 'http' );
 380     $u->query($query_string);
 381     for my $key ( $u->query_param ) {
 382         my @vals = $u->query_param($key);
 383         $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
 384     }
 385 }
 386
 387 =item $self->prepare_read($c)
 388
 389 =cut
 390
 391 sub prepare_read {
 392     my ( $self, $c ) = @_;
 393
 394     # Reset the read position
 395     $self->read_position(0);
 396 }
 397
 398 =item $self->prepare_request(@arguments)
 399
 400 =cut
 401
 402 sub prepare_request { }
 403
 404 =item $self->prepare_uploads($c)
 405
 406 =cut
 407
 408 sub prepare_uploads {
 409     my ( $self, $c ) = @_;
 410     my $uploads = $c->request->{_body}->upload;
 411     for my $name ( keys %$uploads ) {
 412         my $files = $uploads->{$name};
 413         $files = ref $files eq 'ARRAY' ? $files : [$files];
 414         my @uploads;
 415         for my $upload (@$files) {
 416             my $u = Catalyst::Request::Upload->new;
 417             $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
 418             $u->type( $u->headers->content_type );
 419             $u->tempname( $upload->{tempname} );
 420             $u->size( $upload->{size} );
 421             $u->filename( $upload->{filename} );
 422             push @uploads, $u;
 423         }
 424         $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
 425
 426         # support access to the filename as a normal param
 427         my @filenames = map { $_->{filename} } @uploads;
 428         $c->request->parameters->{$name} =
 429           @filenames > 1 ? \@filenames : $filenames[0];
 430     }
 431 }
 432
 433 =item $self->prepare_write($c)
 434
 435 =cut
 436
 437 sub prepare_write { }
 438
 439 =item $self->read($c, [$maxlength])
 440
 441 =cut
 442
 443 sub read {
 444     my ( $self, $c, $maxlength ) = @_;
 445
 446     unless ( $self->{_prepared_read} ) {
 447         $self->prepare_read($c);
 448         $self->{_prepared_read} = 1;
 449     }
 450
 451     my $remaining = $self->read_length - $self->read_position;
 452     $maxlength ||= $CHUNKSIZE;
 453
 454     # Are we done reading?
 455     if ( $remaining <= 0 ) {
 456         $self->finalize_read($c);
 457         return;
 458     }
 459
 460     my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
 461     my $rc = $self->read_chunk( $c, my $buffer, $readlen );
 462     if ( defined $rc ) {
 463         $self->read_position( $self->read_position + $rc );
 464         return $buffer;
 465     }
 466     else {
 467         Catalyst::Exception->throw(
 468             message => "Unknown error reading input: $!" );
 469     }
 470 }
 471
 472 =item $self->read_chunk($c, $buffer, $length)
 473
 474 Each engine inplements read_chunk as its preferred way of reading a chunk
 475 of data.
 476
 477 =cut
 478
 479 sub read_chunk { }
 480
 481 =item $self->read_length
 482
 483 The length of input data to be read.  This is obtained from the Content-Length
 484 header.
 485
 486 =item $self->read_position
 487
 488 The amount of input data that has already been read.
 489
 490 =item $self->run($c)
 491
 492 =cut
 493
 494 sub run { }
 495
 496 =item $self->write($c, $buffer)
 497
 498 =cut
 499
 500 sub write {
 501     my ( $self, $c, $buffer ) = @_;
 502
 503     unless ( $self->{_prepared_write} ) {
 504         $self->prepare_write($c);
 505         $self->{_prepared_write} = 1;
 506     }
 507
 508     print STDOUT $buffer;
 509 }
 510
 511 =back
 512
 513 =head1 AUTHORS
 514
 515 Sebastian Riedel, <sri@cpan.org>
 516
 517 Andy Grundman, <andy@hybridized.org>
 518
 519 =head1 COPYRIGHT
 520
 521 This program is free software, you can redistribute it and/or modify it under
 522 the same terms as Perl itself.
 523
 524 =cut
 525
 526 1;