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 has env => (is => 'rw');
18 # input position and length
19 has read_length => (is => 'rw');
20 has read_position => (is => 'rw');
22 has _prepared_write => (is => 'rw');
24 # Amount of data to read from input on each pass
25 our $CHUNKSIZE = 64 * 1024;
29 Catalyst::Engine - The Catalyst Engine
40 =head2 $self->finalize_body($c)
42 Finalize body. Prints the response output.
47 my ( $self, $c ) = @_;
48 my $body = $c->response->body;
49 no warnings 'uninitialized';
50 if ( blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
53 read $body, my ($buffer), $CHUNKSIZE;
54 last unless $self->write( $c, $buffer );
60 $self->write( $c, $body );
64 =head2 $self->finalize_cookies($c)
66 Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
71 sub finalize_cookies {
72 my ( $self, $c ) = @_;
75 my $response = $c->response;
77 foreach my $name (keys %{ $response->cookies }) {
79 my $val = $response->cookies->{$name};
84 : CGI::Simple::Cookie->new(
86 -value => $val->{value},
87 -expires => $val->{expires},
88 -domain => $val->{domain},
89 -path => $val->{path},
90 -secure => $val->{secure} || 0,
91 -httponly => $val->{httponly} || 0,
95 push @cookies, $cookie->as_string;
98 for my $cookie (@cookies) {
99 $response->headers->push_header( 'Set-Cookie' => $cookie );
103 =head2 $self->finalize_error($c)
105 Output an appropriate error message. Called if there's an error in $c
106 after the dispatch has finished. Will output debug messages if Catalyst
107 is in debug mode, or a `please come back later` message otherwise.
112 my ( $self, $c ) = @_;
114 $c->res->content_type('text/html; charset=utf-8');
115 my $name = $c->config->{name} || join(' ', split('::', ref $c));
117 my ( $title, $error, $infos );
121 $error = join '', map {
122 '<p><code class="error">'
123 . encode_entities($_)
126 $error ||= 'No output';
127 $error = qq{<pre wrap="">$error</pre>};
128 $title = $name = "$name on Catalyst $Catalyst::VERSION";
129 $name = "<h1>$name</h1>";
131 # Don't show context in the dump
132 $c->req->_clear_context;
133 $c->res->_clear_context;
135 # Don't show body parser in the dump
136 $c->req->_clear_body;
140 for my $dump ( $c->dump_these ) {
141 my $name = $dump->[0];
142 my $value = encode_entities( dump( $dump->[1] ));
143 push @infos, sprintf <<"EOF", $name, $value;
144 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
146 <pre wrap="">%s</pre>
151 $infos = join "\n", @infos;
158 (en) Please come back later
159 (fr) SVP veuillez revenir plus tard
160 (de) Bitte versuchen sie es spaeter nocheinmal
161 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
162 (no) Vennligst prov igjen senere
163 (dk) Venligst prov igen senere
164 (pl) Prosze sprobowac pozniej
165 (pt) Por favor volte mais tarde
166 (ru) Попробуйте еще раз позже
167 (ua) Спробуйте ще раз пізніше
172 $c->res->body( <<"" );
173 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
174 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
175 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
177 <meta http-equiv="Content-Language" content="en" />
178 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
179 <title>$title</title>
180 <script type="text/javascript">
182 function toggleDump (dumpElement) {
183 var e = document.getElementById( dumpElement );
184 if (e.style.display == "none") {
185 e.style.display = "";
188 e.style.display = "none";
193 <style type="text/css">
195 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
196 Tahoma, Arial, helvetica, sans-serif;
198 background-color: #eee;
202 :link, :link:hover, :visited, :visited:hover {
207 background-color: #ccc;
208 border: 1px solid #aaa;
213 background-color: #cce;
214 border: 1px solid #755;
220 background-color: #eee;
221 border: 1px solid #575;
227 background-color: #cce;
228 border: 1px solid #557;
237 div.name h1, div.error p {
245 text-decoration: underline;
251 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
252 /* Browser specific (not valid) styles to make preformatted text wrap */
254 white-space: pre-wrap; /* css-3 */
255 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
256 white-space: -pre-wrap; /* Opera 4-6 */
257 white-space: -o-pre-wrap; /* Opera 7 */
258 word-wrap: break-word; /* Internet Explorer 5.5+ */
264 <div class="error">$error</div>
265 <div class="infos">$infos</div>
266 <div class="name">$name</div>
273 $c->res->{body} .= ( ' ' x 512 );
276 $c->res->status(500);
279 =head2 $self->finalize_headers($c)
281 Abstract method, allows engines to write headers to response
285 sub finalize_headers { }
287 =head2 $self->finalize_read($c)
291 sub finalize_read { }
293 =head2 $self->finalize_uploads($c)
295 Clean up after uploads, deleting temp files.
299 sub finalize_uploads {
300 my ( $self, $c ) = @_;
302 my $request = $c->request;
303 foreach my $key (keys %{ $request->uploads }) {
304 my $upload = $request->uploads->{$key};
305 unlink grep { -e $_ } map { $_->tempname }
306 (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
311 =head2 $self->prepare_body($c)
313 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
318 my ( $self, $c ) = @_;
320 if ( my $length = $self->read_length ) {
321 my $request = $c->request;
322 unless ( $request->_body ) {
323 my $type = $request->header('Content-Type');
324 $request->_body(HTTP::Body->new( $type, $length ));
325 $request->_body->tmpdir( $c->config->{uploadtmp} )
326 if exists $c->config->{uploadtmp};
329 while ( my $buffer = $self->read($c) ) {
330 $c->prepare_body_chunk($buffer);
333 # paranoia against wrong Content-Length header
334 my $remaining = $length - $self->read_position;
335 if ( $remaining > 0 ) {
336 $self->finalize_read($c);
337 Catalyst::Exception->throw(
338 "Wrong Content-Length value: $length" );
342 # Defined but will cause all body code to be skipped
343 $c->request->_body(0);
347 =head2 $self->prepare_body_chunk($c)
349 Add a chunk to the request body.
353 sub prepare_body_chunk {
354 my ( $self, $c, $chunk ) = @_;
356 $c->request->_body->add($chunk);
359 =head2 $self->prepare_body_parameters($c)
361 Sets up parameters from body.
365 sub prepare_body_parameters {
366 my ( $self, $c ) = @_;
368 return unless $c->request->_body;
370 $c->request->body_parameters( $c->request->_body->param );
373 =head2 $self->prepare_connection($c)
375 Abstract method implemented in engines.
379 sub prepare_connection { }
381 =head2 $self->prepare_cookies($c)
383 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
387 sub prepare_cookies {
388 my ( $self, $c ) = @_;
390 if ( my $header = $c->request->header('Cookie') ) {
391 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
395 =head2 $self->prepare_headers($c)
399 sub prepare_headers { }
401 =head2 $self->prepare_parameters($c)
403 sets up parameters from query and post parameters.
407 sub prepare_parameters {
408 my ( $self, $c ) = @_;
410 my $request = $c->request;
411 my $parameters = $request->parameters;
412 my $body_parameters = $request->body_parameters;
413 my $query_parameters = $request->query_parameters;
414 # We copy, no references
415 foreach my $name (keys %$query_parameters) {
416 my $param = $query_parameters->{$name};
417 $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
420 # Merge query and body parameters
421 foreach my $name (keys %$body_parameters) {
422 my $param = $body_parameters->{$name};
423 my @values = ref $param eq 'ARRAY' ? @$param : ($param);
424 if ( my $existing = $parameters->{$name} ) {
425 unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
427 $parameters->{$name} = @values > 1 ? \@values : $values[0];
431 =head2 $self->prepare_path($c)
433 abstract method, implemented by engines.
439 =head2 $self->prepare_request($c)
441 =head2 $self->prepare_query_parameters($c)
443 process the query string and extract query parameters.
447 sub prepare_query_parameters {
448 my ( $self, $c, $query_string ) = @_;
450 # Check for keywords (no = signs)
451 # (yes, index() is faster than a regex :))
452 if ( index( $query_string, '=' ) < 0 ) {
453 $c->request->query_keywords( $self->unescape_uri($query_string) );
459 # replace semi-colons
460 $query_string =~ s/;/&/g;
462 my @params = grep { length $_ } split /&/, $query_string;
464 for my $item ( @params ) {
467 = map { $self->unescape_uri($_) }
468 split( /=/, $item, 2 );
470 $param = $self->unescape_uri($item) unless defined $param;
472 if ( exists $query{$param} ) {
473 if ( ref $query{$param} ) {
474 push @{ $query{$param} }, $value;
477 $query{$param} = [ $query{$param}, $value ];
481 $query{$param} = $value;
485 $c->request->query_parameters( \%query );
488 =head2 $self->prepare_read($c)
490 prepare to read from the engine.
495 my ( $self, $c ) = @_;
497 # Initialize the read position
498 $self->read_position(0);
500 # Initialize the amount of data we think we need to read
501 $self->read_length( $c->request->header('Content-Length') || 0 );
504 =head2 $self->prepare_request(@arguments)
506 Populate the context object from the request object.
510 sub prepare_request { }
512 =head2 $self->prepare_uploads($c)
516 sub prepare_uploads {
517 my ( $self, $c ) = @_;
519 my $request = $c->request;
520 return unless $request->_body;
522 my $uploads = $request->_body->upload;
523 my $parameters = $request->parameters;
524 foreach my $name (keys %$uploads) {
525 my $files = $uploads->{$name};
527 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
528 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
529 my $u = Catalyst::Request::Upload->new
531 size => $upload->{size},
532 type => $headers->content_type,
534 tempname => $upload->{tempname},
535 filename => $upload->{filename},
539 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
541 # support access to the filename as a normal param
542 my @filenames = map { $_->{filename} } @uploads;
543 # append, if there's already params with this name
544 if (exists $parameters->{$name}) {
545 if (ref $parameters->{$name} eq 'ARRAY') {
546 push @{ $parameters->{$name} }, @filenames;
549 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
553 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
558 =head2 $self->prepare_write($c)
560 Abstract method. Implemented by the engines.
564 sub prepare_write { }
566 =head2 $self->read($c, [$maxlength])
571 my ( $self, $c, $maxlength ) = @_;
573 my $remaining = $self->read_length - $self->read_position;
574 $maxlength ||= $CHUNKSIZE;
576 # Are we done reading?
577 if ( $remaining <= 0 ) {
578 $self->finalize_read($c);
582 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
583 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
585 $self->read_position( $self->read_position + $rc );
589 Catalyst::Exception->throw(
590 message => "Unknown error reading input: $!" );
594 =head2 $self->read_chunk($c, $buffer, $length)
596 Each engine implements read_chunk as its preferred way of reading a chunk
603 =head2 $self->read_length
605 The length of input data to be read. This is obtained from the Content-Length
608 =head2 $self->read_position
610 The amount of input data that has already been read.
612 =head2 $self->run($c)
614 Start the engine. Implemented by the various engine classes.
620 =head2 $self->write($c, $buffer)
622 Writes the buffer to the client.
627 my ( $self, $c, $buffer ) = @_;
629 unless ( $self->_prepared_write ) {
630 $self->prepare_write($c);
631 $self->_prepared_write(1);
634 return 0 if !defined $buffer;
636 my $len = length($buffer);
637 my $wrote = syswrite STDOUT, $buffer;
639 if ( !defined $wrote && $! == EWOULDBLOCK ) {
640 # Unable to write on the first try, will retry in the loop below
644 if ( defined $wrote && $wrote < $len ) {
645 # We didn't write the whole buffer
647 my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
648 if ( defined $ret ) {
652 next if $! == EWOULDBLOCK;
656 last if $wrote >= $len;
663 =head2 $self->unescape_uri($uri)
665 Unescapes a given URI using the most efficient method available. Engines such
666 as Apache may implement this using Apache's C-based modules, for example.
671 my ( $self, $str ) = @_;
673 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
678 =head2 $self->finalize_output
680 <obsolete>, see finalize_body
684 Hash containing enviroment variables including many special variables inserted
685 by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
687 Before accesing enviroment variables consider whether the same information is
688 not directly available via Catalyst objects $c->request, $c->engine ...
690 BEWARE: If you really need to access some enviroment variable from your Catalyst
691 application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
692 as in some enviroments the %ENV hash does not contain what you would expect.
696 Catalyst Contributors, see Catalyst.pm
700 This library is free software. You can redistribute it and/or modify it under
701 the same terms as Perl itself.