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->request->_set_env($args{env});
547 $self->_set_env($args{env}); # Nasty back compat!
548 $ctx->response->_set_response_cb($args{response_cb});
551 =head2 $self->prepare_uploads($c)
555 sub prepare_uploads {
556 my ( $self, $c ) = @_;
558 my $request = $c->request;
559 return unless $request->_body;
561 my $uploads = $request->_body->upload;
562 my $parameters = $request->parameters;
563 foreach my $name (keys %$uploads) {
564 my $files = $uploads->{$name};
566 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
567 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
568 my $u = Catalyst::Request::Upload->new
570 size => $upload->{size},
571 type => scalar $headers->content_type,
573 tempname => $upload->{tempname},
574 filename => $upload->{filename},
578 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
580 # support access to the filename as a normal param
581 my @filenames = map { $_->{filename} } @uploads;
582 # append, if there's already params with this name
583 if (exists $parameters->{$name}) {
584 if (ref $parameters->{$name} eq 'ARRAY') {
585 push @{ $parameters->{$name} }, @filenames;
588 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
592 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
597 =head2 $self->write($c, $buffer)
599 Writes the buffer to the client.
604 my ( $self, $c, $buffer ) = @_;
606 $c->response->write($buffer);
609 =head2 $self->read($c, [$maxlength])
611 Reads from the input stream by calling C<< $self->read_chunk >>.
613 Maintains the read_length and read_position counters as data is read.
618 my ( $self, $c, $maxlength ) = @_;
620 $c->request->read($maxlength);
623 =head2 $self->read_chunk($c, \$buffer, $length)
625 Each engine implements read_chunk as its preferred way of reading a chunk
626 of data. Returns the number of bytes read. A return of 0 indicates that
627 there is no more data to be read.
632 my ($self, $ctx) = (shift, shift);
633 return $ctx->request->read_chunk(@_);
636 =head2 $self->run($app, $server)
638 Start the engine. Builds a PSGI application and calls the
639 run method on the server passed in, which then causes the
640 engine to loop, handling requests..
645 my ($self, $app, $psgi, @args) = @_;
646 # @args left here rather than just a $options, $server for back compat with the
647 # old style scripts which send a few args, then a hashref
649 # They should never actually be used in the normal case as the Plack engine is
650 # passed in got all the 'standard' args via the loader in the script already.
652 # FIXME - we should stash the options in an attribute so that custom args
653 # like Gitalist's --git_dir are possible to get from the app without stupid tricks.
654 my $server = pop @args if (scalar @args && blessed $args[-1]);
655 my $options = pop @args if (scalar @args && ref($args[-1]) eq 'HASH');
656 # Back compat hack for applications with old (non Catalyst::Script) scripts to work in FCGI.
657 if (scalar @args && !ref($args[0])) {
658 if (my $listen = shift @args) {
659 $options->{listen} ||= [$listen];
663 $server = Catalyst::EngineLoader->new(application_name => ref($self))->auto(%$options);
664 # We're not being called from a script, so auto detect what backend to
665 # run on. This should never happen, as mod_perl never calls ->run,
666 # instead the $app->handle method is called per request.
667 $app->log->warn("Not supplied a Plack engine, falling back to engine auto-loader (are your scripts ancient?)")
669 $app->run_options($options);
670 $server->run($psgi, $options);
673 =head2 build_psgi_app ($app, @args)
675 Builds and returns a PSGI application closure. (Raw, not wrapped in middleware)
680 my ($self, $app, @args) = @_;
687 confess("Did not get a response callback for writer, cannot continiue") unless $respond;
688 $app->handle_request(env => $env, response_cb => $respond);
693 =head2 $self->unescape_uri($uri)
695 Unescapes a given URI using the most efficient method available. Engines such
696 as Apache may implement this using Apache's C-based modules, for example.
701 my ( $self, $str ) = @_;
703 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
708 =head2 $self->finalize_output
710 <obsolete>, see finalize_body
714 Hash containing environment variables including many special variables inserted
715 by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
717 Before accessing environment variables consider whether the same information is
718 not directly available via Catalyst objects $c->request, $c->engine ...
720 BEWARE: If you really need to access some environment variable from your Catalyst
721 application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
722 as in some environments the %ENV hash does not contain what you would expect.
726 Catalyst Contributors, see Catalyst.pm
730 This library is free software. You can redistribute it and/or modify it under
731 the same terms as Perl itself.
735 __PACKAGE__->meta->make_immutable;