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);
318 =head2 $self->prepare_body_chunk($c)
322 sub prepare_body_chunk {
323 my ( $self, $c, $chunk ) = @_;
325 $c->request->{_body}->add($chunk);
328 =head2 $self->prepare_body_parameters($c)
332 sub prepare_body_parameters {
333 my ( $self, $c ) = @_;
334 $c->request->body_parameters( $c->request->{_body}->param );
337 =head2 $self->prepare_connection($c)
341 sub prepare_connection { }
343 =head2 $self->prepare_cookies($c)
347 sub prepare_cookies {
348 my ( $self, $c ) = @_;
350 if ( my $header = $c->request->header('Cookie') ) {
351 $c->req->cookies( { CGI::Cookie->parse($header) } );
355 =head2 $self->prepare_headers($c)
359 sub prepare_headers { }
361 =head2 $self->prepare_parameters($c)
365 sub prepare_parameters {
366 my ( $self, $c ) = @_;
368 # We copy, no references
369 while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
370 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
371 $c->request->parameters->{$name} = $param;
374 # Merge query and body parameters
375 while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
376 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
377 if ( my $old_param = $c->request->parameters->{$name} ) {
378 if ( ref $old_param eq 'ARRAY' ) {
379 push @{ $c->request->parameters->{$name} },
380 ref $param eq 'ARRAY' ? @$param : $param;
382 else { $c->request->parameters->{$name} = [ $old_param, $param ] }
384 else { $c->request->parameters->{$name} = $param }
388 =head2 $self->prepare_path($c)
394 =head2 $self->prepare_request($c)
396 =head2 $self->prepare_query_parameters($c)
400 sub prepare_query_parameters {
401 my ( $self, $c, $query_string ) = @_;
403 # replace semi-colons
404 $query_string =~ s/;/&/g;
406 my $u = URI->new( '', 'http' );
407 $u->query($query_string);
408 for my $key ( $u->query_param ) {
409 my @vals = $u->query_param($key);
410 $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
414 =head2 $self->prepare_read($c)
419 my ( $self, $c ) = @_;
421 # Reset the read position
422 $self->read_position(0);
425 =head2 $self->prepare_request(@arguments)
429 sub prepare_request { }
431 =head2 $self->prepare_uploads($c)
435 sub prepare_uploads {
436 my ( $self, $c ) = @_;
437 my $uploads = $c->request->{_body}->upload;
438 for my $name ( keys %$uploads ) {
439 my $files = $uploads->{$name};
440 $files = ref $files eq 'ARRAY' ? $files : [$files];
442 for my $upload (@$files) {
443 my $u = Catalyst::Request::Upload->new;
444 $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
445 $u->type( $u->headers->content_type );
446 $u->tempname( $upload->{tempname} );
447 $u->size( $upload->{size} );
448 $u->filename( $upload->{filename} );
451 $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
453 # support access to the filename as a normal param
454 my @filenames = map { $_->{filename} } @uploads;
455 $c->request->parameters->{$name} =
456 @filenames > 1 ? \@filenames : $filenames[0];
460 =head2 $self->prepare_write($c)
464 sub prepare_write { }
466 =head2 $self->read($c, [$maxlength])
471 my ( $self, $c, $maxlength ) = @_;
473 unless ( $self->{_prepared_read} ) {
474 $self->prepare_read($c);
475 $self->{_prepared_read} = 1;
478 my $remaining = $self->read_length - $self->read_position;
479 $maxlength ||= $CHUNKSIZE;
481 # Are we done reading?
482 if ( $remaining <= 0 ) {
483 $self->finalize_read($c);
487 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
488 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
490 $self->read_position( $self->read_position + $rc );
494 Catalyst::Exception->throw(
495 message => "Unknown error reading input: $!" );
499 =head2 $self->read_chunk($c, $buffer, $length)
501 Each engine inplements read_chunk as its preferred way of reading a chunk
508 =head2 $self->read_length
510 The length of input data to be read. This is obtained from the Content-Length
513 =head2 $self->read_position
515 The amount of input data that has already been read.
517 =head2 $self->run($c)
523 =head2 $self->write($c, $buffer)
528 my ( $self, $c, $buffer ) = @_;
530 unless ( $self->{_prepared_write} ) {
531 $self->prepare_write($c);
532 $self->{_prepared_write} = 1;
535 print STDOUT $buffer;
540 Sebastian Riedel, <sri@cpan.org>
542 Andy Grundman, <andy@hybridized.org>
546 This program is free software, you can redistribute it and/or modify it under
547 the same terms as Perl itself.