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->response->finalize_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.
401 sub prepare_parameters {
402 my ( $self, $c ) = @_;
404 $c->request->parameters;
407 =head2 $self->prepare_path($c)
409 abstract method, implemented by engines.
414 my ($self, $ctx) = @_;
416 my $env = $ctx->request->env;
418 my $scheme = $ctx->request->secure ? 'https' : 'http';
419 my $host = $env->{HTTP_HOST} || $env->{SERVER_NAME};
420 my $port = $env->{SERVER_PORT} || 80;
421 my $base_path = $env->{SCRIPT_NAME} || "/";
423 # set the request URI
425 if (!$ctx->config->{use_request_uri_for_path}) {
426 my $path_info = $env->{PATH_INFO};
427 if ( exists $env->{REDIRECT_URL} ) {
428 $base_path = $env->{REDIRECT_URL};
429 $base_path =~ s/\Q$path_info\E$//;
431 $path = $base_path . $path_info;
433 $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
434 $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
437 my $req_uri = $env->{REQUEST_URI};
438 $req_uri =~ s/\?.*$//;
443 # Using URI directly is way too slow, so we construct the URLs manually
444 my $uri_class = "URI::$scheme";
446 # HTTP_HOST will include the port even if it's 80/443
447 $host =~ s/:(?:80|443)$//;
449 if ($port !~ /^(?:80|443)$/ && $host !~ /:/) {
453 my $query = $env->{QUERY_STRING} ? '?' . $env->{QUERY_STRING} : '';
454 my $uri = $scheme . '://' . $host . '/' . $path . $query;
456 $ctx->request->uri( (bless \$uri, $uri_class)->canonical );
459 # base must end in a slash
460 $base_path .= '/' unless $base_path =~ m{/$};
462 my $base_uri = $scheme . '://' . $host . $base_path;
464 $ctx->request->base( bless \$base_uri, $uri_class );
469 =head2 $self->prepare_request($c)
471 =head2 $self->prepare_query_parameters($c)
473 process the query string and extract query parameters.
477 sub prepare_query_parameters {
480 my $env = $c->request->env;
481 my $query_string = exists $env->{QUERY_STRING}
482 ? $env->{QUERY_STRING}
485 # Check for keywords (no = signs)
486 # (yes, index() is faster than a regex :))
487 if ( index( $query_string, '=' ) < 0 ) {
488 $c->request->query_keywords( $self->unescape_uri($query_string) );
494 # replace semi-colons
495 $query_string =~ s/;/&/g;
497 my @params = grep { length $_ } split /&/, $query_string;
499 for my $item ( @params ) {
502 = map { $self->unescape_uri($_) }
503 split( /=/, $item, 2 );
505 $param = $self->unescape_uri($item) unless defined $param;
507 if ( exists $query{$param} ) {
508 if ( ref $query{$param} ) {
509 push @{ $query{$param} }, $value;
512 $query{$param} = [ $query{$param}, $value ];
516 $query{$param} = $value;
519 $c->request->query_parameters( \%query );
522 =head2 $self->prepare_read($c)
524 Prepare to read by initializing the Content-Length from headers.
529 my ( $self, $c ) = @_;
531 # Initialize the amount of data we think we need to read
532 $c->request->_read_length;
535 =head2 $self->prepare_request(@arguments)
537 Populate the context object from the request object.
541 sub prepare_request {
542 my ($self, $ctx, %args) = @_;
543 $ctx->request->_set_env($args{env});
544 $self->_set_env($args{env}); # Nasty back compat!
545 $ctx->response->_set_response_cb($args{response_cb});
548 =head2 $self->prepare_uploads($c)
552 sub prepare_uploads {
553 my ( $self, $c ) = @_;
555 my $request = $c->request;
556 return unless $request->_body;
558 my $uploads = $request->_body->upload;
559 my $parameters = $request->parameters;
560 foreach my $name (keys %$uploads) {
561 my $files = $uploads->{$name};
563 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
564 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
565 my $u = Catalyst::Request::Upload->new
567 size => $upload->{size},
568 type => scalar $headers->content_type,
570 tempname => $upload->{tempname},
571 filename => $upload->{filename},
575 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
577 # support access to the filename as a normal param
578 my @filenames = map { $_->{filename} } @uploads;
579 # append, if there's already params with this name
580 if (exists $parameters->{$name}) {
581 if (ref $parameters->{$name} eq 'ARRAY') {
582 push @{ $parameters->{$name} }, @filenames;
585 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
589 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
594 =head2 $self->write($c, $buffer)
596 Writes the buffer to the client.
601 my ( $self, $c, $buffer ) = @_;
603 $c->response->write($buffer);
606 =head2 $self->read($c, [$maxlength])
608 Reads from the input stream by calling C<< $self->read_chunk >>.
610 Maintains the read_length and read_position counters as data is read.
615 my ( $self, $c, $maxlength ) = @_;
617 $c->request->read($maxlength);
620 =head2 $self->read_chunk($c, \$buffer, $length)
622 Each engine implements read_chunk as its preferred way of reading a chunk
623 of data. Returns the number of bytes read. A return of 0 indicates that
624 there is no more data to be read.
629 my ($self, $ctx) = (shift, shift);
630 return $ctx->request->read_chunk(@_);
633 =head2 $self->run($app, $server)
635 Start the engine. Builds a PSGI application and calls the
636 run method on the server passed in, which then causes the
637 engine to loop, handling requests..
642 my ($self, $app, $psgi, @args) = @_;
643 # @args left here rather than just a $options, $server for back compat with the
644 # old style scripts which send a few args, then a hashref
646 # They should never actually be used in the normal case as the Plack engine is
647 # passed in got all the 'standard' args via the loader in the script already.
649 # FIXME - we should stash the options in an attribute so that custom args
650 # like Gitalist's --git_dir are possible to get from the app without stupid tricks.
651 my $server = pop @args if (scalar @args && blessed $args[-1]);
652 my $options = pop @args if (scalar @args && ref($args[-1]) eq 'HASH');
653 # Back compat hack for applications with old (non Catalyst::Script) scripts to work in FCGI.
654 if (scalar @args && !ref($args[0])) {
655 if (my $listen = shift @args) {
656 $options->{listen} ||= [$listen];
660 $server = Catalyst::EngineLoader->new(application_name => ref($self))->auto(%$options);
661 # We're not being called from a script, so auto detect what backend to
662 # run on. This should never happen, as mod_perl never calls ->run,
663 # instead the $app->handle method is called per request.
664 $app->log->warn("Not supplied a Plack engine, falling back to engine auto-loader (are your scripts ancient?)")
666 $app->run_options($options);
667 $server->run($psgi, $options);
670 =head2 build_psgi_app ($app, @args)
672 Builds and returns a PSGI application closure. (Raw, not wrapped in middleware)
677 my ($self, $app, @args) = @_;
684 confess("Did not get a response callback for writer, cannot continiue") unless $respond;
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.