1 package Catalyst::Engine;
4 use base 'Class::Accessor::Fast';
5 use CGI::Simple::Cookie;
6 use Data::Dump qw/dump/;
7 use Errno 'EWOULDBLOCK';
14 # input position and length
15 __PACKAGE__->mk_accessors(qw/read_position read_length/);
18 use overload '""' => sub { return ref shift }, fallback => 1;
20 # Amount of data to read from input on each pass
21 our $CHUNKSIZE = 64 * 1024;
25 Catalyst::Engine - The Catalyst Engine
36 =head2 $self->finalize_body($c)
38 Finalize body. Prints the response output.
43 my ( $self, $c ) = @_;
44 my $body = $c->response->body;
45 no warnings 'uninitialized';
46 if ( Scalar::Util::blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
47 while ( !eof $body ) {
48 read $body, my ($buffer), $CHUNKSIZE;
49 last unless $self->write( $c, $buffer );
54 $self->write( $c, $body );
58 =head2 $self->finalize_cookies($c)
60 Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
65 sub finalize_cookies {
66 my ( $self, $c ) = @_;
70 foreach my $name ( keys %{ $c->response->cookies } ) {
72 my $val = $c->response->cookies->{$name};
75 Scalar::Util::blessed($val)
77 : CGI::Simple::Cookie->new(
79 -value => $val->{value},
80 -expires => $val->{expires},
81 -domain => $val->{domain},
82 -path => $val->{path},
83 -secure => $val->{secure} || 0
87 push @cookies, $cookie->as_string;
90 for my $cookie (@cookies) {
91 $c->res->headers->push_header( 'Set-Cookie' => $cookie );
95 =head2 $self->finalize_error($c)
97 Output an apropriate error message, called if there's an error in $c
98 after the dispatch has finished. Will output debug messages if Catalyst
99 is in debug mode, or a `please come back later` message otherwise.
104 my ( $self, $c ) = @_;
106 $c->res->content_type('text/html; charset=utf-8');
107 my $name = $c->config->{name} || join(' ', split('::', ref $c));
109 my ( $title, $error, $infos );
113 $error = join '', map {
114 '<p><code class="error">'
115 . encode_entities($_)
118 $error ||= 'No output';
119 $error = qq{<pre wrap="">$error</pre>};
120 $title = $name = "$name on Catalyst $Catalyst::VERSION";
121 $name = "<h1>$name</h1>";
123 # Don't show context in the dump
124 delete $c->req->{_context};
125 delete $c->res->{_context};
127 # Don't show body parser in the dump
128 delete $c->req->{_body};
130 # Don't show response header state in dump
131 delete $c->res->{_finalized_headers};
135 for my $dump ( $c->dump_these ) {
136 my $name = $dump->[0];
137 my $value = encode_entities( dump( $dump->[1] ));
138 push @infos, sprintf <<"EOF", $name, $value;
139 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
141 <pre wrap="">%s</pre>
146 $infos = join "\n", @infos;
153 (en) Please come back later
154 (fr) SVP veuillez revenir plus tard
155 (de) Bitte versuchen sie es spaeter nocheinmal
156 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
157 (no) Vennligst prov igjen senere
158 (dk) Venligst prov igen senere
159 (pl) Prosze sprobowac pozniej
164 $c->res->body( <<"" );
165 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
166 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
167 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
169 <meta http-equiv="Content-Language" content="en" />
170 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
171 <title>$title</title>
172 <script type="text/javascript">
174 function toggleDump (dumpElement) {
175 var e = document.getElementById( dumpElement );
176 if (e.style.display == "none") {
177 e.style.display = "";
180 e.style.display = "none";
185 <style type="text/css">
187 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
188 Tahoma, Arial, helvetica, sans-serif;
190 background-color: #eee;
194 :link, :link:hover, :visited, :visited:hover {
199 background-color: #ccc;
200 border: 1px solid #aaa;
205 background-color: #cce;
206 border: 1px solid #755;
212 background-color: #eee;
213 border: 1px solid #575;
219 background-color: #cce;
220 border: 1px solid #557;
229 div.name h1, div.error p {
237 text-decoration: underline;
243 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
244 /* Browser specific (not valid) styles to make preformatted text wrap */
246 white-space: pre-wrap; /* css-3 */
247 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
248 white-space: -pre-wrap; /* Opera 4-6 */
249 white-space: -o-pre-wrap; /* Opera 7 */
250 word-wrap: break-word; /* Internet Explorer 5.5+ */
256 <div class="error">$error</div>
257 <div class="infos">$infos</div>
258 <div class="name">$name</div>
265 $c->res->{body} .= ( ' ' x 512 );
268 $c->res->status(500);
271 =head2 $self->finalize_headers($c)
273 Abstract method, allows engines to write headers to response
277 sub finalize_headers { }
279 =head2 $self->finalize_read($c)
283 sub finalize_read { }
285 =head2 $self->finalize_uploads($c)
287 Clean up after uploads, deleting temp files.
291 sub finalize_uploads {
292 my ( $self, $c ) = @_;
294 if ( keys %{ $c->request->uploads } ) {
295 for my $key ( keys %{ $c->request->uploads } ) {
296 my $upload = $c->request->uploads->{$key};
297 unlink map { $_->tempname }
298 grep { -e $_->tempname }
299 ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
304 =head2 $self->prepare_body($c)
306 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
311 my ( $self, $c ) = @_;
313 if ( my $length = $self->read_length ) {
314 unless ( $c->request->{_body} ) {
315 my $type = $c->request->header('Content-Type');
316 $c->request->{_body} = HTTP::Body->new( $type, $length );
317 $c->request->{_body}->{tmpdir} = $c->config->{uploadtmp}
318 if exists $c->config->{uploadtmp};
321 while ( my $buffer = $self->read($c) ) {
322 $c->prepare_body_chunk($buffer);
325 # paranoia against wrong Content-Length header
326 my $remaining = $length - $self->read_position;
327 if ( $remaining > 0 ) {
328 $self->finalize_read($c);
329 Catalyst::Exception->throw(
330 "Wrong Content-Length value: $length" );
334 # Defined but will cause all body code to be skipped
335 $c->request->{_body} = 0;
339 =head2 $self->prepare_body_chunk($c)
341 Add a chunk to the request body.
345 sub prepare_body_chunk {
346 my ( $self, $c, $chunk ) = @_;
348 $c->request->{_body}->add($chunk);
351 =head2 $self->prepare_body_parameters($c)
353 Sets up parameters from body.
357 sub prepare_body_parameters {
358 my ( $self, $c ) = @_;
360 return unless $c->request->{_body};
362 $c->request->body_parameters( $c->request->{_body}->param );
365 =head2 $self->prepare_connection($c)
367 Abstract method implemented in engines.
371 sub prepare_connection { }
373 =head2 $self->prepare_cookies($c)
375 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
379 sub prepare_cookies {
380 my ( $self, $c ) = @_;
382 if ( my $header = $c->request->header('Cookie') ) {
383 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
387 =head2 $self->prepare_headers($c)
391 sub prepare_headers { }
393 =head2 $self->prepare_parameters($c)
395 sets up parameters from query and post parameters.
399 sub prepare_parameters {
400 my ( $self, $c ) = @_;
402 # We copy, no references
403 foreach my $name ( keys %{ $c->request->query_parameters } ) {
404 my $param = $c->request->query_parameters->{$name};
405 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
406 $c->request->parameters->{$name} = $param;
409 # Merge query and body parameters
410 foreach my $name ( keys %{ $c->request->body_parameters } ) {
411 my $param = $c->request->body_parameters->{$name};
412 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
413 if ( my $old_param = $c->request->parameters->{$name} ) {
414 if ( ref $old_param eq 'ARRAY' ) {
415 push @{ $c->request->parameters->{$name} },
416 ref $param eq 'ARRAY' ? @$param : $param;
418 else { $c->request->parameters->{$name} = [ $old_param, $param ] }
420 else { $c->request->parameters->{$name} = $param }
424 =head2 $self->prepare_path($c)
426 abstract method, implemented by engines.
432 =head2 $self->prepare_request($c)
434 =head2 $self->prepare_query_parameters($c)
436 process the query string and extract query parameters.
440 sub prepare_query_parameters {
441 my ( $self, $c, $query_string ) = @_;
443 # Check for keywords (no = signs)
444 # (yes, index() is faster than a regex :))
445 if ( index( $query_string, '=' ) < 0 ) {
446 $c->request->query_keywords( $self->unescape_uri($query_string) );
452 # replace semi-colons
453 $query_string =~ s/;/&/g;
455 my @params = split /&/, $query_string;
457 for my $item ( @params ) {
460 = map { $self->unescape_uri($_) }
461 split( /=/, $item, 2 );
463 $param = $self->unescape_uri($item) unless defined $param;
465 if ( exists $query{$param} ) {
466 if ( ref $query{$param} ) {
467 push @{ $query{$param} }, $value;
470 $query{$param} = [ $query{$param}, $value ];
474 $query{$param} = $value;
478 $c->request->query_parameters( \%query );
481 =head2 $self->prepare_read($c)
483 prepare to read from the engine.
488 my ( $self, $c ) = @_;
490 # Initialize the read position
491 $self->read_position(0);
493 # Initialize the amount of data we think we need to read
494 $self->read_length( $c->request->header('Content-Length') || 0 );
497 =head2 $self->prepare_request(@arguments)
499 Populate the context object from the request object.
503 sub prepare_request { }
505 =head2 $self->prepare_uploads($c)
509 sub prepare_uploads {
510 my ( $self, $c ) = @_;
512 return unless $c->request->{_body};
514 my $uploads = $c->request->{_body}->upload;
515 for my $name ( keys %$uploads ) {
516 my $files = $uploads->{$name};
517 $files = ref $files eq 'ARRAY' ? $files : [$files];
519 for my $upload (@$files) {
520 my $u = Catalyst::Request::Upload->new;
521 $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
522 $u->type( $u->headers->content_type );
523 $u->tempname( $upload->{tempname} );
524 $u->size( $upload->{size} );
525 $u->filename( $upload->{filename} );
528 $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
530 # support access to the filename as a normal param
531 my @filenames = map { $_->{filename} } @uploads;
532 # append, if there's already params with this name
533 if (exists $c->request->parameters->{$name}) {
534 if (ref $c->request->parameters->{$name} eq 'ARRAY') {
535 push @{ $c->request->parameters->{$name} }, @filenames;
538 $c->request->parameters->{$name} =
539 [ $c->request->parameters->{$name}, @filenames ];
543 $c->request->parameters->{$name} =
544 @filenames > 1 ? \@filenames : $filenames[0];
549 =head2 $self->prepare_write($c)
551 Abstract method. Implemented by the engines.
555 sub prepare_write { }
557 =head2 $self->read($c, [$maxlength])
562 my ( $self, $c, $maxlength ) = @_;
564 my $remaining = $self->read_length - $self->read_position;
565 $maxlength ||= $CHUNKSIZE;
567 # Are we done reading?
568 if ( $remaining <= 0 ) {
569 $self->finalize_read($c);
573 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
574 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
576 $self->read_position( $self->read_position + $rc );
580 Catalyst::Exception->throw(
581 message => "Unknown error reading input: $!" );
585 =head2 $self->read_chunk($c, $buffer, $length)
587 Each engine inplements read_chunk as its preferred way of reading a chunk
594 =head2 $self->read_length
596 The length of input data to be read. This is obtained from the Content-Length
599 =head2 $self->read_position
601 The amount of input data that has already been read.
603 =head2 $self->run($c)
605 Start the engine. Implemented by the various engine classes.
611 =head2 $self->write($c, $buffer)
613 Writes the buffer to the client.
618 my ( $self, $c, $buffer ) = @_;
620 unless ( $self->{_prepared_write} ) {
621 $self->prepare_write($c);
622 $self->{_prepared_write} = 1;
625 my $len = length($buffer);
626 my $wrote = syswrite STDOUT, $buffer;
628 if ( !defined $wrote && $! == EWOULDBLOCK ) {
629 # Unable to write on the first try, will retry in the loop below
633 if ( defined $wrote && $wrote < $len ) {
634 # We didn't write the whole buffer
636 my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
637 if ( defined $ret ) {
641 next if $! == EWOULDBLOCK;
645 last if $wrote >= $len;
652 =head2 $self->unescape_uri($uri)
654 Unescapes a given URI using the most efficient method available. Engines such
655 as Apache may implement this using Apache's C-based modules, for example.
660 my ( $self, $str ) = @_;
662 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
667 =head2 $self->finalize_output
669 <obsolete>, see finalize_body
673 Sebastian Riedel, <sri@cpan.org>
675 Andy Grundman, <andy@hybridized.org>
679 This program is free software, you can redistribute it and/or modify it under
680 the same terms as Perl itself.