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