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
160 (pt) Por favor volte mais tarde
161 (ru) Попробуйте еще раз позже
162 (ua) Спробуйте ще раз пізніше
167 $c->res->body( <<"" );
168 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
169 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
170 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
172 <meta http-equiv="Content-Language" content="en" />
173 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
174 <title>$title</title>
175 <script type="text/javascript">
177 function toggleDump (dumpElement) {
178 var e = document.getElementById( dumpElement );
179 if (e.style.display == "none") {
180 e.style.display = "";
183 e.style.display = "none";
188 <style type="text/css">
190 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
191 Tahoma, Arial, helvetica, sans-serif;
193 background-color: #eee;
197 :link, :link:hover, :visited, :visited:hover {
202 background-color: #ccc;
203 border: 1px solid #aaa;
208 background-color: #cce;
209 border: 1px solid #755;
215 background-color: #eee;
216 border: 1px solid #575;
222 background-color: #cce;
223 border: 1px solid #557;
232 div.name h1, div.error p {
240 text-decoration: underline;
246 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
247 /* Browser specific (not valid) styles to make preformatted text wrap */
249 white-space: pre-wrap; /* css-3 */
250 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
251 white-space: -pre-wrap; /* Opera 4-6 */
252 white-space: -o-pre-wrap; /* Opera 7 */
253 word-wrap: break-word; /* Internet Explorer 5.5+ */
259 <div class="error">$error</div>
260 <div class="infos">$infos</div>
261 <div class="name">$name</div>
268 $c->res->{body} .= ( ' ' x 512 );
271 $c->res->status(500);
274 =head2 $self->finalize_headers($c)
276 Abstract method, allows engines to write headers to response
280 sub finalize_headers { }
282 =head2 $self->finalize_read($c)
286 sub finalize_read { }
288 =head2 $self->finalize_uploads($c)
290 Clean up after uploads, deleting temp files.
294 sub finalize_uploads {
295 my ( $self, $c ) = @_;
297 if ( keys %{ $c->request->uploads } ) {
298 for my $key ( keys %{ $c->request->uploads } ) {
299 my $upload = $c->request->uploads->{$key};
300 unlink map { $_->tempname }
301 grep { -e $_->tempname }
302 ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
307 =head2 $self->prepare_body($c)
309 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
314 my ( $self, $c ) = @_;
316 if ( my $length = $self->read_length ) {
317 unless ( $c->request->{_body} ) {
318 my $type = $c->request->header('Content-Type');
319 $c->request->{_body} = HTTP::Body->new( $type, $length );
320 $c->request->{_body}->tmpdir( $c->config->{uploadtmp} )
321 if exists $c->config->{uploadtmp};
324 while ( my $buffer = $self->read($c) ) {
325 $c->prepare_body_chunk($buffer);
328 # paranoia against wrong Content-Length header
329 my $remaining = $length - $self->read_position;
330 if ( $remaining > 0 ) {
331 $self->finalize_read($c);
332 Catalyst::Exception->throw(
333 "Wrong Content-Length value: $length" );
337 # Defined but will cause all body code to be skipped
338 $c->request->{_body} = 0;
342 =head2 $self->prepare_body_chunk($c)
344 Add a chunk to the request body.
348 sub prepare_body_chunk {
349 my ( $self, $c, $chunk ) = @_;
351 $c->request->{_body}->add($chunk);
354 =head2 $self->prepare_body_parameters($c)
356 Sets up parameters from body.
360 sub prepare_body_parameters {
361 my ( $self, $c ) = @_;
363 return unless $c->request->{_body};
365 $c->request->body_parameters( $c->request->{_body}->param );
368 =head2 $self->prepare_connection($c)
370 Abstract method implemented in engines.
374 sub prepare_connection { }
376 =head2 $self->prepare_cookies($c)
378 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
382 sub prepare_cookies {
383 my ( $self, $c ) = @_;
385 if ( my $header = $c->request->header('Cookie') ) {
386 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
390 =head2 $self->prepare_headers($c)
394 sub prepare_headers { }
396 =head2 $self->prepare_parameters($c)
398 sets up parameters from query and post parameters.
402 sub prepare_parameters {
403 my ( $self, $c ) = @_;
405 # We copy, no references
406 foreach my $name ( keys %{ $c->request->query_parameters } ) {
407 my $param = $c->request->query_parameters->{$name};
408 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
409 $c->request->parameters->{$name} = $param;
412 # Merge query and body parameters
413 foreach my $name ( keys %{ $c->request->body_parameters } ) {
414 my $param = $c->request->body_parameters->{$name};
415 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
416 if ( my $old_param = $c->request->parameters->{$name} ) {
417 if ( ref $old_param eq 'ARRAY' ) {
418 push @{ $c->request->parameters->{$name} },
419 ref $param eq 'ARRAY' ? @$param : $param;
421 else { $c->request->parameters->{$name} = [ $old_param, $param ] }
423 else { $c->request->parameters->{$name} = $param }
427 =head2 $self->prepare_path($c)
429 abstract method, implemented by engines.
435 =head2 $self->prepare_request($c)
437 =head2 $self->prepare_query_parameters($c)
439 process the query string and extract query parameters.
443 sub prepare_query_parameters {
444 my ( $self, $c, $query_string ) = @_;
446 # Check for keywords (no = signs)
447 # (yes, index() is faster than a regex :))
448 if ( index( $query_string, '=' ) < 0 ) {
449 $c->request->query_keywords( $self->unescape_uri($query_string) );
455 # replace semi-colons
456 $query_string =~ s/;/&/g;
458 my @params = grep { length $_ } split /&/, $query_string;
460 for my $item ( @params ) {
463 = map { $self->unescape_uri($_) }
464 split( /=/, $item, 2 );
466 $param = $self->unescape_uri($item) unless defined $param;
468 if ( exists $query{$param} ) {
469 if ( ref $query{$param} ) {
470 push @{ $query{$param} }, $value;
473 $query{$param} = [ $query{$param}, $value ];
477 $query{$param} = $value;
481 $c->request->query_parameters( \%query );
484 =head2 $self->prepare_read($c)
486 prepare to read from the engine.
491 my ( $self, $c ) = @_;
493 # Initialize the read position
494 $self->read_position(0);
496 # Initialize the amount of data we think we need to read
497 $self->read_length( $c->request->header('Content-Length') || 0 );
500 =head2 $self->prepare_request(@arguments)
502 Populate the context object from the request object.
506 sub prepare_request { }
508 =head2 $self->prepare_uploads($c)
512 sub prepare_uploads {
513 my ( $self, $c ) = @_;
515 return unless $c->request->{_body};
517 my $uploads = $c->request->{_body}->upload;
518 for my $name ( keys %$uploads ) {
519 my $files = $uploads->{$name};
520 $files = ref $files eq 'ARRAY' ? $files : [$files];
522 for my $upload (@$files) {
523 my $u = Catalyst::Request::Upload->new;
524 $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
525 $u->type( $u->headers->content_type );
526 $u->tempname( $upload->{tempname} );
527 $u->size( $upload->{size} );
528 $u->filename( $upload->{filename} );
531 $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
533 # support access to the filename as a normal param
534 my @filenames = map { $_->{filename} } @uploads;
535 # append, if there's already params with this name
536 if (exists $c->request->parameters->{$name}) {
537 if (ref $c->request->parameters->{$name} eq 'ARRAY') {
538 push @{ $c->request->parameters->{$name} }, @filenames;
541 $c->request->parameters->{$name} =
542 [ $c->request->parameters->{$name}, @filenames ];
546 $c->request->parameters->{$name} =
547 @filenames > 1 ? \@filenames : $filenames[0];
552 =head2 $self->prepare_write($c)
554 Abstract method. Implemented by the engines.
558 sub prepare_write { }
560 =head2 $self->read($c, [$maxlength])
565 my ( $self, $c, $maxlength ) = @_;
567 my $remaining = $self->read_length - $self->read_position;
568 $maxlength ||= $CHUNKSIZE;
570 # Are we done reading?
571 if ( $remaining <= 0 ) {
572 $self->finalize_read($c);
576 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
577 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
579 $self->read_position( $self->read_position + $rc );
583 Catalyst::Exception->throw(
584 message => "Unknown error reading input: $!" );
588 =head2 $self->read_chunk($c, $buffer, $length)
590 Each engine inplements read_chunk as its preferred way of reading a chunk
597 =head2 $self->read_length
599 The length of input data to be read. This is obtained from the Content-Length
602 =head2 $self->read_position
604 The amount of input data that has already been read.
606 =head2 $self->run($c)
608 Start the engine. Implemented by the various engine classes.
614 =head2 $self->write($c, $buffer)
616 Writes the buffer to the client.
621 my ( $self, $c, $buffer ) = @_;
623 unless ( $self->{_prepared_write} ) {
624 $self->prepare_write($c);
625 $self->{_prepared_write} = 1;
628 my $len = length($buffer);
629 my $wrote = syswrite STDOUT, $buffer;
631 if ( !defined $wrote && $! == EWOULDBLOCK ) {
632 # Unable to write on the first try, will retry in the loop below
636 if ( defined $wrote && $wrote < $len ) {
637 # We didn't write the whole buffer
639 my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
640 if ( defined $ret ) {
644 next if $! == EWOULDBLOCK;
648 last if $wrote >= $len;
655 =head2 $self->unescape_uri($uri)
657 Unescapes a given URI using the most efficient method available. Engines such
658 as Apache may implement this using Apache's C-based modules, for example.
663 my ( $self, $str ) = @_;
665 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
670 =head2 $self->finalize_output
672 <obsolete>, see finalize_body
676 Catalyst Contributors, see Catalyst.pm
680 This program is free software, you can redistribute it and/or modify it under
681 the same terms as Perl itself.