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         $infos = <<"";
 121 <br/>
 122 <b><u>Request</u></b><br/>
 123 <pre>$req</pre>
 124 <b><u>Response</u></b><br/>
 125 <pre>$res</pre>
 126 <b><u>Stash</u></b><br/>
 127 <pre>$stash</pre>
 128
 129     }
 130     else {
 131         $title = $name;
 132         $error = '';
 133         $infos = <<"";
 134 <pre>
 135 (en) Please come back later
 136 (de) Bitte versuchen sie es spaeter nocheinmal
 137 (nl) Gelieve te komen later terug
 138 (no) Vennligst prov igjen senere
 139 (fr) Veuillez revenir plus tard
 140 (es) Vuelto por favor mas adelante
 141 (pt) Voltado por favor mais tarde
 142 (it) Ritornato prego più successivamente
 143 </pre>
 144
 145         $name = '';
 146     }
 147     $c->res->body( <<"" );
 148 <html>
 149 <head>
 150     <title>$title</title>
 151     <style type="text/css">
 152         body {
 153             font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
 154                          Tahoma, Arial, helvetica, sans-serif;
 155             color: #ddd;
 156             background-color: #eee;
 157             margin: 0px;
 158             padding: 0px;
 159         }
 160         div.box {
 161             background-color: #ccc;
 162             border: 1px solid #aaa;
 163             padding: 4px;
 164             margin: 10px;
 165             -moz-border-radius: 10px;
 166         }
 167         div.error {
 168             background-color: #977;
 169             border: 1px solid #755;
 170             padding: 8px;
 171             margin: 4px;
 172             margin-bottom: 10px;
 173             -moz-border-radius: 10px;
 174         }
 175         div.infos {
 176             background-color: #797;
 177             border: 1px solid #575;
 178             padding: 8px;
 179             margin: 4px;
 180             margin-bottom: 10px;
 181             -moz-border-radius: 10px;
 182         }
 183         div.name {
 184             background-color: #779;
 185             border: 1px solid #557;
 186             padding: 8px;
 187             margin: 4px;
 188             -moz-border-radius: 10px;
 189         }
 190         code.error {
 191             display: block;
 192             margin: 1em 0;
 193             overflow: auto;
 194             white-space: pre;
 195         }
 196     </style>
 197 </head>
 198 <body>
 199     <div class="box">
 200         <div class="error">$error</div>
 201         <div class="infos">$infos</div>
 202         <div class="name">$name</div>
 203     </div>
 204 </body>
 205 </html>
 206
 207 }
 208
 209 =item $self->finalize_headers($c)
 210
 211 =cut
 212
 213 sub finalize_headers { }
 214
 215 =item $self->finalize_read($c)
 216
 217 =cut
 218
 219 sub finalize_read {
 220     my ( $self, $c ) = @_;
 221
 222     undef $self->{_prepared_read};
 223 }
 224
 225 =item $self->finalize_uploads($c)
 226
 227 =cut
 228
 229 sub finalize_uploads {
 230     my ( $self, $c ) = @_;
 231
 232     if ( keys %{ $c->request->uploads } ) {
 233         for my $key ( keys %{ $c->request->uploads } ) {
 234             my $upload = $c->request->uploads->{$key};
 235             unlink map { $_->tempname }
 236               grep     { -e $_->tempname }
 237               ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
 238         }
 239     }
 240 }
 241
 242 =item $self->prepare_body($c)
 243
 244 =cut
 245
 246 sub prepare_body {
 247     my ( $self, $c ) = @_;
 248
 249     $self->read_length( $c->request->header('Content-Length') || 0 );
 250     my $type = $c->request->header('Content-Type');
 251
 252     unless ( $c->request->{_body} ) {
 253         $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
 254     }
 255
 256     if ( $self->read_length > 0 ) {
 257         while ( my $buffer = $self->read($c) ) {
 258             $c->prepare_body_chunk($buffer);
 259         }
 260     }
 261 }
 262
 263 =item $self->prepare_body_chunk($c)
 264
 265 =cut
 266
 267 sub prepare_body_chunk {
 268     my ( $self, $c, $chunk ) = @_;
 269
 270     $c->request->{_body}->add($chunk);
 271 }
 272
 273 =item $self->prepare_body_parameters($c)
 274
 275 =cut
 276
 277 sub prepare_body_parameters {
 278     my ( $self, $c ) = @_;
 279     $c->request->body_parameters( $c->request->{_body}->param );
 280 }
 281
 282 =item $self->prepare_connection($c)
 283
 284 =cut
 285
 286 sub prepare_connection { }
 287
 288 =item $self->prepare_cookies($c)
 289
 290 =cut
 291
 292 sub prepare_cookies {
 293     my ( $self, $c ) = @_;
 294
 295     if ( my $header = $c->request->header('Cookie') ) {
 296         $c->req->cookies( { CGI::Cookie->parse($header) } );
 297     }
 298 }
 299
 300 =item $self->prepare_headers($c)
 301
 302 =cut
 303
 304 sub prepare_headers { }
 305
 306 =item $self->prepare_parameters($c)
 307
 308 =cut
 309
 310 sub prepare_parameters {
 311     my ( $self, $c ) = @_;
 312
 313     # We copy, no references
 314     while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
 315         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 316         $c->request->parameters->{$name} = $param;
 317     }
 318
 319     # Merge query and body parameters
 320     while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
 321         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
 322         if ( my $old_param = $c->request->parameters->{$name} ) {
 323             if ( ref $old_param eq 'ARRAY' ) {
 324                 push @{ $c->request->parameters->{$name} },
 325                   ref $param eq 'ARRAY' ? @$param : $param;
 326             }
 327             else { $c->request->parameters->{$name} = [ $old_param, $param ] }
 328         }
 329         else { $c->request->parameters->{$name} = $param }
 330     }
 331 }
 332
 333 =item $self->prepare_path($c)
 334
 335 =cut
 336
 337 sub prepare_path { }
 338
 339 =item $self->prepare_request($c)
 340
 341 =item $self->prepare_query_parameters($c)
 342
 343 =cut
 344
 345 sub prepare_query_parameters {
 346     my ( $self, $c, $query_string ) = @_;
 347
 348     # replace semi-colons
 349     $query_string =~ s/;/&/g;
 350
 351     my $u = URI->new( '', 'http' );
 352     $u->query($query_string);
 353     for my $key ( $u->query_param ) {
 354         my @vals = $u->query_param($key);
 355         $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
 356     }
 357 }
 358
 359 =item $self->prepare_read($c)
 360
 361 =cut
 362
 363 sub prepare_read {
 364     my ( $self, $c ) = @_;
 365
 366     # Reset the read position
 367     $self->read_position(0);
 368 }
 369
 370 =item $self->prepare_request(@arguments)
 371
 372 =cut
 373
 374 sub prepare_request { }
 375
 376 =item $self->prepare_uploads($c)
 377
 378 =cut
 379
 380 sub prepare_uploads {
 381     my ( $self, $c ) = @_;
 382     my $uploads = $c->request->{_body}->upload;
 383     for my $name ( keys %$uploads ) {
 384         my $files = $uploads->{$name};
 385         $files = ref $files eq 'ARRAY' ? $files : [$files];
 386         my @uploads;
 387         for my $upload (@$files) {
 388             my $u = Catalyst::Request::Upload->new;
 389             $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
 390             $u->type( $u->headers->content_type );
 391             $u->tempname( $upload->{tempname} );
 392             $u->size( $upload->{size} );
 393             $u->filename( $upload->{filename} );
 394             push @uploads, $u;
 395         }
 396         $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
 397
 398         # support access to the filename as a normal param
 399         my @filenames = map { $_->{filename} } @uploads;
 400         $c->request->parameters->{$name} =
 401           @filenames > 1 ? \@filenames : $filenames[0];
 402     }
 403 }
 404
 405 =item $self->prepare_write($c)
 406
 407 =cut
 408
 409 sub prepare_write { }
 410
 411 =item $self->read($c, [$maxlength])
 412
 413 =cut
 414
 415 sub read {
 416     my ( $self, $c, $maxlength ) = @_;
 417
 418     unless ( $self->{_prepared_read} ) {
 419         $self->prepare_read($c);
 420         $self->{_prepared_read} = 1;
 421     }
 422
 423     my $remaining = $self->read_length - $self->read_position;
 424     $maxlength ||= $CHUNKSIZE;
 425
 426     # Are we done reading?
 427     if ( $remaining <= 0 ) {
 428         $self->finalize_read($c);
 429         return;
 430     }
 431
 432     my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
 433     my $rc = $self->read_chunk( $c, my $buffer, $readlen );
 434     if ( defined $rc ) {
 435         $self->read_position( $self->read_position + $rc );
 436         return $buffer;
 437     }
 438     else {
 439         Catalyst::Exception->throw(
 440             message => "Unknown error reading input: $!" );
 441     }
 442 }
 443
 444 =item $self->read_chunk($c, $buffer, $length)
 445
 446 Each engine inplements read_chunk as its preferred way of reading a chunk
 447 of data.
 448
 449 =cut
 450
 451 sub read_chunk { }
 452
 453 =item $self->read_length
 454
 455 The length of input data to be read.  This is obtained from the Content-Length
 456 header.
 457
 458 =item $self->read_position
 459
 460 The amount of input data that has already been read.
 461
 462 =item $self->run($c)
 463
 464 =cut
 465
 466 sub run { }
 467
 468 =item $self->write($c, $buffer)
 469
 470 =cut
 471
 472 sub write {
 473     my ( $self, $c, $buffer ) = @_;
 474
 475     unless ( $self->{_prepared_write} ) {
 476         $self->prepare_write($c);
 477         $self->{_prepared_write} = 1;
 478     }
 479
 480     print STDOUT $buffer;
 481 }
 482
 483 =back
 484
 485 =head1 AUTHORS
 486
 487 Sebastian Riedel, <sri@cpan.org>
 488
 489 Andy Grundman, <andy@hybridized.org>
 490
 491 =head1 COPYRIGHT
 492
 493 This program is free software, you can redistribute it and/or modify it under
 494 the same terms as Perl itself.
 495
 496 =cut
 497
 498 1;