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 (de) Bitte versuchen sie es spaeter nocheinmal
149 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
150 (no) Vennligst prov igjen senere
151 (dk) Venligst prov igen senere
152 (pl) Prosze sprobowac pozniej
157 $c->res->body( <<"" );
158 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
159 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
160 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
162 <meta http-equiv="Content-Language" content="en" />
163 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
164 <title>$title</title>
165 <script type="text/javascript">
167 function toggleDump (dumpElement) {
168 var e = document.getElementById( dumpElement );
169 if (e.style.display == "none") {
170 e.style.display = "";
173 e.style.display = "none";
178 <style type="text/css">
180 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
181 Tahoma, Arial, helvetica, sans-serif;
183 background-color: #eee;
187 :link, :link:hover, :visited, :visited:hover {
192 background-color: #ccc;
193 border: 1px solid #aaa;
196 -moz-border-radius: 10px;
199 background-color: #977;
200 border: 1px solid #755;
204 -moz-border-radius: 10px;
207 background-color: #797;
208 border: 1px solid #575;
212 -moz-border-radius: 10px;
215 background-color: #779;
216 border: 1px solid #557;
219 -moz-border-radius: 10px;
226 div.name h1, div.error p {
234 text-decoration: underline;
240 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
241 /* Browser specific (not valid) styles to make preformatted text wrap */
243 white-space: pre-wrap; /* css-3 */
244 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
245 white-space: -pre-wrap; /* Opera 4-6 */
246 white-space: -o-pre-wrap; /* Opera 7 */
247 word-wrap: break-word; /* Internet Explorer 5.5+ */
253 <div class="error">$error</div>
254 <div class="infos">$infos</div>
255 <div class="name">$name</div>
262 $c->res->{body} .= ( ' ' x 512 );
265 $c->res->status(500);
268 =head2 $self->finalize_headers($c)
270 Abstract method, allows engines to write headers to response
274 sub finalize_headers { }
276 =head2 $self->finalize_read($c)
281 my ( $self, $c ) = @_;
283 undef $self->{_prepared_read};
286 =head2 $self->finalize_uploads($c)
288 Clean up after uploads, deleting temp files.
292 sub finalize_uploads {
293 my ( $self, $c ) = @_;
295 if ( keys %{ $c->request->uploads } ) {
296 for my $key ( keys %{ $c->request->uploads } ) {
297 my $upload = $c->request->uploads->{$key};
298 unlink map { $_->tempname }
299 grep { -e $_->tempname }
300 ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
305 =head2 $self->prepare_body($c)
307 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
312 my ( $self, $c ) = @_;
314 $self->read_length( $c->request->header('Content-Length') || 0 );
315 my $type = $c->request->header('Content-Type');
317 unless ( $c->request->{_body} ) {
318 $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
319 $c->request->{_body}->{tmpdir} = $c->config->{uploadtmp} if exists $c->config->{uploadtmp};
322 if ( $self->read_length > 0 ) {
323 while ( my $buffer = $self->read($c) ) {
324 $c->prepare_body_chunk($buffer);
327 # paranoia against wrong Content-Length header
328 my $remaining = $self->read_length - $self->read_position;
329 if ($remaining > 0) {
330 $self->finalize_read($c);
331 Catalyst::Exception->throw("Wrong Content-Length value: ". $self->read_length);
336 =head2 $self->prepare_body_chunk($c)
338 Add a chunk to the request body.
342 sub prepare_body_chunk {
343 my ( $self, $c, $chunk ) = @_;
345 $c->request->{_body}->add($chunk);
348 =head2 $self->prepare_body_parameters($c)
350 Sets up parameters from body.
354 sub prepare_body_parameters {
355 my ( $self, $c ) = @_;
356 $c->request->body_parameters( $c->request->{_body}->param );
359 =head2 $self->prepare_connection($c)
361 Abstract method implemented in engines.
365 sub prepare_connection { }
367 =head2 $self->prepare_cookies($c)
369 Parse cookies from header. Sets a L<CGI::Cookie> object.
373 sub prepare_cookies {
374 my ( $self, $c ) = @_;
376 if ( my $header = $c->request->header('Cookie') ) {
377 $c->req->cookies( { CGI::Cookie->parse($header) } );
381 =head2 $self->prepare_headers($c)
385 sub prepare_headers { }
387 =head2 $self->prepare_parameters($c)
389 sets up parameters from query and post parameters.
393 sub prepare_parameters {
394 my ( $self, $c ) = @_;
396 # We copy, no references
397 while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
398 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
399 $c->request->parameters->{$name} = $param;
402 # Merge query and body parameters
403 while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
404 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
405 if ( my $old_param = $c->request->parameters->{$name} ) {
406 if ( ref $old_param eq 'ARRAY' ) {
407 push @{ $c->request->parameters->{$name} },
408 ref $param eq 'ARRAY' ? @$param : $param;
410 else { $c->request->parameters->{$name} = [ $old_param, $param ] }
412 else { $c->request->parameters->{$name} = $param }
416 =head2 $self->prepare_path($c)
418 abstract method, implemented by engines.
424 =head2 $self->prepare_request($c)
426 =head2 $self->prepare_query_parameters($c)
428 process the query string and extract query parameters.
432 sub prepare_query_parameters {
433 my ( $self, $c, $query_string ) = @_;
435 # replace semi-colons
436 $query_string =~ s/;/&/g;
438 my $u = URI->new( '', 'http' );
439 $u->query($query_string);
440 for my $key ( $u->query_param ) {
441 my @vals = $u->query_param($key);
442 $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
446 =head2 $self->prepare_read($c)
448 prepare to read from the engine.
453 my ( $self, $c ) = @_;
455 # Reset the read position
456 $self->read_position(0);
459 =head2 $self->prepare_request(@arguments)
461 Populate the context object from the request object.
465 sub prepare_request { }
467 =head2 $self->prepare_uploads($c)
471 sub prepare_uploads {
472 my ( $self, $c ) = @_;
473 my $uploads = $c->request->{_body}->upload;
474 for my $name ( keys %$uploads ) {
475 my $files = $uploads->{$name};
476 $files = ref $files eq 'ARRAY' ? $files : [$files];
478 for my $upload (@$files) {
479 my $u = Catalyst::Request::Upload->new;
480 $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
481 $u->type( $u->headers->content_type );
482 $u->tempname( $upload->{tempname} );
483 $u->size( $upload->{size} );
484 $u->filename( $upload->{filename} );
487 $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
489 # support access to the filename as a normal param
490 my @filenames = map { $_->{filename} } @uploads;
491 $c->request->parameters->{$name} =
492 @filenames > 1 ? \@filenames : $filenames[0];
496 =head2 $self->prepare_write($c)
498 Abstract method. Implemented by the engines.
502 sub prepare_write { }
504 =head2 $self->read($c, [$maxlength])
509 my ( $self, $c, $maxlength ) = @_;
511 unless ( $self->{_prepared_read} ) {
512 $self->prepare_read($c);
513 $self->{_prepared_read} = 1;
516 my $remaining = $self->read_length - $self->read_position;
517 $maxlength ||= $CHUNKSIZE;
519 # Are we done reading?
520 if ( $remaining <= 0 ) {
521 $self->finalize_read($c);
525 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
526 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
528 $self->read_position( $self->read_position + $rc );
532 Catalyst::Exception->throw(
533 message => "Unknown error reading input: $!" );
537 =head2 $self->read_chunk($c, $buffer, $length)
539 Each engine inplements read_chunk as its preferred way of reading a chunk
546 =head2 $self->read_length
548 The length of input data to be read. This is obtained from the Content-Length
551 =head2 $self->read_position
553 The amount of input data that has already been read.
555 =head2 $self->run($c)
557 Start the engine. Implemented by the various engine classes.
563 =head2 $self->write($c, $buffer)
565 Writes the buffer to the client. Can only be called once for a request.
570 my ( $self, $c, $buffer ) = @_;
572 unless ( $self->{_prepared_write} ) {
573 $self->prepare_write($c);
574 $self->{_prepared_write} = 1;
577 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.