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;
122 <b><u>Request</u></b><br/>
124 <b><u>Response</u></b><br/>
126 <b><u>Stash</u></b><br/>
135 (en) Please come back later
136 (de) Bitte versuchen sie es spaeter nocheinmal
137 (nl) Gelieve te komen later terug
138 (no) Vennligst prov igjen senere
139 (fr) Veuillez revenir plus tard
140 (es) Vuelto por favor mas adelante
141 (pt) Voltado por favor mais tarde
142 (it) Ritornato prego piĆ¹ successivamente
147 $c->res->body( <<"" );
150 <title>$title</title>
151 <style type="text/css">
153 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
154 Tahoma, Arial, helvetica, sans-serif;
156 background-color: #eee;
161 background-color: #ccc;
162 border: 1px solid #aaa;
165 -moz-border-radius: 10px;
168 background-color: #977;
169 border: 1px solid #755;
173 -moz-border-radius: 10px;
176 background-color: #797;
177 border: 1px solid #575;
181 -moz-border-radius: 10px;
184 background-color: #779;
185 border: 1px solid #557;
188 -moz-border-radius: 10px;
200 <div class="error">$error</div>
201 <div class="infos">$infos</div>
202 <div class="name">$name</div>
209 =item $self->finalize_headers($c)
213 sub finalize_headers { }
215 =item $self->finalize_read($c)
220 my ( $self, $c ) = @_;
222 undef $self->{_prepared_read};
225 =item $self->finalize_uploads($c)
229 sub finalize_uploads {
230 my ( $self, $c ) = @_;
232 if ( keys %{ $c->request->uploads } ) {
233 for my $key ( keys %{ $c->request->uploads } ) {
234 my $upload = $c->request->uploads->{$key};
235 unlink map { $_->tempname }
236 grep { -e $_->tempname }
237 ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
242 =item $self->prepare_body($c)
247 my ( $self, $c ) = @_;
249 $self->read_length( $c->request->header('Content-Length') || 0 );
250 my $type = $c->request->header('Content-Type');
252 unless ( $c->request->{_body} ) {
253 $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
256 if ( $self->read_length > 0 ) {
257 while ( my $buffer = $self->read($c) ) {
258 $c->prepare_body_chunk($buffer);
263 =item $self->prepare_body_chunk($c)
267 sub prepare_body_chunk {
268 my ( $self, $c, $chunk ) = @_;
270 $c->request->{_body}->add($chunk);
273 =item $self->prepare_body_parameters($c)
277 sub prepare_body_parameters {
278 my ( $self, $c ) = @_;
279 $c->request->body_parameters( $c->request->{_body}->param );
282 =item $self->prepare_connection($c)
286 sub prepare_connection { }
288 =item $self->prepare_cookies($c)
292 sub prepare_cookies {
293 my ( $self, $c ) = @_;
295 if ( my $header = $c->request->header('Cookie') ) {
296 $c->req->cookies( { CGI::Cookie->parse($header) } );
300 =item $self->prepare_headers($c)
304 sub prepare_headers { }
306 =item $self->prepare_parameters($c)
310 sub prepare_parameters {
311 my ( $self, $c ) = @_;
313 # We copy, no references
314 while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
315 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
316 $c->request->parameters->{$name} = $param;
319 # Merge query and body parameters
320 while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
321 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
322 if ( my $old_param = $c->request->parameters->{$name} ) {
323 if ( ref $old_param eq 'ARRAY' ) {
324 push @{ $c->request->parameters->{$name} },
325 ref $param eq 'ARRAY' ? @$param : $param;
327 else { $c->request->parameters->{$name} = [ $old_param, $param ] }
329 else { $c->request->parameters->{$name} = $param }
333 =item $self->prepare_path($c)
339 =item $self->prepare_request($c)
341 =item $self->prepare_query_parameters($c)
345 sub prepare_query_parameters {
346 my ( $self, $c, $query_string ) = @_;
348 # replace semi-colons
349 $query_string =~ s/;/&/g;
351 my $u = URI->new( '', 'http' );
352 $u->query($query_string);
353 for my $key ( $u->query_param ) {
354 my @vals = $u->query_param($key);
355 $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
359 =item $self->prepare_read($c)
364 my ( $self, $c ) = @_;
366 # Reset the read position
367 $self->read_position(0);
370 =item $self->prepare_request(@arguments)
374 sub prepare_request { }
376 =item $self->prepare_uploads($c)
380 sub prepare_uploads {
381 my ( $self, $c ) = @_;
382 my $uploads = $c->request->{_body}->upload;
383 for my $name ( keys %$uploads ) {
384 my $files = $uploads->{$name};
385 $files = ref $files eq 'ARRAY' ? $files : [$files];
387 for my $upload (@$files) {
388 my $u = Catalyst::Request::Upload->new;
389 $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
390 $u->type( $u->headers->content_type );
391 $u->tempname( $upload->{tempname} );
392 $u->size( $upload->{size} );
393 $u->filename( $upload->{filename} );
396 $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
398 # support access to the filename as a normal param
399 my @filenames = map { $_->{filename} } @uploads;
400 $c->request->parameters->{$name} =
401 @filenames > 1 ? \@filenames : $filenames[0];
405 =item $self->prepare_write($c)
409 sub prepare_write { }
411 =item $self->read($c, [$maxlength])
416 my ( $self, $c, $maxlength ) = @_;
418 unless ( $self->{_prepared_read} ) {
419 $self->prepare_read($c);
420 $self->{_prepared_read} = 1;
423 my $remaining = $self->read_length - $self->read_position;
424 $maxlength ||= $CHUNKSIZE;
426 # Are we done reading?
427 if ( $remaining <= 0 ) {
428 $self->finalize_read($c);
432 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
433 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
435 $self->read_position( $self->read_position + $rc );
439 Catalyst::Exception->throw(
440 message => "Unknown error reading input: $!" );
444 =item $self->read_chunk($c, $buffer, $length)
446 Each engine inplements read_chunk as its preferred way of reading a chunk
453 =item $self->read_length
455 The length of input data to be read. This is obtained from the Content-Length
458 =item $self->read_position
460 The amount of input data that has already been read.
468 =item $self->write($c, $buffer)
473 my ( $self, $c, $buffer ) = @_;
475 unless ( $self->{_prepared_write} ) {
476 $self->prepare_write($c);
477 $self->{_prepared_write} = 1;
480 print STDOUT $buffer;
487 Sebastian Riedel, <sri@cpan.org>
489 Andy Grundman, <andy@hybridized.org>
493 This program is free software, you can redistribute it and/or modify it under
494 the same terms as Perl itself.