1 package Catalyst::Engine;
4 use base 'Class::Accessor::Fast';
12 # input position and length
13 __PACKAGE__->mk_accessors(qw/read_position read_length/);
16 use overload '""' => sub { return ref shift }, fallback => 1;
18 # Amount of data to read from input on each pass
19 our $CHUNKSIZE = 4096;
23 Catalyst::Engine - The Catalyst Engine
34 =head2 $self->finalize_body($c)
36 Finalize body. Prints the response output.
41 my ( $self, $c ) = @_;
42 if ( ref $c->response->body && $c->response->body->can('read') ) {
43 while ( !$c->response->body->eof() ) {
44 $c->response->body->read( my $buffer, $CHUNKSIZE );
45 last unless $self->write( $c, $buffer );
47 $c->response->body->close();
50 $self->write( $c, $c->response->body );
54 =head2 $self->finalize_cookies($c)
56 Create CGI::Cookies from $c->res->cookies, and set them as response headers.
60 sub finalize_cookies {
61 my ( $self, $c ) = @_;
64 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
66 my $cookie = CGI::Cookie->new(
68 -value => $cookie->{value},
69 -expires => $cookie->{expires},
70 -domain => $cookie->{domain},
71 -path => $cookie->{path},
72 -secure => $cookie->{secure} || 0
75 push @cookies, $cookie->as_string;
78 for my $cookie (@cookies) {
79 $c->res->headers->push_header( 'Set-Cookie' => $cookie );
83 =head2 $self->finalize_error($c)
85 Output an apropriate error message, called if there's an error in $c
86 after the dispatch has finished. Will output debug messages if Catalyst
87 is in debug mode, or a `please come back later` message otherwise.
92 my ( $self, $c ) = @_;
94 $c->res->content_type('text/html; charset=utf-8');
95 my $name = $c->config->{name} || 'Catalyst Application';
97 my ( $title, $error, $infos );
101 local $Data::Dumper::Terse = 1;
102 $error = join '', map {
103 '<p><code class="error">'
104 . encode_entities($_)
107 $error ||= 'No output';
108 $error = qq{<pre wrap="">$error</pre>};
109 $title = $name = "$name on Catalyst $Catalyst::VERSION";
110 $name = "<h1>$name</h1>";
112 # Don't show context in the dump
113 delete $c->req->{_context};
114 delete $c->res->{_context};
116 # Don't show body parser in the dump
117 delete $c->req->{_body};
119 # Don't show response header state in dump
120 delete $c->res->{_finalized_headers};
122 my $req = encode_entities Dumper $c->req;
123 my $res = encode_entities Dumper $c->res;
124 my $stash = encode_entities Dumper $c->stash;
128 for my $dump ( $c->dump_these ) {
129 my $name = $dump->[0];
130 my $value = encode_entities( Dumper $dump->[1] );
131 push @infos, sprintf <<"EOF", $name, $value;
132 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
134 <pre wrap="">%s</pre>
139 $infos = join "\n", @infos;
146 (en) Please come back later
147 (de) Bitte versuchen sie es spaeter nocheinmal
148 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
149 (no) Vennligst prov igjen senere
150 (dk) Venligst prov igen senere
151 (pl) Prosze sprobowac pozniej
156 $c->res->body( <<"" );
157 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
158 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
159 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
161 <meta http-equiv="Content-Language" content="en" />
162 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
163 <title>$title</title>
164 <script type="text/javascript">
166 function toggleDump (dumpElement) {
167 var e = document.getElementById( dumpElement );
168 if (e.style.display == "none") {
169 e.style.display = "";
172 e.style.display = "none";
177 <style type="text/css">
179 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
180 Tahoma, Arial, helvetica, sans-serif;
182 background-color: #eee;
186 :link, :link:hover, :visited, :visited:hover {
191 background-color: #ccc;
192 border: 1px solid #aaa;
195 -moz-border-radius: 10px;
198 background-color: #977;
199 border: 1px solid #755;
203 -moz-border-radius: 10px;
206 background-color: #797;
207 border: 1px solid #575;
211 -moz-border-radius: 10px;
214 background-color: #779;
215 border: 1px solid #557;
218 -moz-border-radius: 10px;
225 div.name h1, div.error p {
233 text-decoration: underline;
239 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
240 /* Browser specific (not valid) styles to make preformatted text wrap */
242 white-space: pre-wrap; /* css-3 */
243 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
244 white-space: -pre-wrap; /* Opera 4-6 */
245 white-space: -o-pre-wrap; /* Opera 7 */
246 word-wrap: break-word; /* Internet Explorer 5.5+ */
252 <div class="error">$error</div>
253 <div class="infos">$infos</div>
254 <div class="name">$name</div>
261 $c->res->{body} .= ( ' ' x 512 );
264 $c->res->status(500);
267 =head2 $self->finalize_headers($c)
269 Abstract method, allows engines to write headers to response
273 sub finalize_headers { }
275 =head2 $self->finalize_read($c)
280 my ( $self, $c ) = @_;
282 undef $self->{_prepared_read};
285 =head2 $self->finalize_uploads($c)
287 Clean up after uploads, deleting temp files.
291 sub finalize_uploads {
292 my ( $self, $c ) = @_;
294 if ( keys %{ $c->request->uploads } ) {
295 for my $key ( keys %{ $c->request->uploads } ) {
296 my $upload = $c->request->uploads->{$key};
297 unlink map { $_->tempname }
298 grep { -e $_->tempname }
299 ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
304 =head2 $self->prepare_body($c)
306 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
311 my ( $self, $c ) = @_;
313 $self->read_length( $c->request->header('Content-Length') || 0 );
314 my $type = $c->request->header('Content-Type');
316 unless ( $c->request->{_body} ) {
317 $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
320 if ( $self->read_length > 0 ) {
321 while ( my $buffer = $self->read($c) ) {
322 $c->prepare_body_chunk($buffer);
325 # paranoia against wrong Content-Length header
326 my $remaining = $self->read_length - $self->read_position;
327 if ($remaining > 0) {
328 $self->finalize_read($c);
329 Catalyst::Exception->throw("Wrong Content-Length value: ". $self->read_length);
334 =head2 $self->prepare_body_chunk($c)
336 Add a chunk to the request body.
340 sub prepare_body_chunk {
341 my ( $self, $c, $chunk ) = @_;
343 $c->request->{_body}->add($chunk);
346 =head2 $self->prepare_body_parameters($c)
348 Sets up parameters from body.
352 sub prepare_body_parameters {
353 my ( $self, $c ) = @_;
354 $c->request->body_parameters( $c->request->{_body}->param );
357 =head2 $self->prepare_connection($c)
359 Abstract method implemented in engines.
363 sub prepare_connection { }
365 =head2 $self->prepare_cookies($c)
367 Parse cookies from header. Sets a L<CGI::Cookie> object.
371 sub prepare_cookies {
372 my ( $self, $c ) = @_;
374 if ( my $header = $c->request->header('Cookie') ) {
375 $c->req->cookies( { CGI::Cookie->parse($header) } );
379 =head2 $self->prepare_headers($c)
383 sub prepare_headers { }
385 =head2 $self->prepare_parameters($c)
387 sets up parameters from query and post parameters.
391 sub prepare_parameters {
392 my ( $self, $c ) = @_;
394 # We copy, no references
395 while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
396 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
397 $c->request->parameters->{$name} = $param;
400 # Merge query and body parameters
401 while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
402 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
403 if ( my $old_param = $c->request->parameters->{$name} ) {
404 if ( ref $old_param eq 'ARRAY' ) {
405 push @{ $c->request->parameters->{$name} },
406 ref $param eq 'ARRAY' ? @$param : $param;
408 else { $c->request->parameters->{$name} = [ $old_param, $param ] }
410 else { $c->request->parameters->{$name} = $param }
414 =head2 $self->prepare_path($c)
416 abstract method, implemented by engines.
422 =head2 $self->prepare_request($c)
424 =head2 $self->prepare_query_parameters($c)
426 process the query string and extract query parameters.
430 sub prepare_query_parameters {
431 my ( $self, $c, $query_string ) = @_;
433 # replace semi-colons
434 $query_string =~ s/;/&/g;
436 my $u = URI->new( '', 'http' );
437 $u->query($query_string);
438 for my $key ( $u->query_param ) {
439 my @vals = $u->query_param($key);
440 $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
444 =head2 $self->prepare_read($c)
446 prepare to read from the engine.
451 my ( $self, $c ) = @_;
453 # Reset the read position
454 $self->read_position(0);
457 =head2 $self->prepare_request(@arguments)
459 Populate the context object from the request object.
463 sub prepare_request { }
465 =head2 $self->prepare_uploads($c)
469 sub prepare_uploads {
470 my ( $self, $c ) = @_;
471 my $uploads = $c->request->{_body}->upload;
472 for my $name ( keys %$uploads ) {
473 my $files = $uploads->{$name};
474 $files = ref $files eq 'ARRAY' ? $files : [$files];
476 for my $upload (@$files) {
477 my $u = Catalyst::Request::Upload->new;
478 $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
479 $u->type( $u->headers->content_type );
480 $u->tempname( $upload->{tempname} );
481 $u->size( $upload->{size} );
482 $u->filename( $upload->{filename} );
485 $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
487 # support access to the filename as a normal param
488 my @filenames = map { $_->{filename} } @uploads;
489 $c->request->parameters->{$name} =
490 @filenames > 1 ? \@filenames : $filenames[0];
494 =head2 $self->prepare_write($c)
496 Abstract method. Implemented by the engines.
500 sub prepare_write { }
502 =head2 $self->read($c, [$maxlength])
507 my ( $self, $c, $maxlength ) = @_;
509 unless ( $self->{_prepared_read} ) {
510 $self->prepare_read($c);
511 $self->{_prepared_read} = 1;
514 my $remaining = $self->read_length - $self->read_position;
515 $maxlength ||= $CHUNKSIZE;
517 # Are we done reading?
518 if ( $remaining <= 0 ) {
519 $self->finalize_read($c);
523 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
524 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
526 $self->read_position( $self->read_position + $rc );
530 Catalyst::Exception->throw(
531 message => "Unknown error reading input: $!" );
535 =head2 $self->read_chunk($c, $buffer, $length)
537 Each engine inplements read_chunk as its preferred way of reading a chunk
544 =head2 $self->read_length
546 The length of input data to be read. This is obtained from the Content-Length
549 =head2 $self->read_position
551 The amount of input data that has already been read.
553 =head2 $self->run($c)
555 Start the engine. Implemented by the various engine classes.
561 =head2 $self->write($c, $buffer)
563 Writes the buffer to the client. Can only be called once for a request.
568 my ( $self, $c, $buffer ) = @_;
570 unless ( $self->{_prepared_write} ) {
571 $self->prepare_write($c);
572 $self->{_prepared_write} = 1;
575 print STDOUT $buffer;
578 =head2 $self->finalize_output
580 <obsolete>, see finalize_body
584 Sebastian Riedel, <sri@cpan.org>
586 Andy Grundman, <andy@hybridized.org>
590 This program is free software, you can redistribute it and/or modify it under
591 the same terms as Perl itself.