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 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} || 'Catalyst Application';
98 my ( $title, $error, $infos );
102 local $Data::Dumper::Terse = 1;
103 $error = join '', map {
104 '<p><code class="error">'
105 . encode_entities($_)
108 $error ||= 'No output';
109 $error = qq{<pre wrap="">$error</pre>};
110 $title = $name = "$name on Catalyst $Catalyst::VERSION";
111 $name = "<h1>$name</h1>";
113 # Don't show context in the dump
114 delete $c->req->{_context};
115 delete $c->res->{_context};
117 # Don't show body parser in the dump
118 delete $c->req->{_body};
120 # Don't show response header state in dump
121 delete $c->res->{_finalized_headers};
123 my $req = encode_entities Dumper $c->req;
124 my $res = encode_entities Dumper $c->res;
125 my $stash = encode_entities Dumper $c->stash;
129 for my $dump ( $c->dump_these ) {
130 my $name = $dump->[0];
131 my $value = encode_entities( Dumper $dump->[1] );
132 push @infos, sprintf <<"EOF", $name, $value;
133 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
135 <pre wrap="">%s</pre>
140 $infos = join "\n", @infos;
147 (en) Please come back later
148 (fr) SVP veuillez revenir plus tard
149 (de) Bitte versuchen sie es spaeter nocheinmal
150 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
151 (no) Vennligst prov igjen senere
152 (dk) Venligst prov igen senere
153 (pl) Prosze sprobowac pozniej
158 $c->res->body( <<"" );
159 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
160 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
161 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
163 <meta http-equiv="Content-Language" content="en" />
164 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
165 <title>$title</title>
166 <script type="text/javascript">
168 function toggleDump (dumpElement) {
169 var e = document.getElementById( dumpElement );
170 if (e.style.display == "none") {
171 e.style.display = "";
174 e.style.display = "none";
179 <style type="text/css">
181 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
182 Tahoma, Arial, helvetica, sans-serif;
184 background-color: #eee;
188 :link, :link:hover, :visited, :visited:hover {
193 background-color: #ccc;
194 border: 1px solid #aaa;
197 -moz-border-radius: 10px;
200 background-color: #977;
201 border: 1px solid #755;
205 -moz-border-radius: 10px;
208 background-color: #797;
209 border: 1px solid #575;
213 -moz-border-radius: 10px;
216 background-color: #779;
217 border: 1px solid #557;
220 -moz-border-radius: 10px;
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} if exists $c->config->{uploadtmp};
323 if ( $self->read_length > 0 ) {
324 while ( my $buffer = $self->read($c) ) {
325 $c->prepare_body_chunk($buffer);
328 # paranoia against wrong Content-Length header
329 my $remaining = $self->read_length - $self->read_position;
330 if ($remaining > 0) {
331 $self->finalize_read($c);
332 Catalyst::Exception->throw("Wrong Content-Length value: ". $self->read_length);
337 =head2 $self->prepare_body_chunk($c)
339 Add a chunk to the request body.
343 sub prepare_body_chunk {
344 my ( $self, $c, $chunk ) = @_;
346 $c->request->{_body}->add($chunk);
349 =head2 $self->prepare_body_parameters($c)
351 Sets up parameters from body.
355 sub prepare_body_parameters {
356 my ( $self, $c ) = @_;
357 $c->request->body_parameters( $c->request->{_body}->param );
360 =head2 $self->prepare_connection($c)
362 Abstract method implemented in engines.
366 sub prepare_connection { }
368 =head2 $self->prepare_cookies($c)
370 Parse cookies from header. Sets a L<CGI::Cookie> object.
374 sub prepare_cookies {
375 my ( $self, $c ) = @_;
377 if ( my $header = $c->request->header('Cookie') ) {
378 $c->req->cookies( { CGI::Cookie->parse($header) } );
382 =head2 $self->prepare_headers($c)
386 sub prepare_headers { }
388 =head2 $self->prepare_parameters($c)
390 sets up parameters from query and post parameters.
394 sub prepare_parameters {
395 my ( $self, $c ) = @_;
397 # We copy, no references
398 while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
399 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
400 $c->request->parameters->{$name} = $param;
403 # Merge query and body parameters
404 while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
405 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
406 if ( my $old_param = $c->request->parameters->{$name} ) {
407 if ( ref $old_param eq 'ARRAY' ) {
408 push @{ $c->request->parameters->{$name} },
409 ref $param eq 'ARRAY' ? @$param : $param;
411 else { $c->request->parameters->{$name} = [ $old_param, $param ] }
413 else { $c->request->parameters->{$name} = $param }
417 =head2 $self->prepare_path($c)
419 abstract method, implemented by engines.
425 =head2 $self->prepare_request($c)
427 =head2 $self->prepare_query_parameters($c)
429 process the query string and extract query parameters.
433 sub prepare_query_parameters {
434 my ( $self, $c, $query_string ) = @_;
436 # replace semi-colons
437 $query_string =~ s/;/&/g;
439 my $u = URI->new( '', 'http' );
440 $u->query($query_string);
441 for my $key ( $u->query_param ) {
442 my @vals = $u->query_param($key);
443 $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
447 =head2 $self->prepare_read($c)
449 prepare to read from the engine.
454 my ( $self, $c ) = @_;
456 # Reset the read position
457 $self->read_position(0);
460 =head2 $self->prepare_request(@arguments)
462 Populate the context object from the request object.
466 sub prepare_request { }
468 =head2 $self->prepare_uploads($c)
472 sub prepare_uploads {
473 my ( $self, $c ) = @_;
474 my $uploads = $c->request->{_body}->upload;
475 for my $name ( keys %$uploads ) {
476 my $files = $uploads->{$name};
477 $files = ref $files eq 'ARRAY' ? $files : [$files];
479 for my $upload (@$files) {
480 my $u = Catalyst::Request::Upload->new;
481 $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
482 $u->type( $u->headers->content_type );
483 $u->tempname( $upload->{tempname} );
484 $u->size( $upload->{size} );
485 $u->filename( $upload->{filename} );
488 $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
490 # support access to the filename as a normal param
491 my @filenames = map { $_->{filename} } @uploads;
492 $c->request->parameters->{$name} =
493 @filenames > 1 ? \@filenames : $filenames[0];
497 =head2 $self->prepare_write($c)
499 Abstract method. Implemented by the engines.
503 sub prepare_write { }
505 =head2 $self->read($c, [$maxlength])
510 my ( $self, $c, $maxlength ) = @_;
512 unless ( $self->{_prepared_read} ) {
513 $self->prepare_read($c);
514 $self->{_prepared_read} = 1;
517 my $remaining = $self->read_length - $self->read_position;
518 $maxlength ||= $CHUNKSIZE;
520 # Are we done reading?
521 if ( $remaining <= 0 ) {
522 $self->finalize_read($c);
526 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
527 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
529 $self->read_position( $self->read_position + $rc );
533 Catalyst::Exception->throw(
534 message => "Unknown error reading input: $!" );
538 =head2 $self->read_chunk($c, $buffer, $length)
540 Each engine inplements read_chunk as its preferred way of reading a chunk
547 =head2 $self->read_length
549 The length of input data to be read. This is obtained from the Content-Length
552 =head2 $self->read_position
554 The amount of input data that has already been read.
556 =head2 $self->run($c)
558 Start the engine. Implemented by the various engine classes.
564 =head2 $self->write($c, $buffer)
566 Writes the buffer to the client. Can only be called once for a request.
571 my ( $self, $c, $buffer ) = @_;
573 unless ( $self->{_prepared_write} ) {
574 $self->prepare_write($c);
575 $self->{_prepared_write} = 1;
578 print STDOUT $buffer;
581 =head2 $self->finalize_output
583 <obsolete>, see finalize_body
587 Sebastian Riedel, <sri@cpan.org>
589 Andy Grundman, <andy@hybridized.org>
593 This program is free software, you can redistribute it and/or modify it under
594 the same terms as Perl itself.