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 ) = @_;
48 $self->write( $c, $c->response->output );
51 =item $self->finalize_cookies($c)
55 sub finalize_cookies {
56 my ( $self, $c ) = @_;
59 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
61 my $cookie = CGI::Cookie->new(
63 -value => $cookie->{value},
64 -expires => $cookie->{expires},
65 -domain => $cookie->{domain},
66 -path => $cookie->{path},
67 -secure => $cookie->{secure} || 0
70 push @cookies, $cookie->as_string;
74 $c->res->headers->push_header( 'Set-Cookie' => join ',', @cookies );
78 =item $self->finalize_error($c)
83 my ( $self, $c ) = @_;
85 $c->res->headers->content_type('text/html');
86 my $name = $c->config->{name} || 'Catalyst Application';
88 my ( $title, $error, $infos );
92 local $Data::Dumper::Terse = 1;
94 map { '<code class="error">' . encode_entities($_) . '</code>' }
96 $error ||= 'No output';
97 $title = $name = "$name on Catalyst $Catalyst::VERSION";
99 # Don't show context in the dump
100 delete $c->req->{_context};
101 delete $c->res->{_context};
103 # Don't show body parser in the dump
104 delete $c->req->{_body};
106 # Don't show response header state in dump
107 delete $c->res->{_finalized_headers};
109 my $req = encode_entities Dumper $c->req;
110 my $res = encode_entities Dumper $c->res;
111 my $stash = encode_entities Dumper $c->stash;
114 <b><u>Request</u></b><br/>
116 <b><u>Response</u></b><br/>
118 <b><u>Stash</u></b><br/>
127 (en) Please come back later
128 (de) Bitte versuchen sie es spaeter nocheinmal
129 (nl) Gelieve te komen later terug
130 (no) Vennligst prov igjen senere
131 (fr) Veuillez revenir plus tard
132 (es) Vuelto por favor mas adelante
133 (pt) Voltado por favor mais tarde
134 (it) Ritornato prego piĆ¹ successivamente
139 $c->res->body( <<"" );
142 <title>$title</title>
143 <style type="text/css">
145 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
146 Tahoma, Arial, helvetica, sans-serif;
148 background-color: #eee;
153 background-color: #ccc;
154 border: 1px solid #aaa;
157 -moz-border-radius: 10px;
160 background-color: #977;
161 border: 1px solid #755;
165 -moz-border-radius: 10px;
168 background-color: #797;
169 border: 1px solid #575;
173 -moz-border-radius: 10px;
176 background-color: #779;
177 border: 1px solid #557;
180 -moz-border-radius: 10px;
192 <div class="error">$error</div>
193 <div class="infos">$infos</div>
194 <div class="name">$name</div>
201 =item $self->finalize_headers($c)
205 sub finalize_headers { }
207 =item $self->finalize_read($c)
212 my ( $self, $c ) = @_;
214 undef $self->{_prepared_read};
217 =item $self->finalize_uploads($c)
221 sub finalize_uploads {
222 my ( $self, $c ) = @_;
224 if ( keys %{ $c->request->uploads } ) {
225 for my $key ( keys %{ $c->request->uploads } ) {
226 my $upload = $c->request->uploads->{$key};
227 unlink map { $_->tempname }
228 grep { -e $_->tempname }
229 ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
234 =item $self->prepare_body($c)
239 my ( $self, $c ) = @_;
241 $self->read_length( $c->request->header('Content-Length') || 0 );
242 my $type = $c->request->header('Content-Type');
244 unless ( $c->request->{_body} ) {
245 $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
248 if ( $self->read_length > 0 ) {
249 while ( my $buffer = $self->read($c) ) {
250 $c->prepare_body_chunk($buffer);
255 =item $self->prepare_body_chunk($c)
259 sub prepare_body_chunk {
260 my ( $self, $c, $chunk ) = @_;
262 $c->request->{_body}->add($chunk);
265 =item $self->prepare_body_parameters($c)
269 sub prepare_body_parameters {
270 my ( $self, $c ) = @_;
271 $c->request->body_parameters( $c->request->{_body}->param );
274 =item $self->prepare_connection($c)
278 sub prepare_connection { }
280 =item $self->prepare_cookies($c)
284 sub prepare_cookies {
285 my ( $self, $c ) = @_;
287 if ( my $header = $c->request->header('Cookie') ) {
288 $c->req->cookies( { CGI::Cookie->parse($header) } );
292 =item $self->prepare_headers($c)
296 sub prepare_headers { }
298 =item $self->prepare_parameters($c)
302 sub prepare_parameters {
303 my ( $self, $c ) = @_;
305 # We copy, no references
306 while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
307 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
308 $c->request->parameters->{$name} = $param;
311 # Merge query and body parameters
312 while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
313 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
314 if ( my $old_param = $c->request->parameters->{$name} ) {
315 if ( ref $old_param eq 'ARRAY' ) {
316 push @{ $c->request->parameters->{$name} },
317 ref $param eq 'ARRAY' ? @$param : $param;
319 else { $c->request->parameters->{$name} = [ $old_param, $param ] }
321 else { $c->request->parameters->{$name} = $param }
325 =item $self->prepare_path($c)
331 =item $self->prepare_request($c)
333 =item $self->prepare_query_parameters($c)
337 sub prepare_query_parameters {
338 my ( $self, $c, $query_string ) = @_;
340 # replace semi-colons
341 $query_string =~ s/;/&/g;
343 my $u = URI->new( '', 'http' );
344 $u->query( $query_string );
345 for my $key ( $u->query_param ) {
346 my @vals = $u->query_param($key);
347 $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
351 =item $self->prepare_read($c)
356 my ( $self, $c ) = @_;
358 # Reset the read position
359 $self->read_position(0);
362 =item $self->prepare_request(@arguments)
366 sub prepare_request { }
368 =item $self->prepare_uploads($c)
372 sub prepare_uploads {
373 my ( $self, $c ) = @_;
374 my $uploads = $c->request->{_body}->upload;
375 for my $name ( keys %$uploads ) {
376 my $files = $uploads->{$name};
377 $files = ref $files eq 'ARRAY' ? $files : [$files];
379 for my $upload (@$files) {
380 my $u = Catalyst::Request::Upload->new;
381 $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
382 $u->type( $u->headers->content_type );
383 $u->tempname( $upload->{tempname} );
384 $u->size( $upload->{size} );
385 $u->filename( $upload->{filename} );
388 $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
390 # support access to the filename as a normal param
391 my @filenames = map { $_->{filename} } @uploads;
392 $c->request->parameters->{$name}
393 = @filenames > 1 ? \@filenames : $filenames[0];
397 =item $self->prepare_write($c)
401 sub prepare_write { }
403 =item $self->read($c, [$maxlength])
408 my ( $self, $c, $maxlength ) = @_;
410 unless ( $self->{_prepared_read} ) {
411 $self->prepare_read($c);
412 $self->{_prepared_read} = 1;
415 my $remaining = $self->read_length - $self->read_position;
416 $maxlength ||= $CHUNKSIZE;
418 # Are we done reading?
419 if ( $remaining <= 0 ) {
420 $self->finalize_read($c);
424 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
425 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
427 $self->read_position( $self->read_position + $rc );
431 Catalyst::Exception->throw(
432 message => "Unknown error reading input: $!" );
436 =item $self->read_chunk($c, $buffer, $length)
438 Each engine inplements read_chunk as its preferred way of reading a chunk
445 =item $self->read_length
447 The length of input data to be read. This is obtained from the Content-Length
450 =item $self->read_position
452 The amount of input data that has already been read.
460 =item $self->write($c, $buffer)
465 my ( $self, $c, $buffer ) = @_;
467 unless ( $self->{_prepared_write} ) {
468 $self->prepare_write($c);
469 $self->{_prepared_write} = 1;
472 print STDOUT $buffer;
479 Sebastian Riedel, <sri@cpan.org>
481 Andy Grundman, <andy@hybridized.org>
485 This program is free software, you can redistribute it and/or modify it under
486 the same terms as Perl itself.