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
33 =head2 $self->finalize_output
35 <obsolete>, see finalize_body
37 =head2 $self->finalize_body($c)
39 Finalize body. Prints the response output.
44 my ( $self, $c ) = @_;
45 if ( ref $c->response->body && $c->response->body->can('read') ) {
46 while ( !$c->response->body->eof() ) {
47 $c->response->body->read( my $buffer, $CHUNKSIZE );
48 last unless $self->write( $c, $buffer );
50 $c->response->body->close();
53 $self->write( $c, $c->response->body );
57 =head2 $self->finalize_cookies($c)
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)
89 my ( $self, $c ) = @_;
91 $c->res->content_type('text/html; charset=utf-8');
92 my $name = $c->config->{name} || 'Catalyst Application';
94 my ( $title, $error, $infos );
98 local $Data::Dumper::Terse = 1;
99 $error = join '', map {
100 '<p><code class="error">'
101 . encode_entities($_)
104 $error ||= 'No output';
105 $error = qq{<pre wrap="">$error</pre>};
106 $title = $name = "$name on Catalyst $Catalyst::VERSION";
107 $name = "<h1>$name</h1>";
109 # Don't show context in the dump
110 delete $c->req->{_context};
111 delete $c->res->{_context};
113 # Don't show body parser in the dump
114 delete $c->req->{_body};
116 # Don't show response header state in dump
117 delete $c->res->{_finalized_headers};
119 my $req = encode_entities Dumper $c->req;
120 my $res = encode_entities Dumper $c->res;
121 my $stash = encode_entities Dumper $c->stash;
125 for my $dump ( $c->dump_these ) {
126 my $name = $dump->[0];
127 my $value = encode_entities( Dumper $dump->[1] );
128 push @infos, sprintf <<"EOF", $name, $value;
129 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
131 <pre wrap="">%s</pre>
136 $infos = join "\n", @infos;
143 (en) Please come back later
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;
192 -moz-border-radius: 10px;
195 background-color: #977;
196 border: 1px solid #755;
200 -moz-border-radius: 10px;
203 background-color: #797;
204 border: 1px solid #575;
208 -moz-border-radius: 10px;
211 background-color: #779;
212 border: 1px solid #557;
215 -moz-border-radius: 10px;
222 div.name h1, div.error p {
230 text-decoration: underline;
236 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
237 /* Browser specific (not valid) styles to make preformatted text wrap */
239 white-space: pre-wrap; /* css-3 */
240 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
241 white-space: -pre-wrap; /* Opera 4-6 */
242 white-space: -o-pre-wrap; /* Opera 7 */
243 word-wrap: break-word; /* Internet Explorer 5.5+ */
249 <div class="error">$error</div>
250 <div class="infos">$infos</div>
251 <div class="name">$name</div>
258 $c->res->{body} .= ( ' ' x 512 );
261 $c->res->status(500);
264 =head2 $self->finalize_headers($c)
268 sub finalize_headers { }
270 =head2 $self->finalize_read($c)
275 my ( $self, $c ) = @_;
277 undef $self->{_prepared_read};
280 =head2 $self->finalize_uploads($c)
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)
302 my ( $self, $c ) = @_;
304 $self->read_length( $c->request->header('Content-Length') || 0 );
305 my $type = $c->request->header('Content-Type');
307 unless ( $c->request->{_body} ) {
308 $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
311 if ( $self->read_length > 0 ) {
312 while ( my $buffer = $self->read($c) ) {
313 $c->prepare_body_chunk($buffer);
316 # paranoia against wrong Content-Length header
317 my $remaining = $self->read_length - $self->read_position;
318 if ($remaining > 0) {
319 $self->finalize_read($c);
320 Catalyst::Exception->throw("Wrong Content-Length value: ". $self->read_length);
325 =head2 $self->prepare_body_chunk($c)
329 sub prepare_body_chunk {
330 my ( $self, $c, $chunk ) = @_;
332 $c->request->{_body}->add($chunk);
335 =head2 $self->prepare_body_parameters($c)
339 sub prepare_body_parameters {
340 my ( $self, $c ) = @_;
341 $c->request->body_parameters( $c->request->{_body}->param );
344 =head2 $self->prepare_connection($c)
348 sub prepare_connection { }
350 =head2 $self->prepare_cookies($c)
354 sub prepare_cookies {
355 my ( $self, $c ) = @_;
357 if ( my $header = $c->request->header('Cookie') ) {
358 $c->req->cookies( { CGI::Cookie->parse($header) } );
362 =head2 $self->prepare_headers($c)
366 sub prepare_headers { }
368 =head2 $self->prepare_parameters($c)
372 sub prepare_parameters {
373 my ( $self, $c ) = @_;
375 # We copy, no references
376 while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
377 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
378 $c->request->parameters->{$name} = $param;
381 # Merge query and body parameters
382 while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
383 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
384 if ( my $old_param = $c->request->parameters->{$name} ) {
385 if ( ref $old_param eq 'ARRAY' ) {
386 push @{ $c->request->parameters->{$name} },
387 ref $param eq 'ARRAY' ? @$param : $param;
389 else { $c->request->parameters->{$name} = [ $old_param, $param ] }
391 else { $c->request->parameters->{$name} = $param }
395 =head2 $self->prepare_path($c)
401 =head2 $self->prepare_request($c)
403 =head2 $self->prepare_query_parameters($c)
407 sub prepare_query_parameters {
408 my ( $self, $c, $query_string ) = @_;
410 # replace semi-colons
411 $query_string =~ s/;/&/g;
413 my $u = URI->new( '', 'http' );
414 $u->query($query_string);
415 for my $key ( $u->query_param ) {
416 my @vals = $u->query_param($key);
417 $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
421 =head2 $self->prepare_read($c)
426 my ( $self, $c ) = @_;
428 # Reset the read position
429 $self->read_position(0);
432 =head2 $self->prepare_request(@arguments)
436 sub prepare_request { }
438 =head2 $self->prepare_uploads($c)
442 sub prepare_uploads {
443 my ( $self, $c ) = @_;
444 my $uploads = $c->request->{_body}->upload;
445 for my $name ( keys %$uploads ) {
446 my $files = $uploads->{$name};
447 $files = ref $files eq 'ARRAY' ? $files : [$files];
449 for my $upload (@$files) {
450 my $u = Catalyst::Request::Upload->new;
451 $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
452 $u->type( $u->headers->content_type );
453 $u->tempname( $upload->{tempname} );
454 $u->size( $upload->{size} );
455 $u->filename( $upload->{filename} );
458 $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
460 # support access to the filename as a normal param
461 my @filenames = map { $_->{filename} } @uploads;
462 $c->request->parameters->{$name} =
463 @filenames > 1 ? \@filenames : $filenames[0];
467 =head2 $self->prepare_write($c)
471 sub prepare_write { }
473 =head2 $self->read($c, [$maxlength])
478 my ( $self, $c, $maxlength ) = @_;
480 unless ( $self->{_prepared_read} ) {
481 $self->prepare_read($c);
482 $self->{_prepared_read} = 1;
485 my $remaining = $self->read_length - $self->read_position;
486 $maxlength ||= $CHUNKSIZE;
488 # Are we done reading?
489 if ( $remaining <= 0 ) {
490 $self->finalize_read($c);
494 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
495 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
497 $self->read_position( $self->read_position + $rc );
501 Catalyst::Exception->throw(
502 message => "Unknown error reading input: $!" );
506 =head2 $self->read_chunk($c, $buffer, $length)
508 Each engine inplements read_chunk as its preferred way of reading a chunk
515 =head2 $self->read_length
517 The length of input data to be read. This is obtained from the Content-Length
520 =head2 $self->read_position
522 The amount of input data that has already been read.
524 =head2 $self->run($c)
530 =head2 $self->write($c, $buffer)
535 my ( $self, $c, $buffer ) = @_;
537 unless ( $self->{_prepared_write} ) {
538 $self->prepare_write($c);
539 $self->{_prepared_write} = 1;
542 print STDOUT $buffer;
547 Sebastian Riedel, <sri@cpan.org>
549 Andy Grundman, <andy@hybridized.org>
553 This program is free software, you can redistribute it and/or modify it under
554 the same terms as Perl itself.