1 package Catalyst::Engine;
4 with 'MooseX::Emulate::Class::Accessor::Fast';
6 use CGI::Simple::Cookie;
7 use Data::Dump qw/dump/;
8 use Errno 'EWOULDBLOCK';
15 # input position and length
16 has read_length => (is => 'rw');
17 has read_position => (is => 'rw');
20 use overload '""' => sub { return ref shift }, fallback => 1;
22 # Amount of data to read from input on each pass
23 our $CHUNKSIZE = 64 * 1024;
27 Catalyst::Engine - The Catalyst Engine
38 =head2 $self->finalize_body($c)
40 Finalize body. Prints the response output.
45 my ( $self, $c ) = @_;
46 my $body = $c->response->body;
47 no warnings 'uninitialized';
48 if ( Scalar::Util::blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
49 while ( !eof $body ) {
50 read $body, my ($buffer), $CHUNKSIZE;
51 last unless $self->write( $c, $buffer );
56 $self->write( $c, $body );
60 =head2 $self->finalize_cookies($c)
62 Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
67 sub finalize_cookies {
68 my ( $self, $c ) = @_;
71 my $response = $c->response;
73 while( my($name, $val) = each %{ $response->cookies } ) {
76 Scalar::Util::blessed($val)
78 : CGI::Simple::Cookie->new(
80 -value => $val->{value},
81 -expires => $val->{expires},
82 -domain => $val->{domain},
83 -path => $val->{path},
84 -secure => $val->{secure} || 0
88 push @cookies, $cookie->as_string;
91 for my $cookie (@cookies) {
92 $response->headers->push_header( 'Set-Cookie' => $cookie );
96 =head2 $self->finalize_error($c)
98 Output an apropriate error message, called if there's an error in $c
99 after the dispatch has finished. Will output debug messages if Catalyst
100 is in debug mode, or a `please come back later` message otherwise.
105 my ( $self, $c ) = @_;
107 $c->res->content_type('text/html; charset=utf-8');
108 my $name = $c->config->{name} || join(' ', split('::', ref $c));
110 my ( $title, $error, $infos );
114 $error = join '', map {
115 '<p><code class="error">'
116 . encode_entities($_)
119 $error ||= 'No output';
120 $error = qq{<pre wrap="">$error</pre>};
121 $title = $name = "$name on Catalyst $Catalyst::VERSION";
122 $name = "<h1>$name</h1>";
124 # Don't show context in the dump
125 delete $c->req->{_context};
126 delete $c->res->{_context};
128 # Don't show body parser in the dump
129 delete $c->req->{_body};
131 # Don't show response header state in dump
132 delete $c->res->{_finalized_headers};
136 for my $dump ( $c->dump_these ) {
137 my $name = $dump->[0];
138 my $value = encode_entities( dump( $dump->[1] ));
139 push @infos, sprintf <<"EOF", $name, $value;
140 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
142 <pre wrap="">%s</pre>
147 $infos = join "\n", @infos;
154 (en) Please come back later
155 (fr) SVP veuillez revenir plus tard
156 (de) Bitte versuchen sie es spaeter nocheinmal
157 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
158 (no) Vennligst prov igjen senere
159 (dk) Venligst prov igen senere
160 (pl) Prosze sprobowac pozniej
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 my $request = $c->request;
296 while( my($key,$upload) = each %{ $request->uploads } ) {
297 unlink grep { -e $_ } map { $_->tempname }
298 (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
303 =head2 $self->prepare_body($c)
305 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
310 my ( $self, $c ) = @_;
312 if ( my $length = $self->read_length ) {
313 my $request = $c->request;
314 unless ( $request->{_body} ) {
315 my $type = $request->header('Content-Type');
316 $request->{_body} = HTTP::Body->new( $type, $length );
317 $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 my $request = $c->request;
403 my $parameters = $request->parameters;
404 my $body_parameters = $request->body_parameters;
405 my $query_parameters = $request->query_parameters;
406 # We copy, no references
407 while( my($name, $param) = each(%$query_parameters) ) {
408 $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
411 # Merge query and body parameters
412 while( my($name, $param) = each(%$body_parameters) ) {
413 my @values = ref $param eq 'ARRAY' ? @$param : ($param);
414 if ( my $existing = $parameters->{$name} ) {
415 unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
417 $parameters->{$name} = @values > 1 ? \@values : $values[0];
421 =head2 $self->prepare_path($c)
423 abstract method, implemented by engines.
429 =head2 $self->prepare_request($c)
431 =head2 $self->prepare_query_parameters($c)
433 process the query string and extract query parameters.
437 sub prepare_query_parameters {
438 my ( $self, $c, $query_string ) = @_;
440 # Check for keywords (no = signs)
441 # (yes, index() is faster than a regex :))
442 if ( index( $query_string, '=' ) < 0 ) {
443 $c->request->query_keywords( $self->unescape_uri($query_string) );
449 # replace semi-colons
450 $query_string =~ s/;/&/g;
452 my @params = split /&/, $query_string;
454 for my $item ( @params ) {
457 = map { $self->unescape_uri($_) }
458 split( /=/, $item, 2 );
460 $param = $self->unescape_uri($item) unless defined $param;
462 if ( exists $query{$param} ) {
463 if ( ref $query{$param} ) {
464 push @{ $query{$param} }, $value;
467 $query{$param} = [ $query{$param}, $value ];
471 $query{$param} = $value;
475 $c->request->query_parameters( \%query );
478 =head2 $self->prepare_read($c)
480 prepare to read from the engine.
485 my ( $self, $c ) = @_;
487 # Initialize the read position
488 $self->read_position(0);
490 # Initialize the amount of data we think we need to read
491 $self->read_length( $c->request->header('Content-Length') || 0 );
494 =head2 $self->prepare_request(@arguments)
496 Populate the context object from the request object.
500 sub prepare_request { }
502 =head2 $self->prepare_uploads($c)
506 sub prepare_uploads {
507 my ( $self, $c ) = @_;
509 my $request = $c->request;
510 return unless $request->{_body};
512 my $uploads = $request->{_body}->upload;
513 my $parameters = $request->parameters;
514 while(my($name,$files) = each(%$uploads) ) {
516 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
517 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
518 my $u = Catalyst::Request::Upload->new
520 size => $upload->{size},
521 type => $headers->content_type,
523 tempname => $upload->{tempname},
524 filename => $upload->{filename},
528 $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 $parameters->{$name}) {
534 if (ref $parameters->{$name} eq 'ARRAY') {
535 push @{ $parameters->{$name} }, @filenames;
538 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
542 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
547 =head2 $self->prepare_write($c)
549 Abstract method. Implemented by the engines.
553 sub prepare_write { }
555 =head2 $self->read($c, [$maxlength])
560 my ( $self, $c, $maxlength ) = @_;
562 my $remaining = $self->read_length - $self->read_position;
563 $maxlength ||= $CHUNKSIZE;
565 # Are we done reading?
566 if ( $remaining <= 0 ) {
567 $self->finalize_read($c);
571 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
572 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
574 $self->read_position( $self->read_position + $rc );
578 Catalyst::Exception->throw(
579 message => "Unknown error reading input: $!" );
583 =head2 $self->read_chunk($c, $buffer, $length)
585 Each engine inplements read_chunk as its preferred way of reading a chunk
592 =head2 $self->read_length
594 The length of input data to be read. This is obtained from the Content-Length
597 =head2 $self->read_position
599 The amount of input data that has already been read.
601 =head2 $self->run($c)
603 Start the engine. Implemented by the various engine classes.
609 =head2 $self->write($c, $buffer)
611 Writes the buffer to the client.
616 my ( $self, $c, $buffer ) = @_;
618 unless ( $self->{_prepared_write} ) {
619 $self->prepare_write($c);
620 $self->{_prepared_write} = 1;
623 my $len = length($buffer);
624 my $wrote = syswrite STDOUT, $buffer;
626 if ( !defined $wrote && $! == EWOULDBLOCK ) {
627 # Unable to write on the first try, will retry in the loop below
631 if ( defined $wrote && $wrote < $len ) {
632 # We didn't write the whole buffer
634 my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
635 if ( defined $ret ) {
639 next if $! == EWOULDBLOCK;
643 last if $wrote >= $len;
650 =head2 $self->unescape_uri($uri)
652 Unescapes a given URI using the most efficient method available. Engines such
653 as Apache may implement this using Apache's C-based modules, for example.
658 my ( $self, $str ) = @_;
660 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
665 =head2 $self->finalize_output
667 <obsolete>, see finalize_body
671 Sebastian Riedel, <sri@cpan.org>
673 Andy Grundman, <andy@hybridized.org>
677 This program is free software, you can redistribute it and/or modify it under
678 the same terms as Perl itself.