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