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
35 =item $self->finalize_output
37 <obsolete>, see finalize_body
39 =item $self->finalize_body($c)
41 Finalize body. Prints the response output.
46 my ( $self, $c ) = @_;
47 if ( ref $c->response->body && $c->response->body->can('read') ) {
48 while ( !$c->response->body->eof() ) {
49 $c->response->body->read( my $buffer, $CHUNKSIZE );
50 $self->write( $c, $buffer );
52 $c->response->body->close();
55 $self->write( $c, $c->response->body );
59 =item $self->finalize_cookies($c)
63 sub finalize_cookies {
64 my ( $self, $c ) = @_;
67 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
69 my $cookie = CGI::Cookie->new(
71 -value => $cookie->{value},
72 -expires => $cookie->{expires},
73 -domain => $cookie->{domain},
74 -path => $cookie->{path},
75 -secure => $cookie->{secure} || 0
78 push @cookies, $cookie->as_string;
82 $c->res->headers->push_header( 'Set-Cookie' => join ',', @cookies );
86 =item $self->finalize_error($c)
91 my ( $self, $c ) = @_;
93 $c->res->headers->content_type('text/html');
94 my $name = $c->config->{name} || 'Catalyst Application';
96 my ( $title, $error, $infos );
100 local $Data::Dumper::Terse = 1;
102 map { '<code class="error">' . encode_entities($_) . '</code>' }
104 $error ||= 'No output';
105 $title = $name = "$name on Catalyst $Catalyst::VERSION";
107 # Don't show context in the dump
108 delete $c->req->{_context};
109 delete $c->res->{_context};
111 # Don't show body parser in the dump
112 delete $c->req->{_body};
114 # Don't show response header state in dump
115 delete $c->res->{_finalized_headers};
117 my $req = encode_entities Dumper $c->req;
118 my $res = encode_entities Dumper $c->res;
119 my $stash = encode_entities Dumper $c->stash;
124 sprintf "<b><u>%s</u></b><br/>\n<pre>%s</pre>", $_->[0],
125 encode_entities( Dumper $_->[1] )
134 (en) Please come back later
135 (de) Bitte versuchen sie es spaeter nocheinmal
136 (nl) Gelieve te komen later terug
137 (no) Vennligst prov igjen senere
138 (fr) Veuillez revenir plus tard
139 (es) Vuelto por favor mas adelante
140 (pt) Voltado por favor mais tarde
141 (it) Ritornato prego piĆ¹ successivamente
146 $c->res->body( <<"" );
149 <title>$title</title>
150 <style type="text/css">
152 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
153 Tahoma, Arial, helvetica, sans-serif;
155 background-color: #eee;
160 background-color: #ccc;
161 border: 1px solid #aaa;
164 -moz-border-radius: 10px;
167 background-color: #977;
168 border: 1px solid #755;
172 -moz-border-radius: 10px;
175 background-color: #797;
176 border: 1px solid #575;
180 -moz-border-radius: 10px;
183 background-color: #779;
184 border: 1px solid #557;
187 -moz-border-radius: 10px;
199 <div class="error">$error</div>
200 <div class="infos">$infos</div>
201 <div class="name">$name</div>
208 =item $self->finalize_headers($c)
212 sub finalize_headers { }
214 =item $self->finalize_read($c)
219 my ( $self, $c ) = @_;
221 undef $self->{_prepared_read};
224 =item $self->finalize_uploads($c)
228 sub finalize_uploads {
229 my ( $self, $c ) = @_;
231 if ( keys %{ $c->request->uploads } ) {
232 for my $key ( keys %{ $c->request->uploads } ) {
233 my $upload = $c->request->uploads->{$key};
234 unlink map { $_->tempname }
235 grep { -e $_->tempname }
236 ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
241 =item $self->prepare_body($c)
246 my ( $self, $c ) = @_;
248 $self->read_length( $c->request->header('Content-Length') || 0 );
249 my $type = $c->request->header('Content-Type');
251 unless ( $c->request->{_body} ) {
252 $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
255 if ( $self->read_length > 0 ) {
256 while ( my $buffer = $self->read($c) ) {
257 $c->prepare_body_chunk($buffer);
262 =item $self->prepare_body_chunk($c)
266 sub prepare_body_chunk {
267 my ( $self, $c, $chunk ) = @_;
269 $c->request->{_body}->add($chunk);
272 =item $self->prepare_body_parameters($c)
276 sub prepare_body_parameters {
277 my ( $self, $c ) = @_;
278 $c->request->body_parameters( $c->request->{_body}->param );
281 =item $self->prepare_connection($c)
285 sub prepare_connection { }
287 =item $self->prepare_cookies($c)
291 sub prepare_cookies {
292 my ( $self, $c ) = @_;
294 if ( my $header = $c->request->header('Cookie') ) {
295 $c->req->cookies( { CGI::Cookie->parse($header) } );
299 =item $self->prepare_headers($c)
303 sub prepare_headers { }
305 =item $self->prepare_parameters($c)
309 sub prepare_parameters {
310 my ( $self, $c ) = @_;
312 # We copy, no references
313 while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
314 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
315 $c->request->parameters->{$name} = $param;
318 # Merge query and body parameters
319 while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
320 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
321 if ( my $old_param = $c->request->parameters->{$name} ) {
322 if ( ref $old_param eq 'ARRAY' ) {
323 push @{ $c->request->parameters->{$name} },
324 ref $param eq 'ARRAY' ? @$param : $param;
326 else { $c->request->parameters->{$name} = [ $old_param, $param ] }
328 else { $c->request->parameters->{$name} = $param }
332 =item $self->prepare_path($c)
338 =item $self->prepare_request($c)
340 =item $self->prepare_query_parameters($c)
344 sub prepare_query_parameters {
345 my ( $self, $c, $query_string ) = @_;
347 # replace semi-colons
348 $query_string =~ s/;/&/g;
350 my $u = URI->new( '', 'http' );
351 $u->query($query_string);
352 for my $key ( $u->query_param ) {
353 my @vals = $u->query_param($key);
354 $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
358 =item $self->prepare_read($c)
363 my ( $self, $c ) = @_;
365 # Reset the read position
366 $self->read_position(0);
369 =item $self->prepare_request(@arguments)
373 sub prepare_request { }
375 =item $self->prepare_uploads($c)
379 sub prepare_uploads {
380 my ( $self, $c ) = @_;
381 my $uploads = $c->request->{_body}->upload;
382 for my $name ( keys %$uploads ) {
383 my $files = $uploads->{$name};
384 $files = ref $files eq 'ARRAY' ? $files : [$files];
386 for my $upload (@$files) {
387 my $u = Catalyst::Request::Upload->new;
388 $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
389 $u->type( $u->headers->content_type );
390 $u->tempname( $upload->{tempname} );
391 $u->size( $upload->{size} );
392 $u->filename( $upload->{filename} );
395 $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
397 # support access to the filename as a normal param
398 my @filenames = map { $_->{filename} } @uploads;
399 $c->request->parameters->{$name} =
400 @filenames > 1 ? \@filenames : $filenames[0];
404 =item $self->prepare_write($c)
408 sub prepare_write { }
410 =item $self->read($c, [$maxlength])
415 my ( $self, $c, $maxlength ) = @_;
417 unless ( $self->{_prepared_read} ) {
418 $self->prepare_read($c);
419 $self->{_prepared_read} = 1;
422 my $remaining = $self->read_length - $self->read_position;
423 $maxlength ||= $CHUNKSIZE;
425 # Are we done reading?
426 if ( $remaining <= 0 ) {
427 $self->finalize_read($c);
431 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
432 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
434 $self->read_position( $self->read_position + $rc );
438 Catalyst::Exception->throw(
439 message => "Unknown error reading input: $!" );
443 =item $self->read_chunk($c, $buffer, $length)
445 Each engine inplements read_chunk as its preferred way of reading a chunk
452 =item $self->read_length
454 The length of input data to be read. This is obtained from the Content-Length
457 =item $self->read_position
459 The amount of input data that has already been read.
467 =item $self->write($c, $buffer)
472 my ( $self, $c, $buffer ) = @_;
474 unless ( $self->{_prepared_write} ) {
475 $self->prepare_write($c);
476 $self->{_prepared_write} = 1;
479 print STDOUT $buffer;
486 Sebastian Riedel, <sri@cpan.org>
488 Andy Grundman, <andy@hybridized.org>
492 This program is free software, you can redistribute it and/or modify it under
493 the same terms as Perl itself.