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;
224 div.name h1, div.error p {
232 text-decoration: underline;
242 <div class="error">$error</div>
243 <div class="infos">$infos</div>
244 <div class="name">$name</div>
251 =head2 $self->finalize_headers($c)
255 sub finalize_headers { }
257 =head2 $self->finalize_read($c)
262 my ( $self, $c ) = @_;
264 undef $self->{_prepared_read};
267 =head2 $self->finalize_uploads($c)
271 sub finalize_uploads {
272 my ( $self, $c ) = @_;
274 if ( keys %{ $c->request->uploads } ) {
275 for my $key ( keys %{ $c->request->uploads } ) {
276 my $upload = $c->request->uploads->{$key};
277 unlink map { $_->tempname }
278 grep { -e $_->tempname }
279 ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
284 =head2 $self->prepare_body($c)
289 my ( $self, $c ) = @_;
291 $self->read_length( $c->request->header('Content-Length') || 0 );
292 my $type = $c->request->header('Content-Type');
294 unless ( $c->request->{_body} ) {
295 $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
298 if ( $self->read_length > 0 ) {
299 while ( my $buffer = $self->read($c) ) {
300 $c->prepare_body_chunk($buffer);
305 =head2 $self->prepare_body_chunk($c)
309 sub prepare_body_chunk {
310 my ( $self, $c, $chunk ) = @_;
312 $c->request->{_body}->add($chunk);
315 =head2 $self->prepare_body_parameters($c)
319 sub prepare_body_parameters {
320 my ( $self, $c ) = @_;
321 $c->request->body_parameters( $c->request->{_body}->param );
324 =head2 $self->prepare_connection($c)
328 sub prepare_connection { }
330 =head2 $self->prepare_cookies($c)
334 sub prepare_cookies {
335 my ( $self, $c ) = @_;
337 if ( my $header = $c->request->header('Cookie') ) {
338 $c->req->cookies( { CGI::Cookie->parse($header) } );
342 =head2 $self->prepare_headers($c)
346 sub prepare_headers { }
348 =head2 $self->prepare_parameters($c)
352 sub prepare_parameters {
353 my ( $self, $c ) = @_;
355 # We copy, no references
356 while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
357 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
358 $c->request->parameters->{$name} = $param;
361 # Merge query and body parameters
362 while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
363 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
364 if ( my $old_param = $c->request->parameters->{$name} ) {
365 if ( ref $old_param eq 'ARRAY' ) {
366 push @{ $c->request->parameters->{$name} },
367 ref $param eq 'ARRAY' ? @$param : $param;
369 else { $c->request->parameters->{$name} = [ $old_param, $param ] }
371 else { $c->request->parameters->{$name} = $param }
375 =head2 $self->prepare_path($c)
381 =head2 $self->prepare_request($c)
383 =head2 $self->prepare_query_parameters($c)
387 sub prepare_query_parameters {
388 my ( $self, $c, $query_string ) = @_;
390 # replace semi-colons
391 $query_string =~ s/;/&/g;
393 my $u = URI->new( '', 'http' );
394 $u->query($query_string);
395 for my $key ( $u->query_param ) {
396 my @vals = $u->query_param($key);
397 $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
401 =head2 $self->prepare_read($c)
406 my ( $self, $c ) = @_;
408 # Reset the read position
409 $self->read_position(0);
412 =head2 $self->prepare_request(@arguments)
416 sub prepare_request { }
418 =head2 $self->prepare_uploads($c)
422 sub prepare_uploads {
423 my ( $self, $c ) = @_;
424 my $uploads = $c->request->{_body}->upload;
425 for my $name ( keys %$uploads ) {
426 my $files = $uploads->{$name};
427 $files = ref $files eq 'ARRAY' ? $files : [$files];
429 for my $upload (@$files) {
430 my $u = Catalyst::Request::Upload->new;
431 $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
432 $u->type( $u->headers->content_type );
433 $u->tempname( $upload->{tempname} );
434 $u->size( $upload->{size} );
435 $u->filename( $upload->{filename} );
438 $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
440 # support access to the filename as a normal param
441 my @filenames = map { $_->{filename} } @uploads;
442 $c->request->parameters->{$name} =
443 @filenames > 1 ? \@filenames : $filenames[0];
447 =head2 $self->prepare_write($c)
451 sub prepare_write { }
453 =head2 $self->read($c, [$maxlength])
458 my ( $self, $c, $maxlength ) = @_;
460 unless ( $self->{_prepared_read} ) {
461 $self->prepare_read($c);
462 $self->{_prepared_read} = 1;
465 my $remaining = $self->read_length - $self->read_position;
466 $maxlength ||= $CHUNKSIZE;
468 # Are we done reading?
469 if ( $remaining <= 0 ) {
470 $self->finalize_read($c);
474 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
475 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
477 $self->read_position( $self->read_position + $rc );
481 Catalyst::Exception->throw(
482 message => "Unknown error reading input: $!" );
486 =head2 $self->read_chunk($c, $buffer, $length)
488 Each engine inplements read_chunk as its preferred way of reading a chunk
495 =head2 $self->read_length
497 The length of input data to be read. This is obtained from the Content-Length
500 =head2 $self->read_position
502 The amount of input data that has already been read.
504 =head2 $self->run($c)
510 =head2 $self->write($c, $buffer)
515 my ( $self, $c, $buffer ) = @_;
517 unless ( $self->{_prepared_write} ) {
518 $self->prepare_write($c);
519 $self->{_prepared_write} = 1;
522 print STDOUT $buffer;
527 Sebastian Riedel, <sri@cpan.org>
529 Andy Grundman, <andy@hybridized.org>
533 This program is free software, you can redistribute it and/or modify it under
534 the same terms as Perl itself.