1 package Catalyst::Engine;
4 use base 'Class::Accessor::Fast';
5 use CGI::Simple::Cookie;
6 use Data::Dump qw/dump/;
14 # input position and length
15 __PACKAGE__->mk_accessors(qw/read_position read_length/);
18 use overload '""' => sub { return ref shift }, fallback => 1;
20 # Amount of data to read from input on each pass
21 our $CHUNKSIZE = 64 * 1024;
25 Catalyst::Engine - The Catalyst Engine
36 =head2 $self->finalize_body($c)
38 Finalize body. Prints the response output.
43 my ( $self, $c ) = @_;
44 my $body = $c->response->body;
45 no warnings 'uninitialized';
46 if ( Scalar::Util::blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
47 while ( !eof $body ) {
48 read $body, my ($buffer), $CHUNKSIZE;
49 last unless $self->write( $c, $buffer );
54 $self->write( $c, $body );
58 =head2 $self->finalize_cookies($c)
60 Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
65 sub finalize_cookies {
66 my ( $self, $c ) = @_;
70 foreach my $name ( keys %{ $c->response->cookies } ) {
72 my $val = $c->response->cookies->{$name};
75 Scalar::Util::blessed($val)
77 : CGI::Simple::Cookie->new(
79 -value => $val->{value},
80 -expires => $val->{expires},
81 -domain => $val->{domain},
82 -path => $val->{path},
83 -secure => $val->{secure} || 0
87 push @cookies, $cookie->as_string;
90 for my $cookie (@cookies) {
91 $c->res->headers->push_header( 'Set-Cookie' => $cookie );
95 =head2 $self->finalize_error($c)
97 Output an apropriate error message, called if there's an error in $c
98 after the dispatch has finished. Will output debug messages if Catalyst
99 is in debug mode, or a `please come back later` message otherwise.
104 my ( $self, $c ) = @_;
106 $c->res->content_type('text/html; charset=utf-8');
107 my $name = $c->config->{name} || join(' ', split('::', ref $c));
109 my ( $title, $error, $infos );
113 $error = join '', map {
114 '<p><code class="error">'
115 . encode_entities($_)
118 $error ||= 'No output';
119 $error = qq{<pre wrap="">$error</pre>};
120 $title = $name = "$name on Catalyst $Catalyst::VERSION";
121 $name = "<h1>$name</h1>";
123 # Don't show context in the dump
124 delete $c->req->{_context};
125 delete $c->res->{_context};
127 # Don't show body parser in the dump
128 delete $c->req->{_body};
130 # Don't show response header state in dump
131 delete $c->res->{_finalized_headers};
135 for my $dump ( $c->dump_these ) {
136 my $name = $dump->[0];
137 my $value = encode_entities( dump( $dump->[1] ));
138 push @infos, sprintf <<"EOF", $name, $value;
139 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
141 <pre wrap="">%s</pre>
146 $infos = join "\n", @infos;
153 (en) Please come back later
154 (fr) SVP veuillez revenir plus tard
155 (de) Bitte versuchen sie es spaeter nocheinmal
156 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
157 (no) Vennligst prov igjen senere
158 (dk) Venligst prov igen senere
159 (pl) Prosze sprobowac pozniej
164 $c->res->body( <<"" );
165 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
166 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
167 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
169 <meta http-equiv="Content-Language" content="en" />
170 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
171 <title>$title</title>
172 <script type="text/javascript">
174 function toggleDump (dumpElement) {
175 var e = document.getElementById( dumpElement );
176 if (e.style.display == "none") {
177 e.style.display = "";
180 e.style.display = "none";
185 <style type="text/css">
187 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
188 Tahoma, Arial, helvetica, sans-serif;
190 background-color: #eee;
194 :link, :link:hover, :visited, :visited:hover {
199 background-color: #ccc;
200 border: 1px solid #aaa;
205 background-color: #cce;
206 border: 1px solid #755;
212 background-color: #eee;
213 border: 1px solid #575;
219 background-color: #cce;
220 border: 1px solid #557;
229 div.name h1, div.error p {
237 text-decoration: underline;
243 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
244 /* Browser specific (not valid) styles to make preformatted text wrap */
246 white-space: pre-wrap; /* css-3 */
247 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
248 white-space: -pre-wrap; /* Opera 4-6 */
249 white-space: -o-pre-wrap; /* Opera 7 */
250 word-wrap: break-word; /* Internet Explorer 5.5+ */
256 <div class="error">$error</div>
257 <div class="infos">$infos</div>
258 <div class="name">$name</div>
265 $c->res->{body} .= ( ' ' x 512 );
268 $c->res->status(500);
271 =head2 $self->finalize_headers($c)
273 Abstract method, allows engines to write headers to response
277 sub finalize_headers { }
279 =head2 $self->finalize_read($c)
284 my ( $self, $c ) = @_;
286 undef $self->{_prepared_read};
289 =head2 $self->finalize_uploads($c)
291 Clean up after uploads, deleting temp files.
295 sub finalize_uploads {
296 my ( $self, $c ) = @_;
298 if ( keys %{ $c->request->uploads } ) {
299 for my $key ( keys %{ $c->request->uploads } ) {
300 my $upload = $c->request->uploads->{$key};
301 unlink map { $_->tempname }
302 grep { -e $_->tempname }
303 ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
308 =head2 $self->prepare_body($c)
310 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
315 my ( $self, $c ) = @_;
317 my $length = $c->request->header('Content-Length') || 0;
319 $self->read_length( $length );
322 unless ( $c->request->{_body} ) {
323 my $type = $c->request->header('Content-Type');
324 $c->request->{_body} = HTTP::Body->new( $type, $length );
325 $c->request->{_body}->{tmpdir} = $c->config->{uploadtmp}
326 if exists $c->config->{uploadtmp};
329 while ( my $buffer = $self->read($c) ) {
330 $c->prepare_body_chunk($buffer);
333 # paranoia against wrong Content-Length header
334 my $remaining = $length - $self->read_position;
335 if ( $remaining > 0 ) {
336 $self->finalize_read($c);
337 Catalyst::Exception->throw(
338 "Wrong Content-Length value: $length" );
342 # Defined but will cause all body code to be skipped
343 $c->request->{_body} = 0;
347 =head2 $self->prepare_body_chunk($c)
349 Add a chunk to the request body.
353 sub prepare_body_chunk {
354 my ( $self, $c, $chunk ) = @_;
356 $c->request->{_body}->add($chunk);
359 =head2 $self->prepare_body_parameters($c)
361 Sets up parameters from body.
365 sub prepare_body_parameters {
366 my ( $self, $c ) = @_;
368 return unless $c->request->{_body};
370 $c->request->body_parameters( $c->request->{_body}->param );
373 =head2 $self->prepare_connection($c)
375 Abstract method implemented in engines.
379 sub prepare_connection { }
381 =head2 $self->prepare_cookies($c)
383 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
387 sub prepare_cookies {
388 my ( $self, $c ) = @_;
390 if ( my $header = $c->request->header('Cookie') ) {
391 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
395 =head2 $self->prepare_headers($c)
399 sub prepare_headers { }
401 =head2 $self->prepare_parameters($c)
403 sets up parameters from query and post parameters.
407 sub prepare_parameters {
408 my ( $self, $c ) = @_;
410 # We copy, no references
411 foreach my $name ( keys %{ $c->request->query_parameters } ) {
412 my $param = $c->request->query_parameters->{$name};
413 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
414 $c->request->parameters->{$name} = $param;
417 # Merge query and body parameters
418 foreach my $name ( keys %{ $c->request->body_parameters } ) {
419 my $param = $c->request->body_parameters->{$name};
420 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
421 if ( my $old_param = $c->request->parameters->{$name} ) {
422 if ( ref $old_param eq 'ARRAY' ) {
423 push @{ $c->request->parameters->{$name} },
424 ref $param eq 'ARRAY' ? @$param : $param;
426 else { $c->request->parameters->{$name} = [ $old_param, $param ] }
428 else { $c->request->parameters->{$name} = $param }
432 =head2 $self->prepare_path($c)
434 abstract method, implemented by engines.
440 =head2 $self->prepare_request($c)
442 =head2 $self->prepare_query_parameters($c)
444 process the query string and extract query parameters.
448 sub prepare_query_parameters {
449 my ( $self, $c, $query_string ) = @_;
451 # Check for keywords (no = signs)
452 if ( index( $query_string, '=' ) < 0 ) {
453 $c->request->keywords( $self->unescape_uri($query_string) );
459 # replace semi-colons
460 $query_string =~ s/;/&/g;
462 my @params = split /&/, $query_string;
464 for my $item ( @params ) {
467 = map { $self->unescape_uri($_) }
470 $param = $self->unescape_uri($item) unless defined $param;
472 if ( exists $query{$param} ) {
473 if ( ref $query{$param} ) {
474 push @{ $query{$param} }, $value;
477 $query{$param} = [ $query{$param}, $value ];
481 $query{$param} = $value;
485 $c->request->query_parameters( \%query );
488 =head2 $self->prepare_read($c)
490 prepare to read from the engine.
495 my ( $self, $c ) = @_;
497 # Reset the read position
498 $self->read_position(0);
501 =head2 $self->prepare_request(@arguments)
503 Populate the context object from the request object.
507 sub prepare_request { }
509 =head2 $self->prepare_uploads($c)
513 sub prepare_uploads {
514 my ( $self, $c ) = @_;
516 return unless $c->request->{_body};
518 my $uploads = $c->request->{_body}->upload;
519 for my $name ( keys %$uploads ) {
520 my $files = $uploads->{$name};
521 $files = ref $files eq 'ARRAY' ? $files : [$files];
523 for my $upload (@$files) {
524 my $u = Catalyst::Request::Upload->new;
525 $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
526 $u->type( $u->headers->content_type );
527 $u->tempname( $upload->{tempname} );
528 $u->size( $upload->{size} );
529 $u->filename( $upload->{filename} );
532 $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
534 # support access to the filename as a normal param
535 my @filenames = map { $_->{filename} } @uploads;
536 # append, if there's already params with this name
537 if (exists $c->request->parameters->{$name}) {
538 if (ref $c->request->parameters->{$name} eq 'ARRAY') {
539 push @{ $c->request->parameters->{$name} }, @filenames;
542 $c->request->parameters->{$name} =
543 [ $c->request->parameters->{$name}, @filenames ];
547 $c->request->parameters->{$name} =
548 @filenames > 1 ? \@filenames : $filenames[0];
553 =head2 $self->prepare_write($c)
555 Abstract method. Implemented by the engines.
559 sub prepare_write { }
561 =head2 $self->read($c, [$maxlength])
566 my ( $self, $c, $maxlength ) = @_;
568 unless ( $self->{_prepared_read} ) {
569 $self->prepare_read($c);
570 $self->{_prepared_read} = 1;
573 my $remaining = $self->read_length - $self->read_position;
574 $maxlength ||= $CHUNKSIZE;
576 # Are we done reading?
577 if ( $remaining <= 0 ) {
578 $self->finalize_read($c);
582 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
583 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
585 $self->read_position( $self->read_position + $rc );
589 Catalyst::Exception->throw(
590 message => "Unknown error reading input: $!" );
594 =head2 $self->read_chunk($c, $buffer, $length)
596 Each engine inplements read_chunk as its preferred way of reading a chunk
603 =head2 $self->read_length
605 The length of input data to be read. This is obtained from the Content-Length
608 =head2 $self->read_position
610 The amount of input data that has already been read.
612 =head2 $self->run($c)
614 Start the engine. Implemented by the various engine classes.
620 =head2 $self->write($c, $buffer)
622 Writes the buffer to the client. Can only be called once for a request.
627 my ( $self, $c, $buffer ) = @_;
629 unless ( $self->{_prepared_write} ) {
630 $self->prepare_write($c);
631 $self->{_prepared_write} = 1;
634 print STDOUT $buffer;
637 =head2 $self->unescape_uri($uri)
639 Unescapes a given URI using the most efficient method available. Engines such
640 as Apache may implement this using Apache's C-based modules, for example.
647 my $e = URI::Escape::uri_unescape(@_);
653 =head2 $self->finalize_output
655 <obsolete>, see finalize_body
659 Sebastian Riedel, <sri@cpan.org>
661 Andy Grundman, <andy@hybridized.org>
665 This program is free software, you can redistribute it and/or modify it under
666 the same terms as Perl itself.