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 (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;
240 <div class="error">$error</div>
241 <div class="infos">$infos</div>
242 <div class="name">$name</div>
249 $c->res->{body} .= ( ' ' x 512 );
252 $c->res->status(500);
255 =head2 $self->finalize_headers($c)
259 sub finalize_headers { }
261 =head2 $self->finalize_read($c)
266 my ( $self, $c ) = @_;
268 undef $self->{_prepared_read};
271 =head2 $self->finalize_uploads($c)
275 sub finalize_uploads {
276 my ( $self, $c ) = @_;
278 if ( keys %{ $c->request->uploads } ) {
279 for my $key ( keys %{ $c->request->uploads } ) {
280 my $upload = $c->request->uploads->{$key};
281 unlink map { $_->tempname }
282 grep { -e $_->tempname }
283 ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
288 =head2 $self->prepare_body($c)
293 my ( $self, $c ) = @_;
295 $self->read_length( $c->request->header('Content-Length') || 0 );
296 my $type = $c->request->header('Content-Type');
298 unless ( $c->request->{_body} ) {
299 $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
302 if ( $self->read_length > 0 ) {
303 while ( my $buffer = $self->read($c) ) {
304 $c->prepare_body_chunk($buffer);
309 =head2 $self->prepare_body_chunk($c)
313 sub prepare_body_chunk {
314 my ( $self, $c, $chunk ) = @_;
316 $c->request->{_body}->add($chunk);
319 =head2 $self->prepare_body_parameters($c)
323 sub prepare_body_parameters {
324 my ( $self, $c ) = @_;
325 $c->request->body_parameters( $c->request->{_body}->param );
328 =head2 $self->prepare_connection($c)
332 sub prepare_connection { }
334 =head2 $self->prepare_cookies($c)
338 sub prepare_cookies {
339 my ( $self, $c ) = @_;
341 if ( my $header = $c->request->header('Cookie') ) {
342 $c->req->cookies( { CGI::Cookie->parse($header) } );
346 =head2 $self->prepare_headers($c)
350 sub prepare_headers { }
352 =head2 $self->prepare_parameters($c)
356 sub prepare_parameters {
357 my ( $self, $c ) = @_;
359 # We copy, no references
360 while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
361 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
362 $c->request->parameters->{$name} = $param;
365 # Merge query and body parameters
366 while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
367 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
368 if ( my $old_param = $c->request->parameters->{$name} ) {
369 if ( ref $old_param eq 'ARRAY' ) {
370 push @{ $c->request->parameters->{$name} },
371 ref $param eq 'ARRAY' ? @$param : $param;
373 else { $c->request->parameters->{$name} = [ $old_param, $param ] }
375 else { $c->request->parameters->{$name} = $param }
379 =head2 $self->prepare_path($c)
385 =head2 $self->prepare_request($c)
387 =head2 $self->prepare_query_parameters($c)
391 sub prepare_query_parameters {
392 my ( $self, $c, $query_string ) = @_;
394 # replace semi-colons
395 $query_string =~ s/;/&/g;
397 my $u = URI->new( '', 'http' );
398 $u->query($query_string);
399 for my $key ( $u->query_param ) {
400 my @vals = $u->query_param($key);
401 $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
405 =head2 $self->prepare_read($c)
410 my ( $self, $c ) = @_;
412 # Reset the read position
413 $self->read_position(0);
416 =head2 $self->prepare_request(@arguments)
420 sub prepare_request { }
422 =head2 $self->prepare_uploads($c)
426 sub prepare_uploads {
427 my ( $self, $c ) = @_;
428 my $uploads = $c->request->{_body}->upload;
429 for my $name ( keys %$uploads ) {
430 my $files = $uploads->{$name};
431 $files = ref $files eq 'ARRAY' ? $files : [$files];
433 for my $upload (@$files) {
434 my $u = Catalyst::Request::Upload->new;
435 $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
436 $u->type( $u->headers->content_type );
437 $u->tempname( $upload->{tempname} );
438 $u->size( $upload->{size} );
439 $u->filename( $upload->{filename} );
442 $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
444 # support access to the filename as a normal param
445 my @filenames = map { $_->{filename} } @uploads;
446 $c->request->parameters->{$name} =
447 @filenames > 1 ? \@filenames : $filenames[0];
451 =head2 $self->prepare_write($c)
455 sub prepare_write { }
457 =head2 $self->read($c, [$maxlength])
462 my ( $self, $c, $maxlength ) = @_;
464 unless ( $self->{_prepared_read} ) {
465 $self->prepare_read($c);
466 $self->{_prepared_read} = 1;
469 my $remaining = $self->read_length - $self->read_position;
470 $maxlength ||= $CHUNKSIZE;
472 # Are we done reading?
473 if ( $remaining <= 0 ) {
474 $self->finalize_read($c);
478 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
479 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
481 $self->read_position( $self->read_position + $rc );
485 Catalyst::Exception->throw(
486 message => "Unknown error reading input: $!" );
490 =head2 $self->read_chunk($c, $buffer, $length)
492 Each engine inplements read_chunk as its preferred way of reading a chunk
499 =head2 $self->read_length
501 The length of input data to be read. This is obtained from the Content-Length
504 =head2 $self->read_position
506 The amount of input data that has already been read.
508 =head2 $self->run($c)
514 =head2 $self->write($c, $buffer)
519 my ( $self, $c, $buffer ) = @_;
521 unless ( $self->{_prepared_write} ) {
522 $self->prepare_write($c);
523 $self->{_prepared_write} = 1;
526 print STDOUT $buffer;
531 Sebastian Riedel, <sri@cpan.org>
533 Andy Grundman, <andy@hybridized.org>
537 This program is free software, you can redistribute it and/or modify it under
538 the same terms as Perl itself.