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 $got = read $body, my ($buffer), $CHUNKSIZE;
54 $got = 0 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 = ref($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 my $appclass = ref($c) || $c;
321 if ( my $length = $self->read_length ) {
322 my $request = $c->request;
323 unless ( $request->_body ) {
324 my $type = $request->header('Content-Type');
325 $request->_body(HTTP::Body->new( $type, $length ));
326 $request->_body->tmpdir( $appclass->config->{uploadtmp} )
327 if exists $appclass->config->{uploadtmp};
330 # Check for definedness as you could read '0'
331 while ( defined ( my $buffer = $self->read($c) ) ) {
332 $c->prepare_body_chunk($buffer);
335 # paranoia against wrong Content-Length header
336 my $remaining = $length - $self->read_position;
337 if ( $remaining > 0 ) {
338 $self->finalize_read($c);
339 Catalyst::Exception->throw(
340 "Wrong Content-Length value: $length" );
344 # Defined but will cause all body code to be skipped
345 $c->request->_body(0);
349 =head2 $self->prepare_body_chunk($c)
351 Add a chunk to the request body.
355 sub prepare_body_chunk {
356 my ( $self, $c, $chunk ) = @_;
358 $c->request->_body->add($chunk);
361 =head2 $self->prepare_body_parameters($c)
363 Sets up parameters from body.
367 sub prepare_body_parameters {
368 my ( $self, $c ) = @_;
370 return unless $c->request->_body;
372 $c->request->body_parameters( $c->request->_body->param );
375 =head2 $self->prepare_connection($c)
377 Abstract method implemented in engines.
381 sub prepare_connection { }
383 =head2 $self->prepare_cookies($c)
385 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
389 sub prepare_cookies {
390 my ( $self, $c ) = @_;
392 if ( my $header = $c->request->header('Cookie') ) {
393 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
397 =head2 $self->prepare_headers($c)
401 sub prepare_headers { }
403 =head2 $self->prepare_parameters($c)
405 sets up parameters from query and post parameters.
409 sub prepare_parameters {
410 my ( $self, $c ) = @_;
412 my $request = $c->request;
413 my $parameters = $request->parameters;
414 my $body_parameters = $request->body_parameters;
415 my $query_parameters = $request->query_parameters;
416 # We copy, no references
417 foreach my $name (keys %$query_parameters) {
418 my $param = $query_parameters->{$name};
419 $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
422 # Merge query and body parameters
423 foreach my $name (keys %$body_parameters) {
424 my $param = $body_parameters->{$name};
425 my @values = ref $param eq 'ARRAY' ? @$param : ($param);
426 if ( my $existing = $parameters->{$name} ) {
427 unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
429 $parameters->{$name} = @values > 1 ? \@values : $values[0];
433 =head2 $self->prepare_path($c)
435 abstract method, implemented by engines.
441 =head2 $self->prepare_request($c)
443 =head2 $self->prepare_query_parameters($c)
445 process the query string and extract query parameters.
449 sub prepare_query_parameters {
450 my ( $self, $c, $query_string ) = @_;
452 # Check for keywords (no = signs)
453 # (yes, index() is faster than a regex :))
454 if ( index( $query_string, '=' ) < 0 ) {
455 $c->request->query_keywords( $self->unescape_uri($query_string) );
461 # replace semi-colons
462 $query_string =~ s/;/&/g;
464 my @params = grep { length $_ } split /&/, $query_string;
466 for my $item ( @params ) {
469 = map { $self->unescape_uri($_) }
470 split( /=/, $item, 2 );
472 $param = $self->unescape_uri($item) unless defined $param;
474 if ( exists $query{$param} ) {
475 if ( ref $query{$param} ) {
476 push @{ $query{$param} }, $value;
479 $query{$param} = [ $query{$param}, $value ];
483 $query{$param} = $value;
487 $c->request->query_parameters( \%query );
490 =head2 $self->prepare_read($c)
492 prepare to read from the engine.
497 my ( $self, $c ) = @_;
499 # Initialize the read position
500 $self->read_position(0);
502 # Initialize the amount of data we think we need to read
503 $self->read_length( $c->request->header('Content-Length') || 0 );
506 =head2 $self->prepare_request(@arguments)
508 Populate the context object from the request object.
512 sub prepare_request { }
514 =head2 $self->prepare_uploads($c)
518 sub prepare_uploads {
519 my ( $self, $c ) = @_;
521 my $request = $c->request;
522 return unless $request->_body;
524 my $uploads = $request->_body->upload;
525 my $parameters = $request->parameters;
526 foreach my $name (keys %$uploads) {
527 my $files = $uploads->{$name};
529 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
530 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
531 my $u = Catalyst::Request::Upload->new
533 size => $upload->{size},
534 type => $headers->content_type,
536 tempname => $upload->{tempname},
537 filename => $upload->{filename},
541 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
543 # support access to the filename as a normal param
544 my @filenames = map { $_->{filename} } @uploads;
545 # append, if there's already params with this name
546 if (exists $parameters->{$name}) {
547 if (ref $parameters->{$name} eq 'ARRAY') {
548 push @{ $parameters->{$name} }, @filenames;
551 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
555 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
560 =head2 $self->prepare_write($c)
562 Abstract method. Implemented by the engines.
566 sub prepare_write { }
568 =head2 $self->read($c, [$maxlength])
570 Reads from the input stream by calling C<< $self->read_chunk >>.
572 Maintains the read_length and read_position counters as data is read.
577 my ( $self, $c, $maxlength ) = @_;
579 my $remaining = $self->read_length - $self->read_position;
580 $maxlength ||= $CHUNKSIZE;
582 # Are we done reading?
583 if ( $remaining <= 0 ) {
584 $self->finalize_read($c);
588 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
589 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
591 if (0 == $rc) { # Nothing more to read even though Content-Length
592 # said there should be. FIXME - Warn in the log here?
593 $self->finalize_read;
596 $self->read_position( $self->read_position + $rc );
600 Catalyst::Exception->throw(
601 message => "Unknown error reading input: $!" );
605 =head2 $self->read_chunk($c, $buffer, $length)
607 Each engine implements read_chunk as its preferred way of reading a chunk
608 of data. Returns the number of bytes read. A return of 0 indicates that
609 there is no more data to be read.
615 =head2 $self->read_length
617 The length of input data to be read. This is obtained from the Content-Length
620 =head2 $self->read_position
622 The amount of input data that has already been read.
624 =head2 $self->run($c)
626 Start the engine. Implemented by the various engine classes.
632 =head2 $self->write($c, $buffer)
634 Writes the buffer to the client.
639 my ( $self, $c, $buffer ) = @_;
641 unless ( $self->_prepared_write ) {
642 $self->prepare_write($c);
643 $self->_prepared_write(1);
646 return 0 if !defined $buffer;
648 my $len = length($buffer);
649 my $wrote = syswrite STDOUT, $buffer;
651 if ( !defined $wrote && $! == EWOULDBLOCK ) {
652 # Unable to write on the first try, will retry in the loop below
656 if ( defined $wrote && $wrote < $len ) {
657 # We didn't write the whole buffer
659 my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
660 if ( defined $ret ) {
664 next if $! == EWOULDBLOCK;
668 last if $wrote >= $len;
675 =head2 $self->unescape_uri($uri)
677 Unescapes a given URI using the most efficient method available. Engines such
678 as Apache may implement this using Apache's C-based modules, for example.
683 my ( $self, $str ) = @_;
685 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
690 =head2 $self->finalize_output
692 <obsolete>, see finalize_body
696 Hash containing enviroment variables including many special variables inserted
697 by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
699 Before accesing enviroment variables consider whether the same information is
700 not directly available via Catalyst objects $c->request, $c->engine ...
702 BEWARE: If you really need to access some enviroment variable from your Catalyst
703 application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
704 as in some enviroments the %ENV hash does not contain what you would expect.
708 Catalyst Contributors, see Catalyst.pm
712 This library is free software. You can redistribute it and/or modify it under
713 the same terms as Perl itself.