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 $title = $name = "$name on Catalyst $Catalyst::VERSION";
106 $name = "<h1>$name</h1>";
108 # Don't show context in the dump
109 delete $c->req->{_context};
110 delete $c->res->{_context};
112 # Don't show body parser in the dump
113 delete $c->req->{_body};
115 # Don't show response header state in dump
116 delete $c->res->{_finalized_headers};
118 my $req = encode_entities Dumper $c->req;
119 my $res = encode_entities Dumper $c->res;
120 my $stash = encode_entities Dumper $c->stash;
124 for my $dump ( $c->dump_these ) {
125 my $name = $dump->[0];
126 my $value = encode_entities( Dumper $dump->[1] );
127 push @infos, sprintf <<"EOF", $name, $value;
128 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
135 $infos = join "\n", @infos;
142 (en) Please come back later
143 (de) Bitte versuchen sie es spaeter nocheinmal
144 (nl) Gelieve te komen later terug
145 (no) Vennligst prov igjen senere
146 (fr) Veuillez revenir plus tard
147 (es) Vuelto por favor mas adelante
148 (pt) Voltado por favor mais tarde
149 (it) Ritornato prego piĆ¹ successivamente
154 $c->res->body( <<"" );
155 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
156 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
157 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
159 <meta http-equiv="Content-Language" content="en" />
160 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
161 <title>$title</title>
162 <script type="text/javascript">
164 function toggleDump (dumpElement) {
165 var e = document.getElementById( dumpElement );
166 if (e.style.display == "none") {
167 e.style.display = "";
170 e.style.display = "none";
175 <style type="text/css">
177 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
178 Tahoma, Arial, helvetica, sans-serif;
180 background-color: #eee;
184 :link, :link:hover, :visited, :visited:hover {
189 background-color: #ccc;
190 border: 1px solid #aaa;
193 -moz-border-radius: 10px;
196 background-color: #977;
197 border: 1px solid #755;
201 -moz-border-radius: 10px;
204 background-color: #797;
205 border: 1px solid #575;
209 -moz-border-radius: 10px;
212 background-color: #779;
213 border: 1px solid #557;
216 -moz-border-radius: 10px;
223 div.name h1, div.error p {
231 text-decoration: underline;
241 <div class="error">$error</div>
242 <div class="infos">$infos</div>
243 <div class="name">$name</div>
250 =head2 $self->finalize_headers($c)
254 sub finalize_headers { }
256 =head2 $self->finalize_read($c)
261 my ( $self, $c ) = @_;
263 undef $self->{_prepared_read};
266 =head2 $self->finalize_uploads($c)
270 sub finalize_uploads {
271 my ( $self, $c ) = @_;
273 if ( keys %{ $c->request->uploads } ) {
274 for my $key ( keys %{ $c->request->uploads } ) {
275 my $upload = $c->request->uploads->{$key};
276 unlink map { $_->tempname }
277 grep { -e $_->tempname }
278 ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
283 =head2 $self->prepare_body($c)
288 my ( $self, $c ) = @_;
290 $self->read_length( $c->request->header('Content-Length') || 0 );
291 my $type = $c->request->header('Content-Type');
293 unless ( $c->request->{_body} ) {
294 $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
297 if ( $self->read_length > 0 ) {
298 while ( my $buffer = $self->read($c) ) {
299 $c->prepare_body_chunk($buffer);
304 =head2 $self->prepare_body_chunk($c)
308 sub prepare_body_chunk {
309 my ( $self, $c, $chunk ) = @_;
311 $c->request->{_body}->add($chunk);
314 =head2 $self->prepare_body_parameters($c)
318 sub prepare_body_parameters {
319 my ( $self, $c ) = @_;
320 $c->request->body_parameters( $c->request->{_body}->param );
323 =head2 $self->prepare_connection($c)
327 sub prepare_connection { }
329 =head2 $self->prepare_cookies($c)
333 sub prepare_cookies {
334 my ( $self, $c ) = @_;
336 if ( my $header = $c->request->header('Cookie') ) {
337 $c->req->cookies( { CGI::Cookie->parse($header) } );
341 =head2 $self->prepare_headers($c)
345 sub prepare_headers { }
347 =head2 $self->prepare_parameters($c)
351 sub prepare_parameters {
352 my ( $self, $c ) = @_;
354 # We copy, no references
355 while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
356 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
357 $c->request->parameters->{$name} = $param;
360 # Merge query and body parameters
361 while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
362 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
363 if ( my $old_param = $c->request->parameters->{$name} ) {
364 if ( ref $old_param eq 'ARRAY' ) {
365 push @{ $c->request->parameters->{$name} },
366 ref $param eq 'ARRAY' ? @$param : $param;
368 else { $c->request->parameters->{$name} = [ $old_param, $param ] }
370 else { $c->request->parameters->{$name} = $param }
374 =head2 $self->prepare_path($c)
380 =head2 $self->prepare_request($c)
382 =head2 $self->prepare_query_parameters($c)
386 sub prepare_query_parameters {
387 my ( $self, $c, $query_string ) = @_;
389 # replace semi-colons
390 $query_string =~ s/;/&/g;
392 my $u = URI->new( '', 'http' );
393 $u->query($query_string);
394 for my $key ( $u->query_param ) {
395 my @vals = $u->query_param($key);
396 $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
400 =head2 $self->prepare_read($c)
405 my ( $self, $c ) = @_;
407 # Reset the read position
408 $self->read_position(0);
411 =head2 $self->prepare_request(@arguments)
415 sub prepare_request { }
417 =head2 $self->prepare_uploads($c)
421 sub prepare_uploads {
422 my ( $self, $c ) = @_;
423 my $uploads = $c->request->{_body}->upload;
424 for my $name ( keys %$uploads ) {
425 my $files = $uploads->{$name};
426 $files = ref $files eq 'ARRAY' ? $files : [$files];
428 for my $upload (@$files) {
429 my $u = Catalyst::Request::Upload->new;
430 $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
431 $u->type( $u->headers->content_type );
432 $u->tempname( $upload->{tempname} );
433 $u->size( $upload->{size} );
434 $u->filename( $upload->{filename} );
437 $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
439 # support access to the filename as a normal param
440 my @filenames = map { $_->{filename} } @uploads;
441 $c->request->parameters->{$name} =
442 @filenames > 1 ? \@filenames : $filenames[0];
446 =head2 $self->prepare_write($c)
450 sub prepare_write { }
452 =head2 $self->read($c, [$maxlength])
457 my ( $self, $c, $maxlength ) = @_;
459 unless ( $self->{_prepared_read} ) {
460 $self->prepare_read($c);
461 $self->{_prepared_read} = 1;
464 my $remaining = $self->read_length - $self->read_position;
465 $maxlength ||= $CHUNKSIZE;
467 # Are we done reading?
468 if ( $remaining <= 0 ) {
469 $self->finalize_read($c);
473 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
474 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
476 $self->read_position( $self->read_position + $rc );
480 Catalyst::Exception->throw(
481 message => "Unknown error reading input: $!" );
485 =head2 $self->read_chunk($c, $buffer, $length)
487 Each engine inplements read_chunk as its preferred way of reading a chunk
494 =head2 $self->read_length
496 The length of input data to be read. This is obtained from the Content-Length
499 =head2 $self->read_position
501 The amount of input data that has already been read.
503 =head2 $self->run($c)
509 =head2 $self->write($c, $buffer)
514 my ( $self, $c, $buffer ) = @_;
516 unless ( $self->{_prepared_write} ) {
517 $self->prepare_write($c);
518 $self->{_prepared_write} = 1;
521 print STDOUT $buffer;
526 Sebastian Riedel, <sri@cpan.org>
528 Andy Grundman, <andy@hybridized.org>
532 This program is free software, you can redistribute it and/or modify it under
533 the same terms as Perl itself.