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->req->_clear_context;
185 $c->res->_clear_context;
187 # Don't show body parser in the dump
188 $c->req->_clear_body;
192 for my $dump ( $c->dump_these ) {
193 push @infos, $self->_dump_error_page_element($i, $dump);
196 $infos = join "\n", @infos;
203 (en) Please come back later
204 (fr) SVP veuillez revenir plus tard
205 (de) Bitte versuchen sie es spaeter nocheinmal
206 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
207 (no) Vennligst prov igjen senere
208 (dk) Venligst prov igen senere
209 (pl) Prosze sprobowac pozniej
210 (pt) Por favor volte mais tarde
211 (ru) Попробуйте еще раз позже
212 (ua) Спробуйте ще раз пізніше
217 $c->res->body( <<"" );
218 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
219 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
220 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
222 <meta http-equiv="Content-Language" content="en" />
223 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
224 <title>$title</title>
225 <script type="text/javascript">
227 function toggleDump (dumpElement) {
228 var e = document.getElementById( dumpElement );
229 if (e.style.display == "none") {
230 e.style.display = "";
233 e.style.display = "none";
238 <style type="text/css">
240 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
241 Tahoma, Arial, helvetica, sans-serif;
243 background-color: #eee;
247 :link, :link:hover, :visited, :visited:hover {
252 background-color: #ccc;
253 border: 1px solid #aaa;
258 background-color: #cce;
259 border: 1px solid #755;
265 background-color: #eee;
266 border: 1px solid #575;
272 background-color: #cce;
273 border: 1px solid #557;
282 div.name h1, div.error p {
290 text-decoration: underline;
296 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
297 /* Browser specific (not valid) styles to make preformatted text wrap */
299 white-space: pre-wrap; /* css-3 */
300 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
301 white-space: -pre-wrap; /* Opera 4-6 */
302 white-space: -o-pre-wrap; /* Opera 7 */
303 word-wrap: break-word; /* Internet Explorer 5.5+ */
309 <div class="error">$error</div>
310 <div class="infos">$infos</div>
311 <div class="name">$name</div>
316 # Trick IE. Old versions of IE would display their own error page instead
317 # of ours if we'd give it less than 512 bytes.
318 $c->res->{body} .= ( ' ' x 512 );
320 $c->res->{body} = Encode::encode("UTF-8", $c->res->{body});
323 $c->res->status(500);
326 =head2 $self->finalize_headers($c)
328 Allows engines to write headers to response
332 sub finalize_headers {
333 my ($self, $ctx) = @_;
335 $ctx->response->finalize_headers;
339 =head2 $self->finalize_uploads($c)
341 Clean up after uploads, deleting temp files.
345 sub finalize_uploads {
346 my ( $self, $c ) = @_;
348 # N.B. This code is theoretically entirely unneeded due to ->cleanup(1)
349 # on the HTTP::Body object.
350 my $request = $c->request;
351 foreach my $key (keys %{ $request->uploads }) {
352 my $upload = $request->uploads->{$key};
353 unlink grep { -e $_ } map { $_->tempname }
354 (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
359 =head2 $self->prepare_body($c)
361 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
366 my ( $self, $c ) = @_;
368 $c->request->prepare_body;
371 =head2 $self->prepare_body_chunk($c)
373 Add a chunk to the request body.
377 # XXX - Can this be deleted?
378 sub prepare_body_chunk {
379 my ( $self, $c, $chunk ) = @_;
381 $c->request->prepare_body_chunk($chunk);
384 =head2 $self->prepare_body_parameters($c)
386 Sets up parameters from body.
390 sub prepare_body_parameters {
391 my ( $self, $c ) = @_;
393 $c->request->prepare_body_parameters;
396 =head2 $self->prepare_parameters($c)
398 sets up parameters from query and post parameters.
402 sub prepare_parameters {
403 my ( $self, $c ) = @_;
405 $c->request->parameters;
408 =head2 $self->prepare_path($c)
410 abstract method, implemented by engines.
415 my ($self, $ctx) = @_;
417 my $env = $ctx->request->env;
419 my $scheme = $ctx->request->secure ? 'https' : 'http';
420 my $host = $env->{HTTP_HOST} || $env->{SERVER_NAME};
421 my $port = $env->{SERVER_PORT} || 80;
422 my $base_path = $env->{SCRIPT_NAME} || "/";
424 # set the request URI
426 if (!$ctx->config->{use_request_uri_for_path}) {
427 my $path_info = $env->{PATH_INFO};
428 if ( exists $env->{REDIRECT_URL} ) {
429 $base_path = $env->{REDIRECT_URL};
430 $base_path =~ s/\Q$path_info\E$//;
432 $path = $base_path . $path_info;
434 $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
435 $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
438 my $req_uri = $env->{REQUEST_URI};
439 $req_uri =~ s/\?.*$//;
444 # Using URI directly is way too slow, so we construct the URLs manually
445 my $uri_class = "URI::$scheme";
447 # HTTP_HOST will include the port even if it's 80/443
448 $host =~ s/:(?:80|443)$//;
450 if ($port !~ /^(?:80|443)$/ && $host !~ /:/) {
454 my $query = $env->{QUERY_STRING} ? '?' . $env->{QUERY_STRING} : '';
455 my $uri = $scheme . '://' . $host . '/' . $path . $query;
457 $ctx->request->uri( (bless \$uri, $uri_class)->canonical );
460 # base must end in a slash
461 $base_path .= '/' unless $base_path =~ m{/$};
463 my $base_uri = $scheme . '://' . $host . $base_path;
465 $ctx->request->base( bless \$base_uri, $uri_class );
470 =head2 $self->prepare_request($c)
472 =head2 $self->prepare_query_parameters($c)
474 process the query string and extract query parameters.
478 sub prepare_query_parameters {
481 my $env = $c->request->env;
482 my $query_string = exists $env->{QUERY_STRING}
483 ? $env->{QUERY_STRING}
486 # Check for keywords (no = signs)
487 # (yes, index() is faster than a regex :))
488 if ( index( $query_string, '=' ) < 0 ) {
489 $c->request->query_keywords( $self->unescape_uri($query_string) );
495 # replace semi-colons
496 $query_string =~ s/;/&/g;
498 my @params = grep { length $_ } split /&/, $query_string;
500 for my $item ( @params ) {
503 = map { $self->unescape_uri($_) }
504 split( /=/, $item, 2 );
506 $param = $self->unescape_uri($item) unless defined $param;
508 if ( exists $query{$param} ) {
509 if ( ref $query{$param} ) {
510 push @{ $query{$param} }, $value;
513 $query{$param} = [ $query{$param}, $value ];
517 $query{$param} = $value;
520 $c->request->query_parameters( \%query );
523 =head2 $self->prepare_read($c)
525 Prepare to read by initializing the Content-Length from headers.
530 my ( $self, $c ) = @_;
532 # Initialize the amount of data we think we need to read
533 $c->request->_read_length;
536 =head2 $self->prepare_request(@arguments)
538 Populate the context object from the request object.
542 sub prepare_request {
543 my ($self, $ctx, %args) = @_;
544 $ctx->request->_set_env($args{env});
545 $self->_set_env($args{env}); # Nasty back compat!
546 $ctx->response->_set_response_cb($args{response_cb});
549 =head2 $self->prepare_uploads($c)
553 sub prepare_uploads {
554 my ( $self, $c ) = @_;
556 my $request = $c->request;
557 return unless $request->_body;
559 my $uploads = $request->_body->upload;
560 my $parameters = $request->parameters;
561 foreach my $name (keys %$uploads) {
562 my $files = $uploads->{$name};
564 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
565 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
566 my $u = Catalyst::Request::Upload->new
568 size => $upload->{size},
569 type => scalar $headers->content_type,
571 tempname => $upload->{tempname},
572 filename => $upload->{filename},
576 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
578 # support access to the filename as a normal param
579 my @filenames = map { $_->{filename} } @uploads;
580 # append, if there's already params with this name
581 if (exists $parameters->{$name}) {
582 if (ref $parameters->{$name} eq 'ARRAY') {
583 push @{ $parameters->{$name} }, @filenames;
586 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
590 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
595 =head2 $self->write($c, $buffer)
597 Writes the buffer to the client.
602 my ( $self, $c, $buffer ) = @_;
604 $c->response->write($buffer);
607 =head2 $self->read($c, [$maxlength])
609 Reads from the input stream by calling C<< $self->read_chunk >>.
611 Maintains the read_length and read_position counters as data is read.
616 my ( $self, $c, $maxlength ) = @_;
618 $c->request->read($maxlength);
621 =head2 $self->read_chunk($c, \$buffer, $length)
623 Each engine implements read_chunk as its preferred way of reading a chunk
624 of data. Returns the number of bytes read. A return of 0 indicates that
625 there is no more data to be read.
630 my ($self, $ctx) = (shift, shift);
631 return $ctx->request->read_chunk(@_);
634 =head2 $self->run($app, $server)
636 Start the engine. Builds a PSGI application and calls the
637 run method on the server passed in, which then causes the
638 engine to loop, handling requests..
643 my ($self, $app, $psgi, @args) = @_;
644 # @args left here rather than just a $options, $server for back compat with the
645 # old style scripts which send a few args, then a hashref
647 # They should never actually be used in the normal case as the Plack engine is
648 # passed in got all the 'standard' args via the loader in the script already.
650 # FIXME - we should stash the options in an attribute so that custom args
651 # like Gitalist's --git_dir are possible to get from the app without stupid tricks.
652 my $server = pop @args if (scalar @args && blessed $args[-1]);
653 my $options = pop @args if (scalar @args && ref($args[-1]) eq 'HASH');
654 # Back compat hack for applications with old (non Catalyst::Script) scripts to work in FCGI.
655 if (scalar @args && !ref($args[0])) {
656 if (my $listen = shift @args) {
657 $options->{listen} ||= [$listen];
661 $server = Catalyst::EngineLoader->new(application_name => ref($self))->auto(%$options);
662 # We're not being called from a script, so auto detect what backend to
663 # run on. This should never happen, as mod_perl never calls ->run,
664 # instead the $app->handle method is called per request.
665 $app->log->warn("Not supplied a Plack engine, falling back to engine auto-loader (are your scripts ancient?)")
667 $app->run_options($options);
668 $server->run($psgi, $options);
671 =head2 build_psgi_app ($app, @args)
673 Builds and returns a PSGI application closure. (Raw, not wrapped in middleware)
678 my ($self, $app, @args) = @_;
685 $app->handle_request(env => $env, response_cb => $respond);
690 =head2 $self->unescape_uri($uri)
692 Unescapes a given URI using the most efficient method available. Engines such
693 as Apache may implement this using Apache's C-based modules, for example.
698 my ( $self, $str ) = @_;
700 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
705 =head2 $self->finalize_output
707 <obsolete>, see finalize_body
711 Hash containing environment variables including many special variables inserted
712 by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
714 Before accessing environment variables consider whether the same information is
715 not directly available via Catalyst objects $c->request, $c->engine ...
717 BEWARE: If you really need to access some environment variable from your Catalyst
718 application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
719 as in some environments the %ENV hash does not contain what you would expect.
723 Catalyst Contributors, see Catalyst.pm
727 This library is free software. You can redistribute it and/or modify it under
728 the same terms as Perl itself.