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 Catalyst::EngineLoader;
18 use namespace::clean -except => 'meta';
20 # Amount of data to read from input on each pass
21 our $CHUNKSIZE = 64 * 1024;
23 # XXX - this is only here for compat, do not use!
24 has env => ( is => 'rw', writer => '_set_env' );
25 my $WARN_ABOUT_ENV = 0;
27 my ($orig, $self, @args) = @_;
29 warn "env as a writer is deprecated, you probably need to upgrade Catalyst::Engine::PSGI"
30 unless $WARN_ABOUT_ENV++;
31 return $self->_set_env(@args);
36 # XXX - Only here for Engine::PSGI compat
37 sub prepare_connection {
38 my ($self, $ctx) = @_;
39 $ctx->request->prepare_connection;
44 Catalyst::Engine - The Catalyst Engine
55 =head2 $self->finalize_body($c)
57 Finalize body. Prints the response output.
62 my ( $self, $c ) = @_;
63 my $body = $c->response->body;
64 no warnings 'uninitialized';
65 if ( blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
68 $got = read $body, my ($buffer), $CHUNKSIZE;
69 $got = 0 unless $self->write( $c, $buffer );
75 $self->write( $c, $body );
78 my $res = $c->response;
85 =head2 $self->finalize_cookies($c)
87 Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
92 sub finalize_cookies {
93 my ( $self, $c ) = @_;
96 my $response = $c->response;
98 foreach my $name (keys %{ $response->cookies }) {
100 my $val = $response->cookies->{$name};
105 : CGI::Simple::Cookie->new(
107 -value => $val->{value},
108 -expires => $val->{expires},
109 -domain => $val->{domain},
110 -path => $val->{path},
111 -secure => $val->{secure} || 0,
112 -httponly => $val->{httponly} || 0,
115 if (!defined $cookie) {
116 $c->log->warn("undef passed in '$name' cookie value - not setting cookie")
121 push @cookies, $cookie->as_string;
124 for my $cookie (@cookies) {
125 $response->headers->push_header( 'Set-Cookie' => $cookie );
129 =head2 $self->finalize_error($c)
131 Output an appropriate error message. Called if there's an error in $c
132 after the dispatch has finished. Will output debug messages if Catalyst
133 is in debug mode, or a `please come back later` message otherwise.
137 sub _dump_error_page_element {
138 my ($self, $i, $element) = @_;
139 my ($name, $val) = @{ $element };
141 # This is fugly, but the metaclass is _HUGE_ and demands waaay too much
142 # scrolling. Suggestions for more pleasant ways to do this welcome.
143 local $val->{'__MOP__'} = "Stringified: "
144 . $val->{'__MOP__'} if ref $val eq 'HASH' && exists $val->{'__MOP__'};
146 my $text = encode_entities( dump( $val ));
147 sprintf <<"EOF", $name, $text;
148 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
150 <pre wrap="">%s</pre>
156 my ( $self, $c ) = @_;
158 $c->res->content_type('text/html; charset=utf-8');
159 my $name = ref($c)->config->{name} || join(' ', split('::', ref $c));
161 # Prevent Catalyst::Plugin::Unicode::Encoding from running.
162 # This is a little nasty, but it's the best way to be clean whether or
163 # not the user has an encoding plugin.
165 if ($c->can('encoding')) {
169 my ( $title, $error, $infos );
173 $error = join '', map {
174 '<p><code class="error">'
175 . encode_entities($_)
178 $error ||= 'No output';
179 $error = qq{<pre wrap="">$error</pre>};
180 $title = $name = "$name on Catalyst $Catalyst::VERSION";
181 $name = "<h1>$name</h1>";
183 # Don't show context in the dump
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 Allows engines to write headers to response
331 sub finalize_headers {
332 my ($self, $ctx) = @_;
334 $ctx->finalize_headers unless $ctx->response->finalized_headers;
338 =head2 $self->finalize_uploads($c)
340 Clean up after uploads, deleting temp files.
344 sub finalize_uploads {
345 my ( $self, $c ) = @_;
347 # N.B. This code is theoretically entirely unneeded due to ->cleanup(1)
348 # on the HTTP::Body object.
349 my $request = $c->request;
350 foreach my $key (keys %{ $request->uploads }) {
351 my $upload = $request->uploads->{$key};
352 unlink grep { -e $_ } map { $_->tempname }
353 (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
358 =head2 $self->prepare_body($c)
360 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
365 my ( $self, $c ) = @_;
367 $c->request->prepare_body;
370 =head2 $self->prepare_body_chunk($c)
372 Add a chunk to the request body.
376 # XXX - Can this be deleted?
377 sub prepare_body_chunk {
378 my ( $self, $c, $chunk ) = @_;
380 $c->request->prepare_body_chunk($chunk);
383 =head2 $self->prepare_body_parameters($c)
385 Sets up parameters from body.
389 sub prepare_body_parameters {
390 my ( $self, $c ) = @_;
392 $c->request->prepare_body_parameters;
395 =head2 $self->prepare_parameters($c)
397 Sets up parameters from query and post parameters.
398 If parameters have already been set up will clear
399 existing parameters and set up again.
403 sub prepare_parameters {
404 my ( $self, $c ) = @_;
406 $c->request->_clear_parameters;
407 return $c->request->parameters;
410 =head2 $self->prepare_path($c)
412 abstract method, implemented by engines.
417 my ($self, $ctx) = @_;
419 my $env = $ctx->request->env;
421 my $scheme = $ctx->request->secure ? 'https' : 'http';
422 my $host = $env->{HTTP_HOST} || $env->{SERVER_NAME};
423 my $port = $env->{SERVER_PORT} || 80;
424 my $base_path = $env->{SCRIPT_NAME} || "/";
426 # set the request URI
428 if (!$ctx->config->{use_request_uri_for_path}) {
429 my $path_info = $env->{PATH_INFO};
430 if ( exists $env->{REDIRECT_URL} ) {
431 $base_path = $env->{REDIRECT_URL};
432 $base_path =~ s/\Q$path_info\E$//;
434 $path = $base_path . $path_info;
436 $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
437 $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
440 my $req_uri = $env->{REQUEST_URI};
441 $req_uri =~ s/\?.*$//;
446 # Using URI directly is way too slow, so we construct the URLs manually
447 my $uri_class = "URI::$scheme";
449 # HTTP_HOST will include the port even if it's 80/443
450 $host =~ s/:(?:80|443)$//;
452 if ($port !~ /^(?:80|443)$/ && $host !~ /:/) {
456 my $query = $env->{QUERY_STRING} ? '?' . $env->{QUERY_STRING} : '';
457 my $uri = $scheme . '://' . $host . '/' . $path . $query;
459 $ctx->request->uri( (bless \$uri, $uri_class)->canonical );
462 # base must end in a slash
463 $base_path .= '/' unless $base_path =~ m{/$};
465 my $base_uri = $scheme . '://' . $host . $base_path;
467 $ctx->request->base( bless \$base_uri, $uri_class );
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 {
483 my $env = $c->request->env;
484 my $query_string = exists $env->{QUERY_STRING}
485 ? $env->{QUERY_STRING}
488 # Check for keywords (no = signs)
489 # (yes, index() is faster than a regex :))
490 if ( index( $query_string, '=' ) < 0 ) {
491 $c->request->query_keywords( $self->unescape_uri($query_string) );
497 # replace semi-colons
498 $query_string =~ s/;/&/g;
500 my @params = grep { length $_ } split /&/, $query_string;
502 for my $item ( @params ) {
505 = map { $self->unescape_uri($_) }
506 split( /=/, $item, 2 );
508 $param = $self->unescape_uri($item) unless defined $param;
510 if ( exists $query{$param} ) {
511 if ( ref $query{$param} ) {
512 push @{ $query{$param} }, $value;
515 $query{$param} = [ $query{$param}, $value ];
519 $query{$param} = $value;
522 $c->request->query_parameters( \%query );
525 =head2 $self->prepare_read($c)
527 Prepare to read by initializing the Content-Length from headers.
532 my ( $self, $c ) = @_;
534 # Initialize the amount of data we think we need to read
535 $c->request->_read_length;
538 =head2 $self->prepare_request(@arguments)
540 Populate the context object from the request object.
544 sub prepare_request {
545 my ($self, $ctx, %args) = @_;
546 $ctx->log->psgienv($args{env}) if $ctx->log->can('psgienv');
547 $ctx->request->_set_env($args{env});
548 $self->_set_env($args{env}); # Nasty back compat!
549 $ctx->response->_set_response_cb($args{response_cb});
552 =head2 $self->prepare_uploads($c)
556 sub prepare_uploads {
557 my ( $self, $c ) = @_;
559 my $request = $c->request;
560 return unless $request->_body;
562 my $uploads = $request->_body->upload;
563 my $parameters = $request->parameters;
564 foreach my $name (keys %$uploads) {
565 my $files = $uploads->{$name};
567 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
568 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
569 my $u = Catalyst::Request::Upload->new
571 size => $upload->{size},
572 type => scalar $headers->content_type,
574 tempname => $upload->{tempname},
575 filename => $upload->{filename},
579 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
581 # support access to the filename as a normal param
582 my @filenames = map { $_->{filename} } @uploads;
583 # append, if there's already params with this name
584 if (exists $parameters->{$name}) {
585 if (ref $parameters->{$name} eq 'ARRAY') {
586 push @{ $parameters->{$name} }, @filenames;
589 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
593 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
598 =head2 $self->write($c, $buffer)
600 Writes the buffer to the client.
605 my ( $self, $c, $buffer ) = @_;
607 $c->response->write($buffer);
610 =head2 $self->read($c, [$maxlength])
612 Reads from the input stream by calling C<< $self->read_chunk >>.
614 Maintains the read_length and read_position counters as data is read.
619 my ( $self, $c, $maxlength ) = @_;
621 $c->request->read($maxlength);
624 =head2 $self->read_chunk($c, \$buffer, $length)
626 Each engine implements read_chunk as its preferred way of reading a chunk
627 of data. Returns the number of bytes read. A return of 0 indicates that
628 there is no more data to be read.
633 my ($self, $ctx) = (shift, shift);
634 return $ctx->request->read_chunk(@_);
637 =head2 $self->run($app, $server)
639 Start the engine. Builds a PSGI application and calls the
640 run method on the server passed in, which then causes the
641 engine to loop, handling requests..
646 my ($self, $app, $psgi, @args) = @_;
647 # @args left here rather than just a $options, $server for back compat with the
648 # old style scripts which send a few args, then a hashref
650 # They should never actually be used in the normal case as the Plack engine is
651 # passed in got all the 'standard' args via the loader in the script already.
653 # FIXME - we should stash the options in an attribute so that custom args
654 # like Gitalist's --git_dir are possible to get from the app without stupid tricks.
655 my $server = pop @args if (scalar @args && blessed $args[-1]);
656 my $options = pop @args if (scalar @args && ref($args[-1]) eq 'HASH');
657 # Back compat hack for applications with old (non Catalyst::Script) scripts to work in FCGI.
658 if (scalar @args && !ref($args[0])) {
659 if (my $listen = shift @args) {
660 $options->{listen} ||= [$listen];
664 $server = Catalyst::EngineLoader->new(application_name => ref($self))->auto(%$options);
665 # We're not being called from a script, so auto detect what backend to
666 # run on. This should never happen, as mod_perl never calls ->run,
667 # instead the $app->handle method is called per request.
668 $app->log->warn("Not supplied a Plack engine, falling back to engine auto-loader (are your scripts ancient?)")
670 $app->run_options($options);
671 $server->run($psgi, $options);
674 =head2 build_psgi_app ($app, @args)
676 Builds and returns a PSGI application closure. (Raw, not wrapped in middleware)
681 my ($self, $app, @args) = @_;
688 confess("Did not get a response callback for writer, cannot continiue") unless $respond;
689 $app->handle_request(env => $env, response_cb => $respond);
694 =head2 $self->unescape_uri($uri)
696 Unescapes a given URI using the most efficient method available. Engines such
697 as Apache may implement this using Apache's C-based modules, for example.
702 my ( $self, $str ) = @_;
704 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
709 =head2 $self->finalize_output
711 <obsolete>, see finalize_body
715 Hash containing environment variables including many special variables inserted
716 by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
718 Before accessing environment variables consider whether the same information is
719 not directly available via Catalyst objects $c->request, $c->engine ...
721 BEWARE: If you really need to access some environment variable from your Catalyst
722 application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
723 as in some environments the %ENV hash does not contain what you would expect.
727 Catalyst Contributors, see Catalyst.pm
731 This library is free software. You can redistribute it and/or modify it under
732 the same terms as Perl itself.
736 __PACKAGE__->meta->make_immutable;