1 package Catalyst::Engine;
4 use base 'Class::Accessor::Fast';
5 use CGI::Simple::Cookie;
6 use Data::Dump qw/dump/;
13 # input position and length
14 __PACKAGE__->mk_accessors(qw/read_position read_length/);
17 use overload '""' => sub { return ref shift }, fallback => 1;
19 # Amount of data to read from input on each pass
20 our $CHUNKSIZE = 4096;
24 Catalyst::Engine - The Catalyst Engine
35 =head2 $self->finalize_body($c)
37 Finalize body. Prints the response output.
42 my ( $self, $c ) = @_;
43 my $body = $c->response->body;
44 if ( ref $body && ( $body->can('read') || ref($body) eq 'GLOB' ) ) {
45 while ( !eof $body ) {
46 read $body, my ($buffer), $CHUNKSIZE;
47 last unless $self->write( $c, $buffer );
52 $self->write( $c, $body );
56 =head2 $self->finalize_cookies($c)
58 Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
63 sub finalize_cookies {
64 my ( $self, $c ) = @_;
68 foreach my $name ( keys %{ $c->response->cookies } ) {
70 my $val = $c->response->cookies->{$name};
73 Scalar::Util::blessed($val)
75 : CGI::Simple::Cookie->new(
77 -value => $val->{value},
78 -expires => $val->{expires},
79 -domain => $val->{domain},
80 -path => $val->{path},
81 -secure => $val->{secure} || 0
85 push @cookies, $cookie->as_string;
88 for my $cookie (@cookies) {
89 $c->res->headers->push_header( 'Set-Cookie' => $cookie );
93 =head2 $self->finalize_error($c)
95 Output an apropriate error message, called if there's an error in $c
96 after the dispatch has finished. Will output debug messages if Catalyst
97 is in debug mode, or a `please come back later` message otherwise.
102 my ( $self, $c ) = @_;
104 $c->res->content_type('text/html; charset=utf-8');
105 my $name = $c->config->{name} || join(' ', split('::', ref $c));
107 my ( $title, $error, $infos );
111 $error = join '', map {
112 '<p><code class="error">'
113 . encode_entities($_)
116 $error ||= 'No output';
117 $error = qq{<pre wrap="">$error</pre>};
118 $title = $name = "$name on Catalyst $Catalyst::VERSION";
119 $name = "<h1>$name</h1>";
121 # Don't show context in the dump
122 delete $c->req->{_context};
123 delete $c->res->{_context};
125 # Don't show body parser in the dump
126 delete $c->req->{_body};
128 # Don't show response header state in dump
129 delete $c->res->{_finalized_headers};
133 for my $dump ( $c->dump_these ) {
134 my $name = $dump->[0];
135 my $value = encode_entities( dump( $dump->[1] ));
136 push @infos, sprintf <<"EOF", $name, $value;
137 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
139 <pre wrap="">%s</pre>
144 $infos = join "\n", @infos;
151 (en) Please come back later
152 (fr) SVP veuillez revenir plus tard
153 (de) Bitte versuchen sie es spaeter nocheinmal
154 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
155 (no) Vennligst prov igjen senere
156 (dk) Venligst prov igen senere
157 (pl) Prosze sprobowac pozniej
162 $c->res->body( <<"" );
163 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
164 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
165 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
167 <meta http-equiv="Content-Language" content="en" />
168 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
169 <title>$title</title>
170 <script type="text/javascript">
172 function toggleDump (dumpElement) {
173 var e = document.getElementById( dumpElement );
174 if (e.style.display == "none") {
175 e.style.display = "";
178 e.style.display = "none";
183 <style type="text/css">
185 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
186 Tahoma, Arial, helvetica, sans-serif;
188 background-color: #eee;
192 :link, :link:hover, :visited, :visited:hover {
197 background-color: #ccc;
198 border: 1px solid #aaa;
203 background-color: #cce;
204 border: 1px solid #755;
210 background-color: #eee;
211 border: 1px solid #575;
217 background-color: #cce;
218 border: 1px solid #557;
227 div.name h1, div.error p {
235 text-decoration: underline;
241 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
242 /* Browser specific (not valid) styles to make preformatted text wrap */
244 white-space: pre-wrap; /* css-3 */
245 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
246 white-space: -pre-wrap; /* Opera 4-6 */
247 white-space: -o-pre-wrap; /* Opera 7 */
248 word-wrap: break-word; /* Internet Explorer 5.5+ */
254 <div class="error">$error</div>
255 <div class="infos">$infos</div>
256 <div class="name">$name</div>
263 $c->res->{body} .= ( ' ' x 512 );
266 $c->res->status(500);
269 =head2 $self->finalize_headers($c)
271 Abstract method, allows engines to write headers to response
275 sub finalize_headers { }
277 =head2 $self->finalize_read($c)
282 my ( $self, $c ) = @_;
284 undef $self->{_prepared_read};
287 =head2 $self->finalize_uploads($c)
289 Clean up after uploads, deleting temp files.
293 sub finalize_uploads {
294 my ( $self, $c ) = @_;
296 if ( keys %{ $c->request->uploads } ) {
297 for my $key ( keys %{ $c->request->uploads } ) {
298 my $upload = $c->request->uploads->{$key};
299 unlink map { $_->tempname }
300 grep { -e $_->tempname }
301 ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
306 =head2 $self->prepare_body($c)
308 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
313 my ( $self, $c ) = @_;
315 $self->read_length( $c->request->header('Content-Length') || 0 );
316 my $type = $c->request->header('Content-Type');
318 unless ( $c->request->{_body} ) {
319 $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
320 $c->request->{_body}->{tmpdir} = $c->config->{uploadtmp}
321 if exists $c->config->{uploadtmp};
324 if ( $self->read_length > 0 ) {
325 while ( my $buffer = $self->read($c) ) {
326 $c->prepare_body_chunk($buffer);
329 # paranoia against wrong Content-Length header
330 my $remaining = $self->read_length - $self->read_position;
331 if ( $remaining > 0 ) {
332 $self->finalize_read($c);
333 Catalyst::Exception->throw(
334 "Wrong Content-Length value: " . $self->read_length );
339 =head2 $self->prepare_body_chunk($c)
341 Add a chunk to the request body.
345 sub prepare_body_chunk {
346 my ( $self, $c, $chunk ) = @_;
348 $c->request->{_body}->add($chunk);
351 =head2 $self->prepare_body_parameters($c)
353 Sets up parameters from body.
357 sub prepare_body_parameters {
358 my ( $self, $c ) = @_;
359 $c->request->body_parameters( $c->request->{_body}->param );
362 =head2 $self->prepare_connection($c)
364 Abstract method implemented in engines.
368 sub prepare_connection { }
370 =head2 $self->prepare_cookies($c)
372 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
376 sub prepare_cookies {
377 my ( $self, $c ) = @_;
379 if ( my $header = $c->request->header('Cookie') ) {
380 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
384 =head2 $self->prepare_headers($c)
388 sub prepare_headers { }
390 =head2 $self->prepare_parameters($c)
392 sets up parameters from query and post parameters.
396 sub prepare_parameters {
397 my ( $self, $c ) = @_;
399 # We copy, no references
400 foreach my $name ( keys %{ $c->request->query_parameters } ) {
401 my $param = $c->request->query_parameters->{$name};
402 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
403 $c->request->parameters->{$name} = $param;
406 # Merge query and body parameters
407 foreach my $name ( keys %{ $c->request->body_parameters } ) {
408 my $param = $c->request->body_parameters->{$name};
409 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
410 if ( my $old_param = $c->request->parameters->{$name} ) {
411 if ( ref $old_param eq 'ARRAY' ) {
412 push @{ $c->request->parameters->{$name} },
413 ref $param eq 'ARRAY' ? @$param : $param;
415 else { $c->request->parameters->{$name} = [ $old_param, $param ] }
417 else { $c->request->parameters->{$name} = $param }
421 =head2 $self->prepare_path($c)
423 abstract method, implemented by engines.
429 =head2 $self->prepare_request($c)
431 =head2 $self->prepare_query_parameters($c)
433 process the query string and extract query parameters.
437 sub prepare_query_parameters {
438 my ( $self, $c, $query_string ) = @_;
440 # replace semi-colons
441 $query_string =~ s/;/&/g;
443 my $u = URI->new( '', 'http' );
444 $u->query($query_string);
445 for my $key ( $u->query_param ) {
446 my @vals = $u->query_param($key);
447 $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
451 =head2 $self->prepare_read($c)
453 prepare to read from the engine.
458 my ( $self, $c ) = @_;
460 # Reset the read position
461 $self->read_position(0);
464 =head2 $self->prepare_request(@arguments)
466 Populate the context object from the request object.
470 sub prepare_request { }
472 =head2 $self->prepare_uploads($c)
476 sub prepare_uploads {
477 my ( $self, $c ) = @_;
478 my $uploads = $c->request->{_body}->upload;
479 for my $name ( keys %$uploads ) {
480 my $files = $uploads->{$name};
481 $files = ref $files eq 'ARRAY' ? $files : [$files];
483 for my $upload (@$files) {
484 my $u = Catalyst::Request::Upload->new;
485 $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
486 $u->type( $u->headers->content_type );
487 $u->tempname( $upload->{tempname} );
488 $u->size( $upload->{size} );
489 $u->filename( $upload->{filename} );
492 $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
494 # support access to the filename as a normal param
495 my @filenames = map { $_->{filename} } @uploads;
496 $c->request->parameters->{$name} =
497 @filenames > 1 ? \@filenames : $filenames[0];
501 =head2 $self->prepare_write($c)
503 Abstract method. Implemented by the engines.
507 sub prepare_write { }
509 =head2 $self->read($c, [$maxlength])
514 my ( $self, $c, $maxlength ) = @_;
516 unless ( $self->{_prepared_read} ) {
517 $self->prepare_read($c);
518 $self->{_prepared_read} = 1;
521 my $remaining = $self->read_length - $self->read_position;
522 $maxlength ||= $CHUNKSIZE;
524 # Are we done reading?
525 if ( $remaining <= 0 ) {
526 $self->finalize_read($c);
530 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
531 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
533 $self->read_position( $self->read_position + $rc );
537 Catalyst::Exception->throw(
538 message => "Unknown error reading input: $!" );
542 =head2 $self->read_chunk($c, $buffer, $length)
544 Each engine inplements read_chunk as its preferred way of reading a chunk
551 =head2 $self->read_length
553 The length of input data to be read. This is obtained from the Content-Length
556 =head2 $self->read_position
558 The amount of input data that has already been read.
560 =head2 $self->run($c)
562 Start the engine. Implemented by the various engine classes.
568 =head2 $self->write($c, $buffer)
570 Writes the buffer to the client. Can only be called once for a request.
575 my ( $self, $c, $buffer ) = @_;
577 unless ( $self->{_prepared_write} ) {
578 $self->prepare_write($c);
579 $self->{_prepared_write} = 1;
582 print STDOUT $buffer;
586 =head2 $self->finalize_output
588 <obsolete>, see finalize_body
592 Sebastian Riedel, <sri@cpan.org>
594 Andy Grundman, <andy@hybridized.org>
598 This program is free software, you can redistribute it and/or modify it under
599 the same terms as Perl itself.