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';
16 use namespace::clean -except => 'meta';
18 has env => (is => 'rw');
20 # input position and length
21 has read_length => (is => 'rw');
22 has read_position => (is => 'rw');
24 has _prepared_write => (is => 'rw');
26 # Amount of data to read from input on each pass
27 our $CHUNKSIZE = 64 * 1024;
31 Catalyst::Engine - The Catalyst Engine
42 =head2 $self->finalize_body($c)
44 Finalize body. Prints the response output.
49 my ( $self, $c ) = @_;
50 my $body = $c->response->body;
51 no warnings 'uninitialized';
52 if ( blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
55 $got = read $body, my ($buffer), $CHUNKSIZE;
56 $got = 0 unless $self->write( $c, $buffer );
62 $self->write( $c, $body );
66 =head2 $self->finalize_cookies($c)
68 Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
73 sub finalize_cookies {
74 my ( $self, $c ) = @_;
77 my $response = $c->response;
79 foreach my $name (keys %{ $response->cookies }) {
81 my $val = $response->cookies->{$name};
86 : CGI::Simple::Cookie->new(
88 -value => $val->{value},
89 -expires => $val->{expires},
90 -domain => $val->{domain},
91 -path => $val->{path},
92 -secure => $val->{secure} || 0,
93 -httponly => $val->{httponly} || 0,
96 if (!defined $cookie) {
97 $c->log->warn("undef passed in '$name' cookie value - not setting cookie")
102 push @cookies, $cookie->as_string;
105 for my $cookie (@cookies) {
106 $response->headers->push_header( 'Set-Cookie' => $cookie );
110 =head2 $self->finalize_error($c)
112 Output an appropriate error message. Called if there's an error in $c
113 after the dispatch has finished. Will output debug messages if Catalyst
114 is in debug mode, or a `please come back later` message otherwise.
118 sub _dump_error_page_element {
119 my ($self, $i, $element) = @_;
120 my ($name, $val) = @{ $element };
122 # This is fugly, but the metaclass is _HUGE_ and demands waaay too much
123 # scrolling. Suggestions for more pleasant ways to do this welcome.
124 local $val->{'__MOP__'} = "Stringified: "
125 . $val->{'__MOP__'} if ref $val eq 'HASH' && exists $val->{'__MOP__'};
127 my $text = encode_entities( dump( $val ));
128 sprintf <<"EOF", $name, $text;
129 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
131 <pre wrap="">%s</pre>
137 my ( $self, $c ) = @_;
139 $c->res->content_type('text/html; charset=utf-8');
140 my $name = ref($c)->config->{name} || join(' ', split('::', ref $c));
142 # Prevent Catalyst::Plugin::Unicode::Encoding from running.
143 # This is a little nasty, but it's the best way to be clean whether or
144 # not the user has an encoding plugin.
146 if ($c->can('encoding')) {
150 my ( $title, $error, $infos );
154 $error = join '', map {
155 '<p><code class="error">'
156 . encode_entities($_)
159 $error ||= 'No output';
160 $error = qq{<pre wrap="">$error</pre>};
161 $title = $name = "$name on Catalyst $Catalyst::VERSION";
162 $name = "<h1>$name</h1>";
164 # Don't show context in the dump
165 $c->req->_clear_context;
166 $c->res->_clear_context;
168 # Don't show body parser in the dump
169 $c->req->_clear_body;
173 for my $dump ( $c->dump_these ) {
174 push @infos, $self->_dump_error_page_element($i, $dump);
177 $infos = join "\n", @infos;
184 (en) Please come back later
185 (fr) SVP veuillez revenir plus tard
186 (de) Bitte versuchen sie es spaeter nocheinmal
187 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
188 (no) Vennligst prov igjen senere
189 (dk) Venligst prov igen senere
190 (pl) Prosze sprobowac pozniej
191 (pt) Por favor volte mais tarde
192 (ru) Попробуйте еще раз позже
193 (ua) Спробуйте ще раз пізніше
198 $c->res->body( <<"" );
199 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
200 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
201 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
203 <meta http-equiv="Content-Language" content="en" />
204 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
205 <title>$title</title>
206 <script type="text/javascript">
208 function toggleDump (dumpElement) {
209 var e = document.getElementById( dumpElement );
210 if (e.style.display == "none") {
211 e.style.display = "";
214 e.style.display = "none";
219 <style type="text/css">
221 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
222 Tahoma, Arial, helvetica, sans-serif;
224 background-color: #eee;
228 :link, :link:hover, :visited, :visited:hover {
233 background-color: #ccc;
234 border: 1px solid #aaa;
239 background-color: #cce;
240 border: 1px solid #755;
246 background-color: #eee;
247 border: 1px solid #575;
253 background-color: #cce;
254 border: 1px solid #557;
263 div.name h1, div.error p {
271 text-decoration: underline;
277 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
278 /* Browser specific (not valid) styles to make preformatted text wrap */
280 white-space: pre-wrap; /* css-3 */
281 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
282 white-space: -pre-wrap; /* Opera 4-6 */
283 white-space: -o-pre-wrap; /* Opera 7 */
284 word-wrap: break-word; /* Internet Explorer 5.5+ */
290 <div class="error">$error</div>
291 <div class="infos">$infos</div>
292 <div class="name">$name</div>
297 # Trick IE. Old versions of IE would display their own error page instead
298 # of ours if we'd give it less than 512 bytes.
299 $c->res->{body} .= ( ' ' x 512 );
301 $c->res->{body} = Encode::encode("UTF-8", $c->res->{body});
304 $c->res->status(500);
307 =head2 $self->finalize_headers($c)
309 Abstract method, allows engines to write headers to response
313 sub finalize_headers { }
315 =head2 $self->finalize_read($c)
319 sub finalize_read { }
321 =head2 $self->finalize_uploads($c)
323 Clean up after uploads, deleting temp files.
327 sub finalize_uploads {
328 my ( $self, $c ) = @_;
330 # N.B. This code is theoretically entirely unneeded due to ->cleanup(1)
331 # on the HTTP::Body object.
332 my $request = $c->request;
333 foreach my $key (keys %{ $request->uploads }) {
334 my $upload = $request->uploads->{$key};
335 unlink grep { -e $_ } map { $_->tempname }
336 (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
341 =head2 $self->prepare_body($c)
343 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
348 my ( $self, $c ) = @_;
350 my $appclass = ref($c) || $c;
351 if ( my $length = $self->read_length ) {
352 my $request = $c->request;
353 unless ( $request->_body ) {
354 my $type = $request->header('Content-Type');
355 $request->_body(HTTP::Body->new( $type, $length ));
356 $request->_body->cleanup(1); # Make extra sure!
357 $request->_body->tmpdir( $appclass->config->{uploadtmp} )
358 if exists $appclass->config->{uploadtmp};
361 # Check for definedness as you could read '0'
362 while ( defined ( my $buffer = $self->read($c) ) ) {
363 $c->prepare_body_chunk($buffer);
366 # paranoia against wrong Content-Length header
367 my $remaining = $length - $self->read_position;
368 if ( $remaining > 0 ) {
369 $self->finalize_read($c);
370 Catalyst::Exception->throw(
371 "Wrong Content-Length value: $length" );
375 # Defined but will cause all body code to be skipped
376 $c->request->_body(0);
380 =head2 $self->prepare_body_chunk($c)
382 Add a chunk to the request body.
386 sub prepare_body_chunk {
387 my ( $self, $c, $chunk ) = @_;
389 $c->request->_body->add($chunk);
392 =head2 $self->prepare_body_parameters($c)
394 Sets up parameters from body.
398 sub prepare_body_parameters {
399 my ( $self, $c ) = @_;
401 return unless $c->request->_body;
403 $c->request->body_parameters( $c->request->_body->param );
406 =head2 $self->prepare_connection($c)
408 Abstract method implemented in engines.
412 sub prepare_connection { }
414 =head2 $self->prepare_cookies($c)
416 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
420 sub prepare_cookies {
421 my ( $self, $c ) = @_;
423 if ( my $header = $c->request->header('Cookie') ) {
424 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
428 =head2 $self->prepare_headers($c)
432 sub prepare_headers { }
434 =head2 $self->prepare_parameters($c)
436 sets up parameters from query and post parameters.
440 sub prepare_parameters {
441 my ( $self, $c ) = @_;
443 my $request = $c->request;
444 my $parameters = $request->parameters;
445 my $body_parameters = $request->body_parameters;
446 my $query_parameters = $request->query_parameters;
447 # We copy, no references
448 foreach my $name (keys %$query_parameters) {
449 my $param = $query_parameters->{$name};
450 $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
453 # Merge query and body parameters
454 foreach my $name (keys %$body_parameters) {
455 my $param = $body_parameters->{$name};
456 my @values = ref $param eq 'ARRAY' ? @$param : ($param);
457 if ( my $existing = $parameters->{$name} ) {
458 unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
460 $parameters->{$name} = @values > 1 ? \@values : $values[0];
464 =head2 $self->prepare_path($c)
466 abstract method, implemented by engines.
472 =head2 $self->prepare_request($c)
474 =head2 $self->prepare_query_parameters($c)
476 process the query string and extract query parameters.
480 sub prepare_query_parameters {
481 my ( $self, $c, $query_string ) = @_;
483 # Check for keywords (no = signs)
484 # (yes, index() is faster than a regex :))
485 if ( index( $query_string, '=' ) < 0 ) {
486 $c->request->query_keywords( $self->unescape_uri($query_string) );
492 # replace semi-colons
493 $query_string =~ s/;/&/g;
495 my @params = grep { length $_ } split /&/, $query_string;
497 for my $item ( @params ) {
500 = map { $self->unescape_uri($_) }
501 split( /=/, $item, 2 );
503 $param = $self->unescape_uri($item) unless defined $param;
505 if ( exists $query{$param} ) {
506 if ( ref $query{$param} ) {
507 push @{ $query{$param} }, $value;
510 $query{$param} = [ $query{$param}, $value ];
514 $query{$param} = $value;
518 $c->request->query_parameters( \%query );
521 =head2 $self->prepare_read($c)
523 prepare to read from the engine.
528 my ( $self, $c ) = @_;
530 # Initialize the read position
531 $self->read_position(0);
533 # Initialize the amount of data we think we need to read
534 $self->read_length( $c->request->header('Content-Length') || 0 );
537 =head2 $self->prepare_request(@arguments)
539 Populate the context object from the request object.
543 sub prepare_request { }
545 =head2 $self->prepare_uploads($c)
549 sub prepare_uploads {
550 my ( $self, $c ) = @_;
552 my $request = $c->request;
553 return unless $request->_body;
555 my $uploads = $request->_body->upload;
556 my $parameters = $request->parameters;
557 foreach my $name (keys %$uploads) {
558 my $files = $uploads->{$name};
560 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
561 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
562 my $u = Catalyst::Request::Upload->new
564 size => $upload->{size},
565 type => scalar $headers->content_type,
567 tempname => $upload->{tempname},
568 filename => $upload->{filename},
572 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
574 # support access to the filename as a normal param
575 my @filenames = map { $_->{filename} } @uploads;
576 # append, if there's already params with this name
577 if (exists $parameters->{$name}) {
578 if (ref $parameters->{$name} eq 'ARRAY') {
579 push @{ $parameters->{$name} }, @filenames;
582 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
586 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
591 =head2 $self->prepare_write($c)
593 Abstract method. Implemented by the engines.
597 sub prepare_write { }
599 =head2 $self->read($c, [$maxlength])
601 Reads from the input stream by calling C<< $self->read_chunk >>.
603 Maintains the read_length and read_position counters as data is read.
608 my ( $self, $c, $maxlength ) = @_;
610 my $remaining = $self->read_length - $self->read_position;
611 $maxlength ||= $CHUNKSIZE;
613 # Are we done reading?
614 if ( $remaining <= 0 ) {
615 $self->finalize_read($c);
619 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
620 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
622 if (0 == $rc) { # Nothing more to read even though Content-Length
623 # said there should be. FIXME - Warn in the log here?
624 $self->finalize_read;
627 $self->read_position( $self->read_position + $rc );
631 Catalyst::Exception->throw(
632 message => "Unknown error reading input: $!" );
636 =head2 $self->read_chunk($c, $buffer, $length)
638 Each engine implements read_chunk as its preferred way of reading a chunk
639 of data. Returns the number of bytes read. A return of 0 indicates that
640 there is no more data to be read.
646 =head2 $self->read_length
648 The length of input data to be read. This is obtained from the Content-Length
651 =head2 $self->read_position
653 The amount of input data that has already been read.
655 =head2 $self->run($c)
657 Start the engine. Implemented by the various engine classes.
663 =head2 $self->write($c, $buffer)
665 Writes the buffer to the client.
670 my ( $self, $c, $buffer ) = @_;
672 unless ( $self->_prepared_write ) {
673 $self->prepare_write($c);
674 $self->_prepared_write(1);
677 return 0 if !defined $buffer;
679 my $len = length($buffer);
680 my $wrote = syswrite STDOUT, $buffer;
682 if ( !defined $wrote && $! == EWOULDBLOCK ) {
683 # Unable to write on the first try, will retry in the loop below
687 if ( defined $wrote && $wrote < $len ) {
688 # We didn't write the whole buffer
690 my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
691 if ( defined $ret ) {
695 next if $! == EWOULDBLOCK;
699 last if $wrote >= $len;
706 =head2 $self->unescape_uri($uri)
708 Unescapes a given URI using the most efficient method available. Engines such
709 as Apache may implement this using Apache's C-based modules, for example.
714 my ( $self, $str ) = @_;
716 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
721 =head2 $self->finalize_output
723 <obsolete>, see finalize_body
727 Hash containing environment variables including many special variables inserted
728 by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
730 Before accessing environment variables consider whether the same information is
731 not directly available via Catalyst objects $c->request, $c->engine ...
733 BEWARE: If you really need to access some environment variable from your Catalyst
734 application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
735 as in some environments the %ENV hash does not contain what you would expect.
739 Catalyst Contributors, see Catalyst.pm
743 This library is free software. You can redistribute it and/or modify it under
744 the same terms as Perl itself.