1 package Catalyst::Engine;
4 use base 'Class::Accessor::Fast';
6 use Data::Dump qw/dump/;
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 my $body = $c->response->body;
43 if ( ref $body && ( $body->can('read') || ref($body) eq 'GLOB' ) ) {
44 while ( !eof $body ) {
45 read $body, my ($buffer), $CHUNKSIZE;
46 last unless $self->write( $c, $buffer );
51 $self->write( $c, $body );
55 =head2 $self->finalize_cookies($c)
57 Create CGI::Cookies from $c->res->cookies, and set them as response headers.
61 sub finalize_cookies {
62 my ( $self, $c ) = @_;
65 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
67 my $cookie = CGI::Cookie->new(
69 -value => $cookie->{value},
70 -expires => $cookie->{expires},
71 -domain => $cookie->{domain},
72 -path => $cookie->{path},
73 -secure => $cookie->{secure} || 0
76 push @cookies, $cookie->as_string;
79 for my $cookie (@cookies) {
80 $c->res->headers->push_header( 'Set-Cookie' => $cookie );
84 =head2 $self->finalize_error($c)
86 Output an apropriate error message, called if there's an error in $c
87 after the dispatch has finished. Will output debug messages if Catalyst
88 is in debug mode, or a `please come back later` message otherwise.
93 my ( $self, $c ) = @_;
95 $c->res->content_type('text/html; charset=utf-8');
96 my $name = $c->config->{name} || join(' ', split('::', ref $c));
98 my ( $title, $error, $infos );
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};
124 for my $dump ( $c->dump_these ) {
125 my $name = $dump->[0];
126 my $value = encode_entities( dump( $dump->[1] ));
127 push @infos, sprintf <<"EOF", $name, $value;
128 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
130 <pre wrap="">%s</pre>
135 $infos = join "\n", @infos;
142 (en) Please come back later
143 (fr) SVP veuillez revenir plus tard
144 (de) Bitte versuchen sie es spaeter nocheinmal
145 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
146 (no) Vennligst prov igjen senere
147 (dk) Venligst prov igen senere
148 (pl) Prosze sprobowac pozniej
153 $c->res->body( <<"" );
154 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
155 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
156 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
158 <meta http-equiv="Content-Language" content="en" />
159 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
160 <title>$title</title>
161 <script type="text/javascript">
163 function toggleDump (dumpElement) {
164 var e = document.getElementById( dumpElement );
165 if (e.style.display == "none") {
166 e.style.display = "";
169 e.style.display = "none";
174 <style type="text/css">
176 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
177 Tahoma, Arial, helvetica, sans-serif;
179 background-color: #eee;
183 :link, :link:hover, :visited, :visited:hover {
188 background-color: #ccc;
189 border: 1px solid #aaa;
194 background-color: #cce;
195 border: 1px solid #755;
201 background-color: #eee;
202 border: 1px solid #575;
208 background-color: #cce;
209 border: 1px solid #557;
218 div.name h1, div.error p {
226 text-decoration: underline;
232 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
233 /* Browser specific (not valid) styles to make preformatted text wrap */
235 white-space: pre-wrap; /* css-3 */
236 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
237 white-space: -pre-wrap; /* Opera 4-6 */
238 white-space: -o-pre-wrap; /* Opera 7 */
239 word-wrap: break-word; /* Internet Explorer 5.5+ */
245 <div class="error">$error</div>
246 <div class="infos">$infos</div>
247 <div class="name">$name</div>
254 $c->res->{body} .= ( ' ' x 512 );
257 $c->res->status(500);
260 =head2 $self->finalize_headers($c)
262 Abstract method, allows engines to write headers to response
266 sub finalize_headers { }
268 =head2 $self->finalize_read($c)
273 my ( $self, $c ) = @_;
275 undef $self->{_prepared_read};
278 =head2 $self->finalize_uploads($c)
280 Clean up after uploads, deleting temp files.
284 sub finalize_uploads {
285 my ( $self, $c ) = @_;
287 if ( keys %{ $c->request->uploads } ) {
288 for my $key ( keys %{ $c->request->uploads } ) {
289 my $upload = $c->request->uploads->{$key};
290 unlink map { $_->tempname }
291 grep { -e $_->tempname }
292 ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
297 =head2 $self->prepare_body($c)
299 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
304 my ( $self, $c ) = @_;
306 $self->read_length( $c->request->header('Content-Length') || 0 );
307 my $type = $c->request->header('Content-Type');
309 unless ( $c->request->{_body} ) {
310 $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
311 $c->request->{_body}->{tmpdir} = $c->config->{uploadtmp}
312 if exists $c->config->{uploadtmp};
315 if ( $self->read_length > 0 ) {
316 while ( my $buffer = $self->read($c) ) {
317 $c->prepare_body_chunk($buffer);
320 # paranoia against wrong Content-Length header
321 my $remaining = $self->read_length - $self->read_position;
322 if ( $remaining > 0 ) {
323 $self->finalize_read($c);
324 Catalyst::Exception->throw(
325 "Wrong Content-Length value: " . $self->read_length );
330 =head2 $self->prepare_body_chunk($c)
332 Add a chunk to the request body.
336 sub prepare_body_chunk {
337 my ( $self, $c, $chunk ) = @_;
339 $c->request->{_body}->add($chunk);
342 =head2 $self->prepare_body_parameters($c)
344 Sets up parameters from body.
348 sub prepare_body_parameters {
349 my ( $self, $c ) = @_;
350 $c->request->body_parameters( $c->request->{_body}->param );
353 =head2 $self->prepare_connection($c)
355 Abstract method implemented in engines.
359 sub prepare_connection { }
361 =head2 $self->prepare_cookies($c)
363 Parse cookies from header. Sets a L<CGI::Cookie> object.
367 sub prepare_cookies {
368 my ( $self, $c ) = @_;
370 if ( my $header = $c->request->header('Cookie') ) {
371 $c->req->cookies( { CGI::Cookie->parse($header) } );
375 =head2 $self->prepare_headers($c)
379 sub prepare_headers { }
381 =head2 $self->prepare_parameters($c)
383 sets up parameters from query and post parameters.
387 sub prepare_parameters {
388 my ( $self, $c ) = @_;
390 # We copy, no references
391 while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
392 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
393 $c->request->parameters->{$name} = $param;
396 # Merge query and body parameters
397 while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
398 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
399 if ( my $old_param = $c->request->parameters->{$name} ) {
400 if ( ref $old_param eq 'ARRAY' ) {
401 push @{ $c->request->parameters->{$name} },
402 ref $param eq 'ARRAY' ? @$param : $param;
404 else { $c->request->parameters->{$name} = [ $old_param, $param ] }
406 else { $c->request->parameters->{$name} = $param }
410 =head2 $self->prepare_path($c)
412 abstract method, implemented by engines.
418 =head2 $self->prepare_request($c)
420 =head2 $self->prepare_query_parameters($c)
422 process the query string and extract query parameters.
426 sub prepare_query_parameters {
427 my ( $self, $c, $query_string ) = @_;
429 # replace semi-colons
430 $query_string =~ s/;/&/g;
432 my $u = URI->new( '', 'http' );
433 $u->query($query_string);
434 for my $key ( $u->query_param ) {
435 my @vals = $u->query_param($key);
436 $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
440 =head2 $self->prepare_read($c)
442 prepare to read from the engine.
447 my ( $self, $c ) = @_;
449 # Reset the read position
450 $self->read_position(0);
453 =head2 $self->prepare_request(@arguments)
455 Populate the context object from the request object.
459 sub prepare_request { }
461 =head2 $self->prepare_uploads($c)
465 sub prepare_uploads {
466 my ( $self, $c ) = @_;
467 my $uploads = $c->request->{_body}->upload;
468 for my $name ( keys %$uploads ) {
469 my $files = $uploads->{$name};
470 $files = ref $files eq 'ARRAY' ? $files : [$files];
472 for my $upload (@$files) {
473 my $u = Catalyst::Request::Upload->new;
474 $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
475 $u->type( $u->headers->content_type );
476 $u->tempname( $upload->{tempname} );
477 $u->size( $upload->{size} );
478 $u->filename( $upload->{filename} );
481 $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
483 # support access to the filename as a normal param
484 my @filenames = map { $_->{filename} } @uploads;
485 $c->request->parameters->{$name} =
486 @filenames > 1 ? \@filenames : $filenames[0];
490 =head2 $self->prepare_write($c)
492 Abstract method. Implemented by the engines.
496 sub prepare_write { }
498 =head2 $self->read($c, [$maxlength])
503 my ( $self, $c, $maxlength ) = @_;
505 unless ( $self->{_prepared_read} ) {
506 $self->prepare_read($c);
507 $self->{_prepared_read} = 1;
510 my $remaining = $self->read_length - $self->read_position;
511 $maxlength ||= $CHUNKSIZE;
513 # Are we done reading?
514 if ( $remaining <= 0 ) {
515 $self->finalize_read($c);
519 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
520 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
522 $self->read_position( $self->read_position + $rc );
526 Catalyst::Exception->throw(
527 message => "Unknown error reading input: $!" );
531 =head2 $self->read_chunk($c, $buffer, $length)
533 Each engine inplements read_chunk as its preferred way of reading a chunk
540 =head2 $self->read_length
542 The length of input data to be read. This is obtained from the Content-Length
545 =head2 $self->read_position
547 The amount of input data that has already been read.
549 =head2 $self->run($c)
551 Start the engine. Implemented by the various engine classes.
557 =head2 $self->write($c, $buffer)
559 Writes the buffer to the client. Can only be called once for a request.
564 my ( $self, $c, $buffer ) = @_;
566 unless ( $self->{_prepared_write} ) {
567 $self->prepare_write($c);
568 $self->{_prepared_write} = 1;
571 print STDOUT $buffer;
575 =head2 $self->finalize_output
577 <obsolete>, see finalize_body
581 Sebastian Riedel, <sri@cpan.org>
583 Andy Grundman, <andy@hybridized.org>
587 This program is free software, you can redistribute it and/or modify it under
588 the same terms as Perl itself.