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 Catalyst::EngineLoader;
19 use namespace::clean -except => 'meta';
21 has env => (is => 'ro', writer => '_set_env', clearer => '_clear_env');
23 # input position and length
24 has read_length => (is => 'rw');
25 has read_position => (is => 'rw');
27 has _prepared_write => (is => 'rw');
32 writer => '_set_response_cb',
33 clearer => '_clear_response_cb',
38 isa => duck_type([qw(write close)]),
39 writer => '_set_writer',
40 clearer => '_clear_writer',
43 # Amount of data to read from input on each pass
44 our $CHUNKSIZE = 64 * 1024;
48 Catalyst::Engine - The Catalyst Engine
59 =head2 $self->finalize_body($c)
61 Finalize body. Prints the response output.
66 my ( $self, $c ) = @_;
67 my $body = $c->response->body;
68 no warnings 'uninitialized';
69 if ( blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
72 $got = read $body, my ($buffer), $CHUNKSIZE;
73 $got = 0 unless $self->write( $c, $buffer );
79 $self->write( $c, $body );
82 $self->_writer->close;
89 =head2 $self->finalize_cookies($c)
91 Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
96 sub finalize_cookies {
97 my ( $self, $c ) = @_;
100 my $response = $c->response;
102 foreach my $name (keys %{ $response->cookies }) {
104 my $val = $response->cookies->{$name};
109 : CGI::Simple::Cookie->new(
111 -value => $val->{value},
112 -expires => $val->{expires},
113 -domain => $val->{domain},
114 -path => $val->{path},
115 -secure => $val->{secure} || 0,
116 -httponly => $val->{httponly} || 0,
120 push @cookies, $cookie->as_string;
123 for my $cookie (@cookies) {
124 $response->headers->push_header( 'Set-Cookie' => $cookie );
128 =head2 $self->finalize_error($c)
130 Output an appropriate error message. Called if there's an error in $c
131 after the dispatch has finished. Will output debug messages if Catalyst
132 is in debug mode, or a `please come back later` message otherwise.
136 sub _dump_error_page_element {
137 my ($self, $i, $element) = @_;
138 my ($name, $val) = @{ $element };
140 # This is fugly, but the metaclass is _HUGE_ and demands waaay too much
141 # scrolling. Suggestions for more pleasant ways to do this welcome.
142 local $val->{'__MOP__'} = "Stringified: "
143 . $val->{'__MOP__'} if ref $val eq 'HASH' && exists $val->{'__MOP__'};
145 my $text = encode_entities( dump( $val ));
146 sprintf <<"EOF", $name, $text;
147 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
149 <pre wrap="">%s</pre>
155 my ( $self, $c ) = @_;
157 $c->res->content_type('text/html; charset=utf-8');
158 my $name = ref($c)->config->{name} || join(' ', split('::', ref $c));
160 # Prevent Catalyst::Plugin::Unicode::Encoding from running.
161 # This is a little nasty, but it's the best way to be clean whether or
162 # not the user has an encoding plugin.
164 if ($c->can('encoding')) {
168 my ( $title, $error, $infos );
172 $error = join '', map {
173 '<p><code class="error">'
174 . encode_entities($_)
177 $error ||= 'No output';
178 $error = qq{<pre wrap="">$error</pre>};
179 $title = $name = "$name on Catalyst $Catalyst::VERSION";
180 $name = "<h1>$name</h1>";
182 # Don't show context in the dump
183 $c->req->_clear_context;
184 $c->res->_clear_context;
186 # Don't show body parser in the dump
187 $c->req->_clear_body;
191 for my $dump ( $c->dump_these ) {
192 push @infos, $self->_dump_error_page_element($i, $dump);
195 $infos = join "\n", @infos;
202 (en) Please come back later
203 (fr) SVP veuillez revenir plus tard
204 (de) Bitte versuchen sie es spaeter nocheinmal
205 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
206 (no) Vennligst prov igjen senere
207 (dk) Venligst prov igen senere
208 (pl) Prosze sprobowac pozniej
209 (pt) Por favor volte mais tarde
210 (ru) Попробуйте еще раз позже
211 (ua) Спробуйте ще раз пізніше
216 $c->res->body( <<"" );
217 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
218 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
219 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
221 <meta http-equiv="Content-Language" content="en" />
222 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
223 <title>$title</title>
224 <script type="text/javascript">
226 function toggleDump (dumpElement) {
227 var e = document.getElementById( dumpElement );
228 if (e.style.display == "none") {
229 e.style.display = "";
232 e.style.display = "none";
237 <style type="text/css">
239 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
240 Tahoma, Arial, helvetica, sans-serif;
242 background-color: #eee;
246 :link, :link:hover, :visited, :visited:hover {
251 background-color: #ccc;
252 border: 1px solid #aaa;
257 background-color: #cce;
258 border: 1px solid #755;
264 background-color: #eee;
265 border: 1px solid #575;
271 background-color: #cce;
272 border: 1px solid #557;
281 div.name h1, div.error p {
289 text-decoration: underline;
295 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
296 /* Browser specific (not valid) styles to make preformatted text wrap */
298 white-space: pre-wrap; /* css-3 */
299 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
300 white-space: -pre-wrap; /* Opera 4-6 */
301 white-space: -o-pre-wrap; /* Opera 7 */
302 word-wrap: break-word; /* Internet Explorer 5.5+ */
308 <div class="error">$error</div>
309 <div class="infos">$infos</div>
310 <div class="name">$name</div>
315 # Trick IE. Old versions of IE would display their own error page instead
316 # of ours if we'd give it less than 512 bytes.
317 $c->res->{body} .= ( ' ' x 512 );
319 $c->res->{body} = Encode::encode("UTF-8", $c->res->{body});
322 $c->res->status(500);
325 =head2 $self->finalize_headers($c)
327 Abstract method, allows engines to write headers to response
331 sub finalize_headers {
332 my ($self, $ctx) = @_;
335 $ctx->response->headers->scan(sub { push @headers, @_ });
337 $self->_set_writer($self->_response_cb->([ $ctx->response->status, \@headers ]));
338 $self->_clear_response_cb;
343 =head2 $self->finalize_read($c)
347 sub finalize_read { }
349 =head2 $self->finalize_uploads($c)
351 Clean up after uploads, deleting temp files.
355 sub finalize_uploads {
356 my ( $self, $c ) = @_;
358 # N.B. This code is theoretically entirely unneeded due to ->cleanup(1)
359 # on the HTTP::Body object.
360 my $request = $c->request;
361 foreach my $key (keys %{ $request->uploads }) {
362 my $upload = $request->uploads->{$key};
363 unlink grep { -e $_ } map { $_->tempname }
364 (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
369 =head2 $self->prepare_body($c)
371 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
376 my ( $self, $c ) = @_;
378 my $appclass = ref($c) || $c;
379 if ( my $length = $self->read_length ) {
380 my $request = $c->request;
381 unless ( $request->_body ) {
382 my $type = $request->header('Content-Type');
383 $request->_body(HTTP::Body->new( $type, $length ));
384 $request->_body->cleanup(1); # Make extra sure!
385 $request->_body->tmpdir( $appclass->config->{uploadtmp} )
386 if exists $appclass->config->{uploadtmp};
389 # Check for definedness as you could read '0'
390 while ( defined ( my $buffer = $self->read($c) ) ) {
391 $c->prepare_body_chunk($buffer);
394 # paranoia against wrong Content-Length header
395 my $remaining = $length - $self->read_position;
396 if ( $remaining > 0 ) {
397 $self->finalize_read($c);
398 Catalyst::Exception->throw(
399 "Wrong Content-Length value: $length" );
403 # Defined but will cause all body code to be skipped
404 $c->request->_body(0);
408 =head2 $self->prepare_body_chunk($c)
410 Add a chunk to the request body.
414 sub prepare_body_chunk {
415 my ( $self, $c, $chunk ) = @_;
417 $c->request->_body->add($chunk);
420 =head2 $self->prepare_body_parameters($c)
422 Sets up parameters from body.
426 sub prepare_body_parameters {
427 my ( $self, $c ) = @_;
429 return unless $c->request->_body;
431 $c->request->body_parameters( $c->request->_body->param );
434 =head2 $self->prepare_connection($c)
436 Abstract method implemented in engines.
440 sub prepare_connection {
441 my ($self, $ctx) = @_;
443 my $env = $self->env;
444 my $request = $ctx->request;
446 $request->address( $env->{REMOTE_ADDR} );
447 $request->hostname( $env->{REMOTE_HOST} )
448 if exists $env->{REMOTE_HOST};
449 $request->protocol( $env->{SERVER_PROTOCOL} );
450 $request->remote_user( $env->{REMOTE_USER} );
451 $request->method( $env->{REQUEST_METHOD} );
452 $request->secure( $env->{'psgi.url_scheme'} eq 'https' ? 1 : 0 );
457 =head2 $self->prepare_cookies($c)
459 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
463 sub prepare_cookies {
464 my ( $self, $c ) = @_;
466 if ( my $header = $c->request->header('Cookie') ) {
467 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
471 =head2 $self->prepare_headers($c)
475 sub prepare_headers {
476 my ($self, $ctx) = @_;
478 my $env = $self->env;
479 my $headers = $ctx->request->headers;
481 for my $header (keys %{ $env }) {
482 next unless $header =~ /^(HTTP|CONTENT|COOKIE)/i;
483 (my $field = $header) =~ s/^HTTPS?_//;
485 $headers->header($field => $env->{$header});
489 =head2 $self->prepare_parameters($c)
491 sets up parameters from query and post parameters.
495 sub prepare_parameters {
496 my ( $self, $c ) = @_;
498 my $request = $c->request;
499 my $parameters = $request->parameters;
500 my $body_parameters = $request->body_parameters;
501 my $query_parameters = $request->query_parameters;
502 # We copy, no references
503 foreach my $name (keys %$query_parameters) {
504 my $param = $query_parameters->{$name};
505 $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
508 # Merge query and body parameters
509 foreach my $name (keys %$body_parameters) {
510 my $param = $body_parameters->{$name};
511 my @values = ref $param eq 'ARRAY' ? @$param : ($param);
512 if ( my $existing = $parameters->{$name} ) {
513 unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
515 $parameters->{$name} = @values > 1 ? \@values : $values[0];
519 =head2 $self->prepare_path($c)
521 abstract method, implemented by engines.
526 my ($self, $ctx) = @_;
528 my $env = $self->env;
530 my $scheme = $ctx->request->secure ? 'https' : 'http';
531 my $host = $env->{HTTP_HOST} || $env->{SERVER_NAME};
532 my $port = $env->{SERVER_PORT} || 80;
533 my $base_path = $env->{SCRIPT_NAME} || "/";
535 # set the request URI
537 if (!$ctx->config->{use_request_uri_for_path}) {
538 my $path_info = $env->{PATH_INFO};
539 if ( exists $env->{REDIRECT_URL} ) {
540 $base_path = $env->{REDIRECT_URL};
541 $base_path =~ s/\Q$path_info\E$//;
543 $path = $base_path . $path_info;
545 $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
546 $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
549 my $req_uri = $env->{REQUEST_URI};
550 $req_uri =~ s/\?.*$//;
555 # Using URI directly is way too slow, so we construct the URLs manually
556 my $uri_class = "URI::$scheme";
558 # HTTP_HOST will include the port even if it's 80/443
559 $host =~ s/:(?:80|443)$//;
561 if ($port !~ /^(?:80|443)$/ && $host !~ /:/) {
565 my $query = $env->{QUERY_STRING} ? '?' . $env->{QUERY_STRING} : '';
566 my $uri = $scheme . '://' . $host . '/' . $path . $query;
568 $ctx->request->uri( (bless \$uri, $uri_class)->canonical );
571 # base must end in a slash
572 $base_path .= '/' unless $base_path =~ m{/$};
574 my $base_uri = $scheme . '://' . $host . $base_path;
576 $ctx->request->base( bless \$base_uri, $uri_class );
581 =head2 $self->prepare_request($c)
583 =head2 $self->prepare_query_parameters($c)
585 process the query string and extract query parameters.
589 sub prepare_query_parameters {
592 my $query_string = exists $self->env->{QUERY_STRING}
593 ? $self->env->{QUERY_STRING}
596 # Check for keywords (no = signs)
597 # (yes, index() is faster than a regex :))
598 if ( index( $query_string, '=' ) < 0 ) {
599 $c->request->query_keywords( $self->unescape_uri($query_string) );
605 # replace semi-colons
606 $query_string =~ s/;/&/g;
608 my @params = grep { length $_ } split /&/, $query_string;
610 for my $item ( @params ) {
613 = map { $self->unescape_uri($_) }
614 split( /=/, $item, 2 );
616 $param = $self->unescape_uri($item) unless defined $param;
618 if ( exists $query{$param} ) {
619 if ( ref $query{$param} ) {
620 push @{ $query{$param} }, $value;
623 $query{$param} = [ $query{$param}, $value ];
627 $query{$param} = $value;
631 $c->request->query_parameters( \%query );
634 =head2 $self->prepare_read($c)
636 prepare to read from the engine.
641 my ( $self, $c ) = @_;
643 # Initialize the read position
644 $self->read_position(0);
646 # Initialize the amount of data we think we need to read
647 $self->read_length( $c->request->header('Content-Length') || 0 );
650 =head2 $self->prepare_request(@arguments)
652 Populate the context object from the request object.
656 sub prepare_request {
657 my ($self, $ctx, %args) = @_;
658 $self->_set_env($args{env});
661 =head2 $self->prepare_uploads($c)
665 sub prepare_uploads {
666 my ( $self, $c ) = @_;
668 my $request = $c->request;
669 return unless $request->_body;
671 my $uploads = $request->_body->upload;
672 my $parameters = $request->parameters;
673 foreach my $name (keys %$uploads) {
674 my $files = $uploads->{$name};
676 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
677 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
678 my $u = Catalyst::Request::Upload->new
680 size => $upload->{size},
681 type => scalar $headers->content_type,
683 tempname => $upload->{tempname},
684 filename => $upload->{filename},
688 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
690 # support access to the filename as a normal param
691 my @filenames = map { $_->{filename} } @uploads;
692 # append, if there's already params with this name
693 if (exists $parameters->{$name}) {
694 if (ref $parameters->{$name} eq 'ARRAY') {
695 push @{ $parameters->{$name} }, @filenames;
698 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
702 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
707 =head2 $self->prepare_write($c)
709 Abstract method. Implemented by the engines.
713 sub prepare_write { }
715 =head2 $self->read($c, [$maxlength])
717 Reads from the input stream by calling C<< $self->read_chunk >>.
719 Maintains the read_length and read_position counters as data is read.
724 my ( $self, $c, $maxlength ) = @_;
726 my $remaining = $self->read_length - $self->read_position;
727 $maxlength ||= $CHUNKSIZE;
729 # Are we done reading?
730 if ( $remaining <= 0 ) {
731 $self->finalize_read($c);
735 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
736 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
738 if (0 == $rc) { # Nothing more to read even though Content-Length
739 # said there should be.
740 $self->finalize_read;
743 $self->read_position( $self->read_position + $rc );
747 Catalyst::Exception->throw(
748 message => "Unknown error reading input: $!" );
752 =head2 $self->read_chunk($c, $buffer, $length)
754 Each engine implements read_chunk as its preferred way of reading a chunk
755 of data. Returns the number of bytes read. A return of 0 indicates that
756 there is no more data to be read.
761 my ($self, $ctx) = (shift, shift);
762 return $self->env->{'psgi.input'}->read(@_);
765 =head2 $self->read_length
767 The length of input data to be read. This is obtained from the Content-Length
770 =head2 $self->read_position
772 The amount of input data that has already been read.
774 =head2 $self->run($app, $server)
776 Start the engine. Builds a PSGI application and calls the
777 run method on the server passed in, which then causes the
778 engine to loop, handling requests..
783 my ($self, $app, $psgi, @args) = @_;
784 # @args left here rather than just a $options, $server for back compat with the
785 # old style scripts which send a few args, then a hashref
787 # They should never actually be used in the normal case as the Plack engine is
788 # passed in got all the 'standard' args via the loader in the script already.
790 # FIXME - we should stash the options in an attribute so that custom args
791 # like Gitalist's --git_dir are possible to get from the app without stupid tricks.
792 my $server = pop @args if (scalar @args && blessed $args[-1]);
793 my $options = pop @args if (scalar @args && ref($args[-1]) eq 'HASH');
794 # Back compat hack for applications with old (non Catalyst::Script) scripts to work in FCGI.
795 if (scalar @args && !ref($args[0])) {
796 if (my $listen = shift @args) {
797 $options->{listen} ||= [$listen];
801 $server = Catalyst::EngineLoader->new(application_name => ref($self))->auto(%$options);
802 # We're not being called from a script, so auto detect what backend to
803 # run on. This should never happen, as mod_perl never calls ->run,
804 # instead the $app->handle method is called per request.
805 $app->log->warn("Not supplied a Plack engine, falling back to engine auto-loader (are your scripts ancient?)")
807 $server->run($psgi, $options);
810 =head2 build_psgi_app ($app, @args)
812 Builds and returns a PSGI application closure, wrapping it in the reverse proxy
813 middleware if the using_frontend_proxy config setting is set.
818 my ($self, $app, @args) = @_;
825 $self->_set_response_cb($respond);
826 $app->handle_request(env => $env);
831 =head2 $self->write($c, $buffer)
833 Writes the buffer to the client.
838 my ( $self, $c, $buffer ) = @_;
840 unless ( $self->_prepared_write ) {
841 $self->prepare_write($c);
842 $self->_prepared_write(1);
845 $buffer = q[] unless defined $buffer;
847 my $len = length($buffer);
848 $self->_writer->write($buffer);
853 =head2 $self->unescape_uri($uri)
855 Unescapes a given URI using the most efficient method available. Engines such
856 as Apache may implement this using Apache's C-based modules, for example.
861 my ( $self, $str ) = @_;
863 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
868 =head2 $self->finalize_output
870 <obsolete>, see finalize_body
874 Hash containing environment variables including many special variables inserted
875 by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
877 Before accessing environment variables consider whether the same information is
878 not directly available via Catalyst objects $c->request, $c->engine ...
880 BEWARE: If you really need to access some environment variable from your Catalyst
881 application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
882 as in some enviroments the %ENV hash does not contain what you would expect.
886 Catalyst Contributors, see Catalyst.pm
890 This library is free software. You can redistribute it and/or modify it under
891 the same terms as Perl itself.