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 ) = @_;
66 foreach my $name ( keys %{ $c->response->cookies } ) {
68 my $val = $c->response->cookies->{$name};
70 my $cookie = CGI::Cookie->new(
72 -value => $val->{value},
73 -expires => $val->{expires},
74 -domain => $val->{domain},
75 -path => $val->{path},
76 -secure => $val->{secure} || 0
79 push @cookies, $cookie->as_string;
82 for my $cookie (@cookies) {
83 $c->res->headers->push_header( 'Set-Cookie' => $cookie );
87 =head2 $self->finalize_error($c)
89 Output an apropriate error message, called if there's an error in $c
90 after the dispatch has finished. Will output debug messages if Catalyst
91 is in debug mode, or a `please come back later` message otherwise.
96 my ( $self, $c ) = @_;
98 $c->res->content_type('text/html; charset=utf-8');
99 my $name = $c->config->{name} || join(' ', split('::', ref $c));
101 my ( $title, $error, $infos );
105 $error = join '', map {
106 '<p><code class="error">'
107 . encode_entities($_)
110 $error ||= 'No output';
111 $error = qq{<pre wrap="">$error</pre>};
112 $title = $name = "$name on Catalyst $Catalyst::VERSION";
113 $name = "<h1>$name</h1>";
115 # Don't show context in the dump
116 delete $c->req->{_context};
117 delete $c->res->{_context};
119 # Don't show body parser in the dump
120 delete $c->req->{_body};
122 # Don't show response header state in dump
123 delete $c->res->{_finalized_headers};
127 for my $dump ( $c->dump_these ) {
128 my $name = $dump->[0];
129 my $value = encode_entities( dump( $dump->[1] ));
130 push @infos, sprintf <<"EOF", $name, $value;
131 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
133 <pre wrap="">%s</pre>
138 $infos = join "\n", @infos;
145 (en) Please come back later
146 (fr) SVP veuillez revenir plus tard
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;
197 background-color: #cce;
198 border: 1px solid #755;
204 background-color: #eee;
205 border: 1px solid #575;
211 background-color: #cce;
212 border: 1px solid #557;
221 div.name h1, div.error p {
229 text-decoration: underline;
235 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
236 /* Browser specific (not valid) styles to make preformatted text wrap */
238 white-space: pre-wrap; /* css-3 */
239 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
240 white-space: -pre-wrap; /* Opera 4-6 */
241 white-space: -o-pre-wrap; /* Opera 7 */
242 word-wrap: break-word; /* Internet Explorer 5.5+ */
248 <div class="error">$error</div>
249 <div class="infos">$infos</div>
250 <div class="name">$name</div>
257 $c->res->{body} .= ( ' ' x 512 );
260 $c->res->status(500);
263 =head2 $self->finalize_headers($c)
265 Abstract method, allows engines to write headers to response
269 sub finalize_headers { }
271 =head2 $self->finalize_read($c)
276 my ( $self, $c ) = @_;
278 undef $self->{_prepared_read};
281 =head2 $self->finalize_uploads($c)
283 Clean up after uploads, deleting temp files.
287 sub finalize_uploads {
288 my ( $self, $c ) = @_;
290 if ( keys %{ $c->request->uploads } ) {
291 for my $key ( keys %{ $c->request->uploads } ) {
292 my $upload = $c->request->uploads->{$key};
293 unlink map { $_->tempname }
294 grep { -e $_->tempname }
295 ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
300 =head2 $self->prepare_body($c)
302 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
307 my ( $self, $c ) = @_;
309 $self->read_length( $c->request->header('Content-Length') || 0 );
310 my $type = $c->request->header('Content-Type');
312 unless ( $c->request->{_body} ) {
313 $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
314 $c->request->{_body}->{tmpdir} = $c->config->{uploadtmp}
315 if exists $c->config->{uploadtmp};
318 if ( $self->read_length > 0 ) {
319 while ( my $buffer = $self->read($c) ) {
320 $c->prepare_body_chunk($buffer);
323 # paranoia against wrong Content-Length header
324 my $remaining = $self->read_length - $self->read_position;
325 if ( $remaining > 0 ) {
326 $self->finalize_read($c);
327 Catalyst::Exception->throw(
328 "Wrong Content-Length value: " . $self->read_length );
333 =head2 $self->prepare_body_chunk($c)
335 Add a chunk to the request body.
339 sub prepare_body_chunk {
340 my ( $self, $c, $chunk ) = @_;
342 $c->request->{_body}->add($chunk);
345 =head2 $self->prepare_body_parameters($c)
347 Sets up parameters from body.
351 sub prepare_body_parameters {
352 my ( $self, $c ) = @_;
353 $c->request->body_parameters( $c->request->{_body}->param );
356 =head2 $self->prepare_connection($c)
358 Abstract method implemented in engines.
362 sub prepare_connection { }
364 =head2 $self->prepare_cookies($c)
366 Parse cookies from header. Sets a L<CGI::Cookie> object.
370 sub prepare_cookies {
371 my ( $self, $c ) = @_;
373 if ( my $header = $c->request->header('Cookie') ) {
374 $c->req->cookies( { CGI::Cookie->parse($header) } );
378 =head2 $self->prepare_headers($c)
382 sub prepare_headers { }
384 =head2 $self->prepare_parameters($c)
386 sets up parameters from query and post parameters.
390 sub prepare_parameters {
391 my ( $self, $c ) = @_;
393 # We copy, no references
394 foreach my $name ( keys %{ $c->request->query_parameters } ) {
395 my $param = $c->request->query_parameters->{$name};
396 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
397 $c->request->parameters->{$name} = $param;
400 # Merge query and body parameters
401 foreach my $name ( keys %{ $c->request->body_parameters } ) {
402 my $param = $c->request->body_parameters->{$name};
403 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
404 if ( my $old_param = $c->request->parameters->{$name} ) {
405 if ( ref $old_param eq 'ARRAY' ) {
406 push @{ $c->request->parameters->{$name} },
407 ref $param eq 'ARRAY' ? @$param : $param;
409 else { $c->request->parameters->{$name} = [ $old_param, $param ] }
411 else { $c->request->parameters->{$name} = $param }
415 =head2 $self->prepare_path($c)
417 abstract method, implemented by engines.
423 =head2 $self->prepare_request($c)
425 =head2 $self->prepare_query_parameters($c)
427 process the query string and extract query parameters.
431 sub prepare_query_parameters {
432 my ( $self, $c, $query_string ) = @_;
434 # replace semi-colons
435 $query_string =~ s/;/&/g;
437 my $u = URI->new( '', 'http' );
438 $u->query($query_string);
439 for my $key ( $u->query_param ) {
440 my @vals = $u->query_param($key);
441 $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
445 =head2 $self->prepare_read($c)
447 prepare to read from the engine.
452 my ( $self, $c ) = @_;
454 # Reset the read position
455 $self->read_position(0);
458 =head2 $self->prepare_request(@arguments)
460 Populate the context object from the request object.
464 sub prepare_request { }
466 =head2 $self->prepare_uploads($c)
470 sub prepare_uploads {
471 my ( $self, $c ) = @_;
472 my $uploads = $c->request->{_body}->upload;
473 for my $name ( keys %$uploads ) {
474 my $files = $uploads->{$name};
475 $files = ref $files eq 'ARRAY' ? $files : [$files];
477 for my $upload (@$files) {
478 my $u = Catalyst::Request::Upload->new;
479 $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
480 $u->type( $u->headers->content_type );
481 $u->tempname( $upload->{tempname} );
482 $u->size( $upload->{size} );
483 $u->filename( $upload->{filename} );
486 $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
488 # support access to the filename as a normal param
489 my @filenames = map { $_->{filename} } @uploads;
490 $c->request->parameters->{$name} =
491 @filenames > 1 ? \@filenames : $filenames[0];
495 =head2 $self->prepare_write($c)
497 Abstract method. Implemented by the engines.
501 sub prepare_write { }
503 =head2 $self->read($c, [$maxlength])
508 my ( $self, $c, $maxlength ) = @_;
510 unless ( $self->{_prepared_read} ) {
511 $self->prepare_read($c);
512 $self->{_prepared_read} = 1;
515 my $remaining = $self->read_length - $self->read_position;
516 $maxlength ||= $CHUNKSIZE;
518 # Are we done reading?
519 if ( $remaining <= 0 ) {
520 $self->finalize_read($c);
524 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
525 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
527 $self->read_position( $self->read_position + $rc );
531 Catalyst::Exception->throw(
532 message => "Unknown error reading input: $!" );
536 =head2 $self->read_chunk($c, $buffer, $length)
538 Each engine inplements read_chunk as its preferred way of reading a chunk
545 =head2 $self->read_length
547 The length of input data to be read. This is obtained from the Content-Length
550 =head2 $self->read_position
552 The amount of input data that has already been read.
554 =head2 $self->run($c)
556 Start the engine. Implemented by the various engine classes.
562 =head2 $self->write($c, $buffer)
564 Writes the buffer to the client. Can only be called once for a request.
569 my ( $self, $c, $buffer ) = @_;
571 unless ( $self->{_prepared_write} ) {
572 $self->prepare_write($c);
573 $self->{_prepared_write} = 1;
576 print STDOUT $buffer;
580 =head2 $self->finalize_output
582 <obsolete>, see finalize_body
586 Sebastian Riedel, <sri@cpan.org>
588 Andy Grundman, <andy@hybridized.org>
592 This program is free software, you can redistribute it and/or modify it under
593 the same terms as Perl itself.