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 my $WARN_ABOUT_ENV = 0;
25 my ($orig, $self, @args) = @_;
27 warn "env as a writer is deprecated, you probably need to upgrade Catalyst::Engine::PSGI"
28 unless $WARN_ABOUT_ENV++;
29 return $self->_set_env(@args);
34 # input position and length
35 has read_length => (is => 'rw');
36 has read_position => (is => 'rw');
38 has _prepared_write => (is => 'rw');
43 writer => '_set_response_cb',
44 clearer => '_clear_response_cb',
45 predicate => '_has_response_cb',
50 isa => duck_type([qw(write close)]),
51 writer => '_set_writer',
52 clearer => '_clear_writer',
55 # Amount of data to read from input on each pass
56 our $CHUNKSIZE = 64 * 1024;
60 Catalyst::Engine - The Catalyst Engine
71 =head2 $self->finalize_body($c)
73 Finalize body. Prints the response output.
78 my ( $self, $c ) = @_;
79 my $body = $c->response->body;
80 no warnings 'uninitialized';
81 if ( blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
84 $got = read $body, my ($buffer), $CHUNKSIZE;
85 $got = 0 unless $self->write( $c, $buffer );
91 $self->write( $c, $body );
94 $self->_writer->close;
101 =head2 $self->finalize_cookies($c)
103 Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
108 sub finalize_cookies {
109 my ( $self, $c ) = @_;
112 my $response = $c->response;
114 foreach my $name (keys %{ $response->cookies }) {
116 my $val = $response->cookies->{$name};
121 : CGI::Simple::Cookie->new(
123 -value => $val->{value},
124 -expires => $val->{expires},
125 -domain => $val->{domain},
126 -path => $val->{path},
127 -secure => $val->{secure} || 0,
128 -httponly => $val->{httponly} || 0,
131 if (!defined $cookie) {
132 $c->log->warn("undef passed in '$name' cookie value - not setting cookie")
137 push @cookies, $cookie->as_string;
140 for my $cookie (@cookies) {
141 $response->headers->push_header( 'Set-Cookie' => $cookie );
145 =head2 $self->finalize_error($c)
147 Output an appropriate error message. Called if there's an error in $c
148 after the dispatch has finished. Will output debug messages if Catalyst
149 is in debug mode, or a `please come back later` message otherwise.
153 sub _dump_error_page_element {
154 my ($self, $i, $element) = @_;
155 my ($name, $val) = @{ $element };
157 # This is fugly, but the metaclass is _HUGE_ and demands waaay too much
158 # scrolling. Suggestions for more pleasant ways to do this welcome.
159 local $val->{'__MOP__'} = "Stringified: "
160 . $val->{'__MOP__'} if ref $val eq 'HASH' && exists $val->{'__MOP__'};
162 my $text = encode_entities( dump( $val ));
163 sprintf <<"EOF", $name, $text;
164 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
166 <pre wrap="">%s</pre>
172 my ( $self, $c ) = @_;
174 $c->res->content_type('text/html; charset=utf-8');
175 my $name = ref($c)->config->{name} || join(' ', split('::', ref $c));
177 # Prevent Catalyst::Plugin::Unicode::Encoding from running.
178 # This is a little nasty, but it's the best way to be clean whether or
179 # not the user has an encoding plugin.
181 if ($c->can('encoding')) {
185 my ( $title, $error, $infos );
189 $error = join '', map {
190 '<p><code class="error">'
191 . encode_entities($_)
194 $error ||= 'No output';
195 $error = qq{<pre wrap="">$error</pre>};
196 $title = $name = "$name on Catalyst $Catalyst::VERSION";
197 $name = "<h1>$name</h1>";
199 # Don't show context in the dump
200 $c->req->_clear_context;
201 $c->res->_clear_context;
203 # Don't show body parser in the dump
204 $c->req->_clear_body;
208 for my $dump ( $c->dump_these ) {
209 push @infos, $self->_dump_error_page_element($i, $dump);
212 $infos = join "\n", @infos;
219 (en) Please come back later
220 (fr) SVP veuillez revenir plus tard
221 (de) Bitte versuchen sie es spaeter nocheinmal
222 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
223 (no) Vennligst prov igjen senere
224 (dk) Venligst prov igen senere
225 (pl) Prosze sprobowac pozniej
226 (pt) Por favor volte mais tarde
227 (ru) Попробуйте еще раз позже
228 (ua) Спробуйте ще раз пізніше
233 $c->res->body( <<"" );
234 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
235 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
236 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
238 <meta http-equiv="Content-Language" content="en" />
239 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
240 <title>$title</title>
241 <script type="text/javascript">
243 function toggleDump (dumpElement) {
244 var e = document.getElementById( dumpElement );
245 if (e.style.display == "none") {
246 e.style.display = "";
249 e.style.display = "none";
254 <style type="text/css">
256 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
257 Tahoma, Arial, helvetica, sans-serif;
259 background-color: #eee;
263 :link, :link:hover, :visited, :visited:hover {
268 background-color: #ccc;
269 border: 1px solid #aaa;
274 background-color: #cce;
275 border: 1px solid #755;
281 background-color: #eee;
282 border: 1px solid #575;
288 background-color: #cce;
289 border: 1px solid #557;
298 div.name h1, div.error p {
306 text-decoration: underline;
312 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
313 /* Browser specific (not valid) styles to make preformatted text wrap */
315 white-space: pre-wrap; /* css-3 */
316 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
317 white-space: -pre-wrap; /* Opera 4-6 */
318 white-space: -o-pre-wrap; /* Opera 7 */
319 word-wrap: break-word; /* Internet Explorer 5.5+ */
325 <div class="error">$error</div>
326 <div class="infos">$infos</div>
327 <div class="name">$name</div>
332 # Trick IE. Old versions of IE would display their own error page instead
333 # of ours if we'd give it less than 512 bytes.
334 $c->res->{body} .= ( ' ' x 512 );
336 $c->res->{body} = Encode::encode("UTF-8", $c->res->{body});
339 $c->res->status(500);
342 =head2 $self->finalize_headers($c)
344 Abstract method, allows engines to write headers to response
348 sub finalize_headers {
349 my ($self, $ctx) = @_;
351 # This is a less-than-pretty hack to avoid breaking the old
352 # Catalyst::Engine::PSGI. 5.9 Catalyst::Engine sets a response_cb and
353 # expects us to pass headers to it here, whereas Catalyst::Enngine::PSGI
354 # just pulls the headers out of $ctx->response in its run method and never
355 # sets response_cb. So take the lack of a response_cb as a sign that we
356 # don't need to set the headers.
358 return unless $self->_has_response_cb;
361 $ctx->response->headers->scan(sub { push @headers, @_ });
363 $self->_set_writer($self->_response_cb->([ $ctx->response->status, \@headers ]));
364 $self->_clear_response_cb;
369 =head2 $self->finalize_read($c)
373 sub finalize_read { }
375 =head2 $self->finalize_uploads($c)
377 Clean up after uploads, deleting temp files.
381 sub finalize_uploads {
382 my ( $self, $c ) = @_;
384 # N.B. This code is theoretically entirely unneeded due to ->cleanup(1)
385 # on the HTTP::Body object.
386 my $request = $c->request;
387 foreach my $key (keys %{ $request->uploads }) {
388 my $upload = $request->uploads->{$key};
389 unlink grep { -e $_ } map { $_->tempname }
390 (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
395 =head2 $self->prepare_body($c)
397 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
402 my ( $self, $c ) = @_;
404 my $appclass = ref($c) || $c;
405 if ( my $length = $self->read_length ) {
406 my $request = $c->request;
407 unless ( $request->_body ) {
408 my $type = $request->header('Content-Type');
409 $request->_body(HTTP::Body->new( $type, $length ));
410 $request->_body->cleanup(1); # Make extra sure!
411 $request->_body->tmpdir( $appclass->config->{uploadtmp} )
412 if exists $appclass->config->{uploadtmp};
415 # Check for definedness as you could read '0'
416 while ( defined ( my $buffer = $self->read($c) ) ) {
417 $c->prepare_body_chunk($buffer);
420 # paranoia against wrong Content-Length header
421 my $remaining = $length - $self->read_position;
422 if ( $remaining > 0 ) {
423 $self->finalize_read($c);
424 Catalyst::Exception->throw(
425 "Wrong Content-Length value: $length" );
429 # Defined but will cause all body code to be skipped
430 $c->request->_body(0);
434 =head2 $self->prepare_body_chunk($c)
436 Add a chunk to the request body.
440 sub prepare_body_chunk {
441 my ( $self, $c, $chunk ) = @_;
443 $c->request->_body->add($chunk);
446 =head2 $self->prepare_body_parameters($c)
448 Sets up parameters from body.
452 sub prepare_body_parameters {
453 my ( $self, $c ) = @_;
455 return unless $c->request->_body;
457 $c->request->body_parameters( $c->request->_body->param );
460 =head2 $self->prepare_connection($c)
462 Abstract method implemented in engines.
466 sub prepare_connection {
467 my ($self, $ctx) = @_;
469 my $env = $self->env;
470 my $request = $ctx->request;
472 $request->address( $env->{REMOTE_ADDR} );
473 $request->hostname( $env->{REMOTE_HOST} )
474 if exists $env->{REMOTE_HOST};
475 $request->protocol( $env->{SERVER_PROTOCOL} );
476 $request->remote_user( $env->{REMOTE_USER} );
477 $request->method( $env->{REQUEST_METHOD} );
478 $request->secure( $env->{'psgi.url_scheme'} eq 'https' ? 1 : 0 );
483 =head2 $self->prepare_cookies($c)
485 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
489 sub prepare_cookies {
490 my ( $self, $c ) = @_;
492 if ( my $header = $c->request->header('Cookie') ) {
493 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
497 =head2 $self->prepare_headers($c)
501 sub prepare_headers {
502 my ($self, $ctx) = @_;
504 my $env = $self->env;
505 my $headers = $ctx->request->headers;
507 for my $header (keys %{ $env }) {
508 next unless $header =~ /^(HTTP|CONTENT|COOKIE)/i;
509 (my $field = $header) =~ s/^HTTPS?_//;
511 $headers->header($field => $env->{$header});
515 =head2 $self->prepare_parameters($c)
517 sets up parameters from query and post parameters.
521 sub prepare_parameters {
522 my ( $self, $c ) = @_;
524 my $request = $c->request;
525 my $parameters = $request->parameters;
526 my $body_parameters = $request->body_parameters;
527 my $query_parameters = $request->query_parameters;
528 # We copy, no references
529 foreach my $name (keys %$query_parameters) {
530 my $param = $query_parameters->{$name};
531 $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
534 # Merge query and body parameters
535 foreach my $name (keys %$body_parameters) {
536 my $param = $body_parameters->{$name};
537 my @values = ref $param eq 'ARRAY' ? @$param : ($param);
538 if ( my $existing = $parameters->{$name} ) {
539 unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
541 $parameters->{$name} = @values > 1 ? \@values : $values[0];
545 =head2 $self->prepare_path($c)
547 abstract method, implemented by engines.
552 my ($self, $ctx) = @_;
554 my $env = $self->env;
556 my $scheme = $ctx->request->secure ? 'https' : 'http';
557 my $host = $env->{HTTP_HOST} || $env->{SERVER_NAME};
558 my $port = $env->{SERVER_PORT} || 80;
559 my $base_path = $env->{SCRIPT_NAME} || "/";
561 # set the request URI
563 if (!$ctx->config->{use_request_uri_for_path}) {
564 my $path_info = $env->{PATH_INFO};
565 if ( exists $env->{REDIRECT_URL} ) {
566 $base_path = $env->{REDIRECT_URL};
567 $base_path =~ s/\Q$path_info\E$//;
569 $path = $base_path . $path_info;
571 $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
572 $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
575 my $req_uri = $env->{REQUEST_URI};
576 $req_uri =~ s/\?.*$//;
581 # Using URI directly is way too slow, so we construct the URLs manually
582 my $uri_class = "URI::$scheme";
584 # HTTP_HOST will include the port even if it's 80/443
585 $host =~ s/:(?:80|443)$//;
587 if ($port !~ /^(?:80|443)$/ && $host !~ /:/) {
591 my $query = $env->{QUERY_STRING} ? '?' . $env->{QUERY_STRING} : '';
592 my $uri = $scheme . '://' . $host . '/' . $path . $query;
594 $ctx->request->uri( (bless \$uri, $uri_class)->canonical );
597 # base must end in a slash
598 $base_path .= '/' unless $base_path =~ m{/$};
600 my $base_uri = $scheme . '://' . $host . $base_path;
602 $ctx->request->base( bless \$base_uri, $uri_class );
607 =head2 $self->prepare_request($c)
609 =head2 $self->prepare_query_parameters($c)
611 process the query string and extract query parameters.
615 sub prepare_query_parameters {
618 my $query_string = exists $self->env->{QUERY_STRING}
619 ? $self->env->{QUERY_STRING}
622 # Check for keywords (no = signs)
623 # (yes, index() is faster than a regex :))
624 if ( index( $query_string, '=' ) < 0 ) {
625 $c->request->query_keywords( $self->unescape_uri($query_string) );
631 # replace semi-colons
632 $query_string =~ s/;/&/g;
634 my @params = grep { length $_ } split /&/, $query_string;
636 for my $item ( @params ) {
639 = map { $self->unescape_uri($_) }
640 split( /=/, $item, 2 );
642 $param = $self->unescape_uri($item) unless defined $param;
644 if ( exists $query{$param} ) {
645 if ( ref $query{$param} ) {
646 push @{ $query{$param} }, $value;
649 $query{$param} = [ $query{$param}, $value ];
653 $query{$param} = $value;
657 $c->request->query_parameters( \%query );
660 =head2 $self->prepare_read($c)
662 prepare to read from the engine.
667 my ( $self, $c ) = @_;
669 # Initialize the read position
670 $self->read_position(0);
672 # Initialize the amount of data we think we need to read
673 $self->read_length( $c->request->header('Content-Length') || 0 );
676 =head2 $self->prepare_request(@arguments)
678 Populate the context object from the request object.
682 sub prepare_request {
683 my ($self, $ctx, %args) = @_;
684 $self->_set_env($args{env});
687 =head2 $self->prepare_uploads($c)
691 sub prepare_uploads {
692 my ( $self, $c ) = @_;
694 my $request = $c->request;
695 return unless $request->_body;
697 my $uploads = $request->_body->upload;
698 my $parameters = $request->parameters;
699 foreach my $name (keys %$uploads) {
700 my $files = $uploads->{$name};
702 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
703 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
704 my $u = Catalyst::Request::Upload->new
706 size => $upload->{size},
707 type => scalar $headers->content_type,
709 tempname => $upload->{tempname},
710 filename => $upload->{filename},
714 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
716 # support access to the filename as a normal param
717 my @filenames = map { $_->{filename} } @uploads;
718 # append, if there's already params with this name
719 if (exists $parameters->{$name}) {
720 if (ref $parameters->{$name} eq 'ARRAY') {
721 push @{ $parameters->{$name} }, @filenames;
724 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
728 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
733 =head2 $self->prepare_write($c)
735 Abstract method. Implemented by the engines.
739 sub prepare_write { }
741 =head2 $self->read($c, [$maxlength])
743 Reads from the input stream by calling C<< $self->read_chunk >>.
745 Maintains the read_length and read_position counters as data is read.
750 my ( $self, $c, $maxlength ) = @_;
752 my $remaining = $self->read_length - $self->read_position;
753 $maxlength ||= $CHUNKSIZE;
755 # Are we done reading?
756 if ( $remaining <= 0 ) {
757 $self->finalize_read($c);
761 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
762 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
764 if (0 == $rc) { # Nothing more to read even though Content-Length
765 # said there should be.
766 $self->finalize_read;
769 $self->read_position( $self->read_position + $rc );
773 Catalyst::Exception->throw(
774 message => "Unknown error reading input: $!" );
778 =head2 $self->read_chunk($c, $buffer, $length)
780 Each engine implements read_chunk as its preferred way of reading a chunk
781 of data. Returns the number of bytes read. A return of 0 indicates that
782 there is no more data to be read.
787 my ($self, $ctx) = (shift, shift);
788 return $self->env->{'psgi.input'}->read(@_);
791 =head2 $self->read_length
793 The length of input data to be read. This is obtained from the Content-Length
796 =head2 $self->read_position
798 The amount of input data that has already been read.
800 =head2 $self->run($app, $server)
802 Start the engine. Builds a PSGI application and calls the
803 run method on the server passed in, which then causes the
804 engine to loop, handling requests..
809 my ($self, $app, $psgi, @args) = @_;
810 # @args left here rather than just a $options, $server for back compat with the
811 # old style scripts which send a few args, then a hashref
813 # They should never actually be used in the normal case as the Plack engine is
814 # passed in got all the 'standard' args via the loader in the script already.
816 # FIXME - we should stash the options in an attribute so that custom args
817 # like Gitalist's --git_dir are possible to get from the app without stupid tricks.
818 my $server = pop @args if (scalar @args && blessed $args[-1]);
819 my $options = pop @args if (scalar @args && ref($args[-1]) eq 'HASH');
820 # Back compat hack for applications with old (non Catalyst::Script) scripts to work in FCGI.
821 if (scalar @args && !ref($args[0])) {
822 if (my $listen = shift @args) {
823 $options->{listen} ||= [$listen];
827 $server = Catalyst::EngineLoader->new(application_name => ref($self))->auto(%$options);
828 # We're not being called from a script, so auto detect what backend to
829 # run on. This should never happen, as mod_perl never calls ->run,
830 # instead the $app->handle method is called per request.
831 $app->log->warn("Not supplied a Plack engine, falling back to engine auto-loader (are your scripts ancient?)")
833 $server->run($psgi, $options);
836 =head2 build_psgi_app ($app, @args)
838 Builds and returns a PSGI application closure, wrapping it in the reverse proxy
839 middleware if the using_frontend_proxy config setting is set.
844 my ($self, $app, @args) = @_;
851 $self->_set_response_cb($respond);
852 $app->handle_request(env => $env);
857 =head2 $self->write($c, $buffer)
859 Writes the buffer to the client.
864 my ( $self, $c, $buffer ) = @_;
866 unless ( $self->_prepared_write ) {
867 $self->prepare_write($c);
868 $self->_prepared_write(1);
871 $buffer = q[] unless defined $buffer;
873 my $len = length($buffer);
874 $self->_writer->write($buffer);
879 =head2 $self->unescape_uri($uri)
881 Unescapes a given URI using the most efficient method available. Engines such
882 as Apache may implement this using Apache's C-based modules, for example.
887 my ( $self, $str ) = @_;
889 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
894 =head2 $self->finalize_output
896 <obsolete>, see finalize_body
900 Hash containing environment variables including many special variables inserted
901 by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
903 Before accessing environment variables consider whether the same information is
904 not directly available via Catalyst objects $c->request, $c->engine ...
906 BEWARE: If you really need to access some environment variable from your Catalyst
907 application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
908 as in some environments the %ENV hash does not contain what you would expect.
912 Catalyst Contributors, see Catalyst.pm
916 This library is free software. You can redistribute it and/or modify it under
917 the same terms as Perl itself.