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