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';
13 use Moose::Util::TypeConstraints;
15 use namespace::clean -except => 'meta';
17 has env => (is => 'ro', writer => '_set_env', clearer => '_clear_env');
19 # input position and length
20 has read_length => (is => 'rw');
21 has read_position => (is => 'rw');
23 has _prepared_write => (is => 'rw');
28 writer => '_set_response_cb',
33 isa => duck_type([qw(write close)]),
34 writer => '_set_writer',
37 # Amount of data to read from input on each pass
38 our $CHUNKSIZE = 64 * 1024;
42 Catalyst::Engine - The Catalyst Engine
53 =head2 $self->finalize_body($c)
55 Finalize body. Prints the response output.
60 my ( $self, $c ) = @_;
61 my $body = $c->response->body;
62 no warnings 'uninitialized';
63 if ( blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
66 $got = read $body, my ($buffer), $CHUNKSIZE;
67 $got = 0 unless $self->write( $c, $buffer );
73 $self->write( $c, $body );
76 $self->_writer->close;
83 =head2 $self->finalize_cookies($c)
85 Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
90 sub finalize_cookies {
91 my ( $self, $c ) = @_;
94 my $response = $c->response;
96 foreach my $name (keys %{ $response->cookies }) {
98 my $val = $response->cookies->{$name};
103 : CGI::Simple::Cookie->new(
105 -value => $val->{value},
106 -expires => $val->{expires},
107 -domain => $val->{domain},
108 -path => $val->{path},
109 -secure => $val->{secure} || 0,
110 -httponly => $val->{httponly} || 0,
114 push @cookies, $cookie->as_string;
117 for my $cookie (@cookies) {
118 $response->headers->push_header( 'Set-Cookie' => $cookie );
122 =head2 $self->finalize_error($c)
124 Output an appropriate error message. Called if there's an error in $c
125 after the dispatch has finished. Will output debug messages if Catalyst
126 is in debug mode, or a `please come back later` message otherwise.
130 sub _dump_error_page_element {
131 my ($self, $i, $element) = @_;
132 my ($name, $val) = @{ $element };
134 # This is fugly, but the metaclass is _HUGE_ and demands waaay too much
135 # scrolling. Suggestions for more pleasant ways to do this welcome.
136 local $val->{'__MOP__'} = "Stringified: "
137 . $val->{'__MOP__'} if ref $val eq 'HASH' && exists $val->{'__MOP__'};
139 my $text = encode_entities( dump( $val ));
140 sprintf <<"EOF", $name, $text;
141 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
143 <pre wrap="">%s</pre>
149 my ( $self, $c ) = @_;
151 $c->res->content_type('text/html; charset=utf-8');
152 my $name = ref($c)->config->{name} || join(' ', split('::', ref $c));
154 my ( $title, $error, $infos );
158 $error = join '', map {
159 '<p><code class="error">'
160 . encode_entities($_)
163 $error ||= 'No output';
164 $error = qq{<pre wrap="">$error</pre>};
165 $title = $name = "$name on Catalyst $Catalyst::VERSION";
166 $name = "<h1>$name</h1>";
168 # Don't show context in the dump
169 $c->req->_clear_context;
170 $c->res->_clear_context;
172 # Don't show body parser in the dump
173 $c->req->_clear_body;
177 for my $dump ( $c->dump_these ) {
178 push @infos, $self->_dump_error_page_element($i, $dump);
181 $infos = join "\n", @infos;
188 (en) Please come back later
189 (fr) SVP veuillez revenir plus tard
190 (de) Bitte versuchen sie es spaeter nocheinmal
191 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
192 (no) Vennligst prov igjen senere
193 (dk) Venligst prov igen senere
194 (pl) Prosze sprobowac pozniej
195 (pt) Por favor volte mais tarde
196 (ru) Попробуйте еще раз позже
197 (ua) Спробуйте ще раз пізніше
202 $c->res->body( <<"" );
203 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
204 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
205 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
207 <meta http-equiv="Content-Language" content="en" />
208 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
209 <title>$title</title>
210 <script type="text/javascript">
212 function toggleDump (dumpElement) {
213 var e = document.getElementById( dumpElement );
214 if (e.style.display == "none") {
215 e.style.display = "";
218 e.style.display = "none";
223 <style type="text/css">
225 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
226 Tahoma, Arial, helvetica, sans-serif;
228 background-color: #eee;
232 :link, :link:hover, :visited, :visited:hover {
237 background-color: #ccc;
238 border: 1px solid #aaa;
243 background-color: #cce;
244 border: 1px solid #755;
250 background-color: #eee;
251 border: 1px solid #575;
257 background-color: #cce;
258 border: 1px solid #557;
267 div.name h1, div.error p {
275 text-decoration: underline;
281 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
282 /* Browser specific (not valid) styles to make preformatted text wrap */
284 white-space: pre-wrap; /* css-3 */
285 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
286 white-space: -pre-wrap; /* Opera 4-6 */
287 white-space: -o-pre-wrap; /* Opera 7 */
288 word-wrap: break-word; /* Internet Explorer 5.5+ */
294 <div class="error">$error</div>
295 <div class="infos">$infos</div>
296 <div class="name">$name</div>
303 $c->res->{body} .= ( ' ' x 512 );
306 $c->res->status(500);
309 =head2 $self->finalize_headers($c)
311 Abstract method, allows engines to write headers to response
315 sub finalize_headers {
316 my ($self, $ctx) = @_;
319 $ctx->response->headers->scan(sub { push @headers, @_ });
321 $self->_set_writer($self->_response_cb->([ $ctx->response->status, \@headers ]));
326 =head2 $self->finalize_read($c)
330 sub finalize_read { }
332 =head2 $self->finalize_uploads($c)
334 Clean up after uploads, deleting temp files.
338 sub finalize_uploads {
339 my ( $self, $c ) = @_;
341 my $request = $c->request;
342 foreach my $key (keys %{ $request->uploads }) {
343 my $upload = $request->uploads->{$key};
344 unlink grep { -e $_ } map { $_->tempname }
345 (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
350 =head2 $self->prepare_body($c)
352 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
357 my ( $self, $c ) = @_;
359 my $appclass = ref($c) || $c;
360 if ( my $length = $self->read_length ) {
361 my $request = $c->request;
362 unless ( $request->_body ) {
363 my $type = $request->header('Content-Type');
364 $request->_body(HTTP::Body->new( $type, $length ));
365 $request->_body->tmpdir( $appclass->config->{uploadtmp} )
366 if exists $appclass->config->{uploadtmp};
369 # Check for definedness as you could read '0'
370 while ( defined ( my $buffer = $self->read($c) ) ) {
371 $c->prepare_body_chunk($buffer);
374 # paranoia against wrong Content-Length header
375 my $remaining = $length - $self->read_position;
376 if ( $remaining > 0 ) {
377 $self->finalize_read($c);
378 Catalyst::Exception->throw(
379 "Wrong Content-Length value: $length" );
383 # Defined but will cause all body code to be skipped
384 $c->request->_body(0);
388 =head2 $self->prepare_body_chunk($c)
390 Add a chunk to the request body.
394 sub prepare_body_chunk {
395 my ( $self, $c, $chunk ) = @_;
397 $c->request->_body->add($chunk);
400 =head2 $self->prepare_body_parameters($c)
402 Sets up parameters from body.
406 sub prepare_body_parameters {
407 my ( $self, $c ) = @_;
409 return unless $c->request->_body;
411 $c->request->body_parameters( $c->request->_body->param );
414 =head2 $self->prepare_connection($c)
416 Abstract method implemented in engines.
420 sub prepare_connection {
421 my ($self, $ctx) = @_;
423 my $env = $self->env;
424 my $request = $ctx->request;
426 $request->address( $env->{REMOTE_ADDR} );
427 $request->hostname( $env->{REMOTE_HOST} )
428 if exists $env->{REMOTE_HOST};
429 $request->protocol( $env->{SERVER_PROTOCOL} );
430 $request->remote_user( $env->{REMOTE_USER} );
431 $request->method( $env->{REQUEST_METHOD} );
432 $request->secure( $env->{'psgi.url_scheme'} eq 'https' );
437 =head2 $self->prepare_cookies($c)
439 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
443 sub prepare_cookies {
444 my ( $self, $c ) = @_;
446 if ( my $header = $c->request->header('Cookie') ) {
447 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
451 =head2 $self->prepare_headers($c)
455 sub prepare_headers {
456 my ($self, $ctx) = @_;
458 my $env = $self->env;
459 my $headers = $ctx->request->headers;
461 for my $header (keys %{ $env }) {
462 next unless $header =~ /^(HTTP|CONTENT|COOKIE)/i;
463 (my $field = $header) =~ s/^HTTPS?_//;
465 $headers->header($field => $env->{$header});
469 =head2 $self->prepare_parameters($c)
471 sets up parameters from query and post parameters.
475 sub prepare_parameters {
476 my ( $self, $c ) = @_;
478 my $request = $c->request;
479 my $parameters = $request->parameters;
480 my $body_parameters = $request->body_parameters;
481 my $query_parameters = $request->query_parameters;
482 # We copy, no references
483 foreach my $name (keys %$query_parameters) {
484 my $param = $query_parameters->{$name};
485 $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
488 # Merge query and body parameters
489 foreach my $name (keys %$body_parameters) {
490 my $param = $body_parameters->{$name};
491 my @values = ref $param eq 'ARRAY' ? @$param : ($param);
492 if ( my $existing = $parameters->{$name} ) {
493 unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
495 $parameters->{$name} = @values > 1 ? \@values : $values[0];
499 =head2 $self->prepare_path($c)
501 abstract method, implemented by engines.
506 my ($self, $ctx) = @_;
508 my $env = $self->env;
510 my $scheme = $ctx->request->secure ? 'https' : 'http';
511 my $host = $env->{HTTP_HOST} || $env->{SERVER_NAME};
512 my $port = $env->{SERVER_PORT} || 80;
513 my $base_path = $env->{SCRIPT_NAME} || "/";
515 # set the request URI
516 my $req_uri = $env->{REQUEST_URI};
517 $req_uri =~ s/\?.*$//;
518 my $path = $self->unescape_uri($req_uri);
521 # Using URI directly is way too slow, so we construct the URLs manually
522 my $uri_class = "URI::$scheme";
524 # HTTP_HOST will include the port even if it's 80/443
525 $host =~ s/:(?:80|443)$//;
527 if ($port !~ /^(?:80|443)$/ && $host !~ /:/) {
532 $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
533 $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
535 my $query = $env->{QUERY_STRING} ? '?' . $env->{QUERY_STRING} : '';
536 my $uri = $scheme . '://' . $host . '/' . $path . $query;
538 $ctx->request->uri( bless \$uri, $uri_class );
541 # base must end in a slash
542 $base_path .= '/' unless $base_path =~ m{/$};
544 my $base_uri = $scheme . '://' . $host . $base_path;
546 $ctx->request->base( bless \$base_uri, $uri_class );
551 =head2 $self->prepare_request($c)
553 =head2 $self->prepare_query_parameters($c)
555 process the query string and extract query parameters.
559 sub prepare_query_parameters {
562 my $query_string = exists $self->env->{QUERY_STRING}
563 ? $self->env->{QUERY_STRING}
566 # Check for keywords (no = signs)
567 # (yes, index() is faster than a regex :))
568 if ( index( $query_string, '=' ) < 0 ) {
569 $c->request->query_keywords( $self->unescape_uri($query_string) );
575 # replace semi-colons
576 $query_string =~ s/;/&/g;
578 my @params = grep { length $_ } split /&/, $query_string;
580 for my $item ( @params ) {
583 = map { $self->unescape_uri($_) }
584 split( /=/, $item, 2 );
586 $param = $self->unescape_uri($item) unless defined $param;
588 if ( exists $query{$param} ) {
589 if ( ref $query{$param} ) {
590 push @{ $query{$param} }, $value;
593 $query{$param} = [ $query{$param}, $value ];
597 $query{$param} = $value;
601 $c->request->query_parameters( \%query );
604 =head2 $self->prepare_read($c)
606 prepare to read from the engine.
611 my ( $self, $c ) = @_;
613 # Initialize the read position
614 $self->read_position(0);
616 # Initialize the amount of data we think we need to read
617 $self->read_length( $c->request->header('Content-Length') || 0 );
620 =head2 $self->prepare_request(@arguments)
622 Populate the context object from the request object.
626 sub prepare_request {
627 my ($self, $ctx, %args) = @_;
628 $self->_set_env($args{env});
631 =head2 $self->prepare_uploads($c)
635 sub prepare_uploads {
636 my ( $self, $c ) = @_;
638 my $request = $c->request;
639 return unless $request->_body;
641 my $uploads = $request->_body->upload;
642 my $parameters = $request->parameters;
643 foreach my $name (keys %$uploads) {
644 my $files = $uploads->{$name};
646 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
647 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
648 my $u = Catalyst::Request::Upload->new
650 size => $upload->{size},
651 type => $headers->content_type,
653 tempname => $upload->{tempname},
654 filename => $upload->{filename},
658 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
660 # support access to the filename as a normal param
661 my @filenames = map { $_->{filename} } @uploads;
662 # append, if there's already params with this name
663 if (exists $parameters->{$name}) {
664 if (ref $parameters->{$name} eq 'ARRAY') {
665 push @{ $parameters->{$name} }, @filenames;
668 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
672 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
677 =head2 $self->prepare_write($c)
679 Abstract method. Implemented by the engines.
683 sub prepare_write { }
685 =head2 $self->read($c, [$maxlength])
687 Reads from the input stream by calling C<< $self->read_chunk >>.
689 Maintains the read_length and read_position counters as data is read.
694 my ( $self, $c, $maxlength ) = @_;
696 my $remaining = $self->read_length - $self->read_position;
697 $maxlength ||= $CHUNKSIZE;
699 # Are we done reading?
700 if ( $remaining <= 0 ) {
701 $self->finalize_read($c);
705 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
706 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
708 if (0 == $rc) { # Nothing more to read even though Content-Length
709 # said there should be.
710 $self->finalize_read;
713 $self->read_position( $self->read_position + $rc );
717 Catalyst::Exception->throw(
718 message => "Unknown error reading input: $!" );
722 =head2 $self->read_chunk($c, $buffer, $length)
724 Each engine implements read_chunk as its preferred way of reading a chunk
725 of data. Returns the number of bytes read. A return of 0 indicates that
726 there is no more data to be read.
731 my ($self, $ctx) = (shift, shift);
732 return $self->env->{'psgi.input'}->read(@_);
735 =head2 $self->read_length
737 The length of input data to be read. This is obtained from the Content-Length
740 =head2 $self->read_position
742 The amount of input data that has already been read.
744 =head2 $self->run($c)
746 Start the engine. Implemented by the various engine classes.
751 my ($self, $app) = @_;
758 $self->_set_response_cb($respond);
759 $app->handle_request(env => $env);
764 =head2 $self->write($c, $buffer)
766 Writes the buffer to the client.
771 my ( $self, $c, $buffer ) = @_;
773 unless ( $self->_prepared_write ) {
774 $self->prepare_write($c);
775 $self->_prepared_write(1);
778 return 0 if !defined $buffer;
780 my $len = length($buffer);
781 $self->_writer->write($buffer);
786 =head2 $self->unescape_uri($uri)
788 Unescapes a given URI using the most efficient method available. Engines such
789 as Apache may implement this using Apache's C-based modules, for example.
794 my ( $self, $str ) = @_;
796 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
801 =head2 $self->finalize_output
803 <obsolete>, see finalize_body
807 Hash containing enviroment variables including many special variables inserted
808 by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
810 Before accesing enviroment variables consider whether the same information is
811 not directly available via Catalyst objects $c->request, $c->engine ...
813 BEWARE: If you really need to access some enviroment variable from your Catalyst
814 application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
815 as in some enviroments the %ENV hash does not contain what you would expect.
819 Catalyst Contributors, see Catalyst.pm
823 This library is free software. You can redistribute it and/or modify it under
824 the same terms as Perl itself.