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
165 $c->res->body( <<"" );
166 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
167 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
168 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
170 <meta http-equiv="Content-Language" content="en" />
171 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
172 <title>$title</title>
173 <script type="text/javascript">
175 function toggleDump (dumpElement) {
176 var e = document.getElementById( dumpElement );
177 if (e.style.display == "none") {
178 e.style.display = "";
181 e.style.display = "none";
186 <style type="text/css">
188 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
189 Tahoma, Arial, helvetica, sans-serif;
191 background-color: #eee;
195 :link, :link:hover, :visited, :visited:hover {
200 background-color: #ccc;
201 border: 1px solid #aaa;
206 background-color: #cce;
207 border: 1px solid #755;
213 background-color: #eee;
214 border: 1px solid #575;
220 background-color: #cce;
221 border: 1px solid #557;
230 div.name h1, div.error p {
238 text-decoration: underline;
244 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
245 /* Browser specific (not valid) styles to make preformatted text wrap */
247 white-space: pre-wrap; /* css-3 */
248 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
249 white-space: -pre-wrap; /* Opera 4-6 */
250 white-space: -o-pre-wrap; /* Opera 7 */
251 word-wrap: break-word; /* Internet Explorer 5.5+ */
257 <div class="error">$error</div>
258 <div class="infos">$infos</div>
259 <div class="name">$name</div>
266 $c->res->{body} .= ( ' ' x 512 );
269 $c->res->status(500);
272 =head2 $self->finalize_headers($c)
274 Abstract method, allows engines to write headers to response
278 sub finalize_headers { }
280 =head2 $self->finalize_read($c)
284 sub finalize_read { }
286 =head2 $self->finalize_uploads($c)
288 Clean up after uploads, deleting temp files.
292 sub finalize_uploads {
293 my ( $self, $c ) = @_;
295 if ( keys %{ $c->request->uploads } ) {
296 for my $key ( keys %{ $c->request->uploads } ) {
297 my $upload = $c->request->uploads->{$key};
298 unlink map { $_->tempname }
299 grep { -e $_->tempname }
300 ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
305 =head2 $self->prepare_body($c)
307 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
312 my ( $self, $c ) = @_;
314 if ( my $length = $self->read_length ) {
315 unless ( $c->request->{_body} ) {
316 my $type = $c->request->header('Content-Type');
317 $c->request->{_body} = HTTP::Body->new( $type, $length );
318 $c->request->{_body}->tmpdir( $c->config->{uploadtmp} )
319 if exists $c->config->{uploadtmp};
322 while ( my $buffer = $self->read($c) ) {
323 $c->prepare_body_chunk($buffer);
326 # paranoia against wrong Content-Length header
327 my $remaining = $length - $self->read_position;
328 if ( $remaining > 0 ) {
329 $self->finalize_read($c);
330 Catalyst::Exception->throw(
331 "Wrong Content-Length value: $length" );
335 # Defined but will cause all body code to be skipped
336 $c->request->{_body} = 0;
340 =head2 $self->prepare_body_chunk($c)
342 Add a chunk to the request body.
346 sub prepare_body_chunk {
347 my ( $self, $c, $chunk ) = @_;
349 $c->request->{_body}->add($chunk);
352 =head2 $self->prepare_body_parameters($c)
354 Sets up parameters from body.
358 sub prepare_body_parameters {
359 my ( $self, $c ) = @_;
361 return unless $c->request->{_body};
363 $c->request->body_parameters( $c->request->{_body}->param );
366 =head2 $self->prepare_connection($c)
368 Abstract method implemented in engines.
372 sub prepare_connection { }
374 =head2 $self->prepare_cookies($c)
376 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
380 sub prepare_cookies {
381 my ( $self, $c ) = @_;
383 if ( my $header = $c->request->header('Cookie') ) {
384 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
388 =head2 $self->prepare_headers($c)
392 sub prepare_headers { }
394 =head2 $self->prepare_parameters($c)
396 sets up parameters from query and post parameters.
400 sub prepare_parameters {
401 my ( $self, $c ) = @_;
403 # We copy, no references
404 foreach my $name ( keys %{ $c->request->query_parameters } ) {
405 my $param = $c->request->query_parameters->{$name};
406 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
407 $c->request->parameters->{$name} = $param;
410 # Merge query and body parameters
411 foreach my $name ( keys %{ $c->request->body_parameters } ) {
412 my $param = $c->request->body_parameters->{$name};
413 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
414 if ( my $old_param = $c->request->parameters->{$name} ) {
415 if ( ref $old_param eq 'ARRAY' ) {
416 push @{ $c->request->parameters->{$name} },
417 ref $param eq 'ARRAY' ? @$param : $param;
419 else { $c->request->parameters->{$name} = [ $old_param, $param ] }
421 else { $c->request->parameters->{$name} = $param }
425 =head2 $self->prepare_path($c)
427 abstract method, implemented by engines.
433 =head2 $self->prepare_request($c)
435 =head2 $self->prepare_query_parameters($c)
437 process the query string and extract query parameters.
441 sub prepare_query_parameters {
442 my ( $self, $c, $query_string ) = @_;
444 # Check for keywords (no = signs)
445 # (yes, index() is faster than a regex :))
446 if ( index( $query_string, '=' ) < 0 ) {
447 $c->request->query_keywords( $self->unescape_uri($query_string) );
453 # replace semi-colons
454 $query_string =~ s/;/&/g;
456 my @params = grep { length $_ } split /&/, $query_string;
458 for my $item ( @params ) {
461 = map { $self->unescape_uri($_) }
462 split( /=/, $item, 2 );
464 $param = $self->unescape_uri($item) unless defined $param;
466 if ( exists $query{$param} ) {
467 if ( ref $query{$param} ) {
468 push @{ $query{$param} }, $value;
471 $query{$param} = [ $query{$param}, $value ];
475 $query{$param} = $value;
479 $c->request->query_parameters( \%query );
482 =head2 $self->prepare_read($c)
484 prepare to read from the engine.
489 my ( $self, $c ) = @_;
491 # Initialize the read position
492 $self->read_position(0);
494 # Initialize the amount of data we think we need to read
495 $self->read_length( $c->request->header('Content-Length') || 0 );
498 =head2 $self->prepare_request(@arguments)
500 Populate the context object from the request object.
504 sub prepare_request { }
506 =head2 $self->prepare_uploads($c)
510 sub prepare_uploads {
511 my ( $self, $c ) = @_;
513 return unless $c->request->{_body};
515 my $uploads = $c->request->{_body}->upload;
516 for my $name ( keys %$uploads ) {
517 my $files = $uploads->{$name};
518 $files = ref $files eq 'ARRAY' ? $files : [$files];
520 for my $upload (@$files) {
521 my $u = Catalyst::Request::Upload->new;
522 $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
523 $u->type( $u->headers->content_type );
524 $u->tempname( $upload->{tempname} );
525 $u->size( $upload->{size} );
526 $u->filename( $upload->{filename} );
529 $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
531 # support access to the filename as a normal param
532 my @filenames = map { $_->{filename} } @uploads;
533 # append, if there's already params with this name
534 if (exists $c->request->parameters->{$name}) {
535 if (ref $c->request->parameters->{$name} eq 'ARRAY') {
536 push @{ $c->request->parameters->{$name} }, @filenames;
539 $c->request->parameters->{$name} =
540 [ $c->request->parameters->{$name}, @filenames ];
544 $c->request->parameters->{$name} =
545 @filenames > 1 ? \@filenames : $filenames[0];
550 =head2 $self->prepare_write($c)
552 Abstract method. Implemented by the engines.
556 sub prepare_write { }
558 =head2 $self->read($c, [$maxlength])
563 my ( $self, $c, $maxlength ) = @_;
565 my $remaining = $self->read_length - $self->read_position;
566 $maxlength ||= $CHUNKSIZE;
568 # Are we done reading?
569 if ( $remaining <= 0 ) {
570 $self->finalize_read($c);
574 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
575 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
577 $self->read_position( $self->read_position + $rc );
581 Catalyst::Exception->throw(
582 message => "Unknown error reading input: $!" );
586 =head2 $self->read_chunk($c, $buffer, $length)
588 Each engine inplements read_chunk as its preferred way of reading a chunk
595 =head2 $self->read_length
597 The length of input data to be read. This is obtained from the Content-Length
600 =head2 $self->read_position
602 The amount of input data that has already been read.
604 =head2 $self->run($c)
606 Start the engine. Implemented by the various engine classes.
612 =head2 $self->write($c, $buffer)
614 Writes the buffer to the client.
619 my ( $self, $c, $buffer ) = @_;
621 unless ( $self->{_prepared_write} ) {
622 $self->prepare_write($c);
623 $self->{_prepared_write} = 1;
626 my $len = length($buffer);
627 my $wrote = syswrite STDOUT, $buffer;
629 if ( !defined $wrote && $! == EWOULDBLOCK ) {
630 # Unable to write on the first try, will retry in the loop below
634 if ( defined $wrote && $wrote < $len ) {
635 # We didn't write the whole buffer
637 my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
638 if ( defined $ret ) {
642 next if $! == EWOULDBLOCK;
646 last if $wrote >= $len;
653 =head2 $self->unescape_uri($uri)
655 Unescapes a given URI using the most efficient method available. Engines such
656 as Apache may implement this using Apache's C-based modules, for example.
661 my ( $self, $str ) = @_;
663 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
668 =head2 $self->finalize_output
670 <obsolete>, see finalize_body
674 Catalyst Contributors, see Catalyst.pm
678 This program is free software, you can redistribute it and/or modify it under
679 the same terms as Perl itself.