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