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';
14 use namespace::clean -except => 'meta';
16 # input position and length
17 has read_length => (is => 'rw');
18 has read_position => (is => 'rw');
20 has _prepared_write => (is => 'rw');
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 ( 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 foreach my $name (keys %{ $response->cookies }) {
75 my $val = $response->cookies->{$name};
80 : CGI::Simple::Cookie->new(
82 -value => $val->{value},
83 -expires => $val->{expires},
84 -domain => $val->{domain},
85 -path => $val->{path},
86 -secure => $val->{secure} || 0
90 push @cookies, $cookie->as_string;
93 for my $cookie (@cookies) {
94 $response->headers->push_header( 'Set-Cookie' => $cookie );
98 =head2 $self->finalize_error($c)
100 Output an appropriate error message. Called if there's an error in $c
101 after the dispatch has finished. Will output debug messages if Catalyst
102 is in debug mode, or a `please come back later` message otherwise.
107 my ( $self, $c ) = @_;
109 $c->res->content_type('text/html; charset=utf-8');
110 my $name = $c->config->{name} || join(' ', split('::', ref $c));
112 my ( $title, $error, $infos );
116 $error = join '', map {
117 '<p><code class="error">'
118 . encode_entities($_)
121 $error ||= 'No output';
122 $error = qq{<pre wrap="">$error</pre>};
123 $title = $name = "$name on Catalyst $Catalyst::VERSION";
124 $name = "<h1>$name</h1>";
126 # Don't show context in the dump
127 $c->req->_clear_context;
128 $c->res->_clear_context;
130 # Don't show body parser in the dump
131 $c->req->_clear_body;
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 my $request = $c->request;
298 foreach my $key (keys %{ $request->uploads }) {
299 my $upload = $request->uploads->{$key};
300 unlink grep { -e $_ } map { $_->tempname }
301 (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
306 =head2 $self->prepare_body($c)
308 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
313 my ( $self, $c ) = @_;
315 if ( my $length = $self->read_length ) {
316 my $request = $c->request;
317 unless ( $request->_body ) {
318 my $type = $request->header('Content-Type');
319 $request->_body(HTTP::Body->new( $type, $length ));
320 $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 my $request = $c->request;
406 my $parameters = $request->parameters;
407 my $body_parameters = $request->body_parameters;
408 my $query_parameters = $request->query_parameters;
409 # We copy, no references
410 foreach my $name (keys %$query_parameters) {
411 my $param = $query_parameters->{$name};
412 $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
415 # Merge query and body parameters
416 foreach my $name (keys %$body_parameters) {
417 my $param = $body_parameters->{$name};
418 my @values = ref $param eq 'ARRAY' ? @$param : ($param);
419 if ( my $existing = $parameters->{$name} ) {
420 unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
422 $parameters->{$name} = @values > 1 ? \@values : $values[0];
426 =head2 $self->prepare_path($c)
428 abstract method, implemented by engines.
434 =head2 $self->prepare_request($c)
436 =head2 $self->prepare_query_parameters($c)
438 process the query string and extract query parameters.
442 sub prepare_query_parameters {
443 my ( $self, $c, $query_string ) = @_;
445 # Check for keywords (no = signs)
446 # (yes, index() is faster than a regex :))
447 if ( index( $query_string, '=' ) < 0 ) {
448 $c->request->query_keywords( $self->unescape_uri($query_string) );
454 # replace semi-colons
455 $query_string =~ s/;/&/g;
457 my @params = grep { length $_ } split /&/, $query_string;
459 for my $item ( @params ) {
462 = map { $self->unescape_uri($_) }
463 split( /=/, $item, 2 );
465 $param = $self->unescape_uri($item) unless defined $param;
467 if ( exists $query{$param} ) {
468 if ( ref $query{$param} ) {
469 push @{ $query{$param} }, $value;
472 $query{$param} = [ $query{$param}, $value ];
476 $query{$param} = $value;
480 $c->request->query_parameters( \%query );
483 =head2 $self->prepare_read($c)
485 prepare to read from the engine.
490 my ( $self, $c ) = @_;
492 # Initialize the read position
493 $self->read_position(0);
495 # Initialize the amount of data we think we need to read
496 $self->read_length( $c->request->header('Content-Length') || 0 );
499 =head2 $self->prepare_request(@arguments)
501 Populate the context object from the request object.
505 sub prepare_request { }
507 =head2 $self->prepare_uploads($c)
511 sub prepare_uploads {
512 my ( $self, $c ) = @_;
514 my $request = $c->request;
515 return unless $request->_body;
517 my $uploads = $request->_body->upload;
518 my $parameters = $request->parameters;
519 foreach my $name (keys %$uploads) {
520 my $files = $uploads->{$name};
522 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
523 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
524 my $u = Catalyst::Request::Upload->new
526 size => $upload->{size},
527 type => $headers->content_type,
529 tempname => $upload->{tempname},
530 filename => $upload->{filename},
534 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
536 # support access to the filename as a normal param
537 my @filenames = map { $_->{filename} } @uploads;
538 # append, if there's already params with this name
539 if (exists $parameters->{$name}) {
540 if (ref $parameters->{$name} eq 'ARRAY') {
541 push @{ $parameters->{$name} }, @filenames;
544 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
548 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
553 =head2 $self->prepare_write($c)
555 Abstract method. Implemented by the engines.
559 sub prepare_write { }
561 =head2 $self->read($c, [$maxlength])
566 my ( $self, $c, $maxlength ) = @_;
568 my $remaining = $self->read_length - $self->read_position;
569 $maxlength ||= $CHUNKSIZE;
571 # Are we done reading?
572 if ( $remaining <= 0 ) {
573 $self->finalize_read($c);
577 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
578 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
580 $self->read_position( $self->read_position + $rc );
584 Catalyst::Exception->throw(
585 message => "Unknown error reading input: $!" );
589 =head2 $self->read_chunk($c, $buffer, $length)
591 Each engine implements read_chunk as its preferred way of reading a chunk
598 =head2 $self->read_length
600 The length of input data to be read. This is obtained from the Content-Length
603 =head2 $self->read_position
605 The amount of input data that has already been read.
607 =head2 $self->run($c)
609 Start the engine. Implemented by the various engine classes.
615 =head2 $self->write($c, $buffer)
617 Writes the buffer to the client.
622 my ( $self, $c, $buffer ) = @_;
624 unless ( $self->_prepared_write ) {
625 $self->prepare_write($c);
626 $self->_prepared_write(1);
629 return 0 if !defined $buffer;
631 my $len = length($buffer);
632 my $wrote = syswrite STDOUT, $buffer;
634 if ( !defined $wrote && $! == EWOULDBLOCK ) {
635 # Unable to write on the first try, will retry in the loop below
639 if ( defined $wrote && $wrote < $len ) {
640 # We didn't write the whole buffer
642 my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
643 if ( defined $ret ) {
647 next if $! == EWOULDBLOCK;
651 last if $wrote >= $len;
658 =head2 $self->unescape_uri($uri)
660 Unescapes a given URI using the most efficient method available. Engines such
661 as Apache may implement this using Apache's C-based modules, for example.
666 my ( $self, $str ) = @_;
668 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
673 =head2 $self->finalize_output
675 <obsolete>, see finalize_body
679 Catalyst Contributors, see Catalyst.pm
683 This program is free software, you can redistribute it and/or modify it under
684 the same terms as Perl itself.