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 = "<pre>$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>
136 $infos = join "\n", @infos;
143 (en) Please come back later
144 (de) Bitte versuchen sie es spaeter nocheinmal
145 (nl) Gelieve te komen later terug
146 (no) Vennligst prov igjen senere
147 (fr) Veuillez revenir plus tard
148 (es) Vuelto por favor mas adelante
149 (pt) Voltado por favor mais tarde
150 (it) Ritornato prego piĆ¹ successivamente
155 $c->res->body( <<"" );
156 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
157 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
158 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
160 <meta http-equiv="Content-Language" content="en" />
161 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
162 <title>$title</title>
163 <script type="text/javascript">
165 function toggleDump (dumpElement) {
166 var e = document.getElementById( dumpElement );
167 if (e.style.display == "none") {
168 e.style.display = "";
171 e.style.display = "none";
176 <style type="text/css">
178 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
179 Tahoma, Arial, helvetica, sans-serif;
181 background-color: #eee;
185 :link, :link:hover, :visited, :visited:hover {
190 background-color: #ccc;
191 border: 1px solid #aaa;
194 -moz-border-radius: 10px;
197 background-color: #977;
198 border: 1px solid #755;
202 -moz-border-radius: 10px;
205 background-color: #797;
206 border: 1px solid #575;
210 -moz-border-radius: 10px;
213 background-color: #779;
214 border: 1px solid #557;
217 -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.