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 namespace::clean -except => 'meta';
17 has env => (is => 'ro', writer => '_set_env', clearer => '_clear_env');
19 # input position and length
20 has read_length => (is => 'rw');
21 has read_position => (is => 'rw');
23 has _prepared_write => (is => 'rw');
28 writer => '_set_response_cb',
29 clearer => '_clear_response_cb',
34 isa => duck_type([qw(write close)]),
35 writer => '_set_writer',
36 clearer => '_clear_writer',
39 # Amount of data to read from input on each pass
40 our $CHUNKSIZE = 64 * 1024;
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 $self->_writer->close;
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,
116 push @cookies, $cookie->as_string;
119 for my $cookie (@cookies) {
120 $response->headers->push_header( 'Set-Cookie' => $cookie );
124 =head2 $self->finalize_error($c)
126 Output an appropriate error message. Called if there's an error in $c
127 after the dispatch has finished. Will output debug messages if Catalyst
128 is in debug mode, or a `please come back later` message otherwise.
132 sub _dump_error_page_element {
133 my ($self, $i, $element) = @_;
134 my ($name, $val) = @{ $element };
136 # This is fugly, but the metaclass is _HUGE_ and demands waaay too much
137 # scrolling. Suggestions for more pleasant ways to do this welcome.
138 local $val->{'__MOP__'} = "Stringified: "
139 . $val->{'__MOP__'} if ref $val eq 'HASH' && exists $val->{'__MOP__'};
141 my $text = encode_entities( dump( $val ));
142 sprintf <<"EOF", $name, $text;
143 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
145 <pre wrap="">%s</pre>
151 my ( $self, $c ) = @_;
153 $c->res->content_type('text/html; charset=utf-8');
154 my $name = ref($c)->config->{name} || join(' ', split('::', ref $c));
156 my ( $title, $error, $infos );
160 $error = join '', map {
161 '<p><code class="error">'
162 . encode_entities($_)
165 $error ||= 'No output';
166 $error = qq{<pre wrap="">$error</pre>};
167 $title = $name = "$name on Catalyst $Catalyst::VERSION";
168 $name = "<h1>$name</h1>";
170 # Don't show context in the dump
171 $c->req->_clear_context;
172 $c->res->_clear_context;
174 # Don't show body parser in the dump
175 $c->req->_clear_body;
179 for my $dump ( $c->dump_these ) {
180 push @infos, $self->_dump_error_page_element($i, $dump);
183 $infos = join "\n", @infos;
190 (en) Please come back later
191 (fr) SVP veuillez revenir plus tard
192 (de) Bitte versuchen sie es spaeter nocheinmal
193 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
194 (no) Vennligst prov igjen senere
195 (dk) Venligst prov igen senere
196 (pl) Prosze sprobowac pozniej
197 (pt) Por favor volte mais tarde
198 (ru) Попробуйте еще раз позже
199 (ua) Спробуйте ще раз пізніше
204 $c->res->body( <<"" );
205 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
206 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
207 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
209 <meta http-equiv="Content-Language" content="en" />
210 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
211 <title>$title</title>
212 <script type="text/javascript">
214 function toggleDump (dumpElement) {
215 var e = document.getElementById( dumpElement );
216 if (e.style.display == "none") {
217 e.style.display = "";
220 e.style.display = "none";
225 <style type="text/css">
227 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
228 Tahoma, Arial, helvetica, sans-serif;
230 background-color: #eee;
234 :link, :link:hover, :visited, :visited:hover {
239 background-color: #ccc;
240 border: 1px solid #aaa;
245 background-color: #cce;
246 border: 1px solid #755;
252 background-color: #eee;
253 border: 1px solid #575;
259 background-color: #cce;
260 border: 1px solid #557;
269 div.name h1, div.error p {
277 text-decoration: underline;
283 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
284 /* Browser specific (not valid) styles to make preformatted text wrap */
286 white-space: pre-wrap; /* css-3 */
287 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
288 white-space: -pre-wrap; /* Opera 4-6 */
289 white-space: -o-pre-wrap; /* Opera 7 */
290 word-wrap: break-word; /* Internet Explorer 5.5+ */
296 <div class="error">$error</div>
297 <div class="infos">$infos</div>
298 <div class="name">$name</div>
305 $c->res->{body} .= ( ' ' x 512 );
308 $c->res->status(500);
311 =head2 $self->finalize_headers($c)
313 Abstract method, allows engines to write headers to response
317 sub finalize_headers {
318 my ($self, $ctx) = @_;
321 $ctx->response->headers->scan(sub { push @headers, @_ });
323 $self->_set_writer($self->_response_cb->([ $ctx->response->status, \@headers ]));
324 $self->_clear_response_cb;
329 =head2 $self->finalize_read($c)
333 sub finalize_read { }
335 =head2 $self->finalize_uploads($c)
337 Clean up after uploads, deleting temp files.
341 sub finalize_uploads {
342 my ( $self, $c ) = @_;
344 my $request = $c->request;
345 foreach my $key (keys %{ $request->uploads }) {
346 my $upload = $request->uploads->{$key};
347 unlink grep { -e $_ } map { $_->tempname }
348 (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
353 =head2 $self->prepare_body($c)
355 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
360 my ( $self, $c ) = @_;
362 my $appclass = ref($c) || $c;
363 if ( my $length = $self->read_length ) {
364 my $request = $c->request;
365 unless ( $request->_body ) {
366 my $type = $request->header('Content-Type');
367 $request->_body(HTTP::Body->new( $type, $length ));
368 $request->_body->tmpdir( $appclass->config->{uploadtmp} )
369 if exists $appclass->config->{uploadtmp};
372 # Check for definedness as you could read '0'
373 while ( defined ( my $buffer = $self->read($c) ) ) {
374 $c->prepare_body_chunk($buffer);
377 # paranoia against wrong Content-Length header
378 my $remaining = $length - $self->read_position;
379 if ( $remaining > 0 ) {
380 $self->finalize_read($c);
381 Catalyst::Exception->throw(
382 "Wrong Content-Length value: $length" );
386 # Defined but will cause all body code to be skipped
387 $c->request->_body(0);
391 =head2 $self->prepare_body_chunk($c)
393 Add a chunk to the request body.
397 sub prepare_body_chunk {
398 my ( $self, $c, $chunk ) = @_;
400 $c->request->_body->add($chunk);
403 =head2 $self->prepare_body_parameters($c)
405 Sets up parameters from body.
409 sub prepare_body_parameters {
410 my ( $self, $c ) = @_;
412 return unless $c->request->_body;
414 $c->request->body_parameters( $c->request->_body->param );
417 =head2 $self->prepare_connection($c)
419 Abstract method implemented in engines.
423 sub prepare_connection {
424 my ($self, $ctx) = @_;
426 my $env = $self->env;
427 my $request = $ctx->request;
429 $request->address( $env->{REMOTE_ADDR} );
430 $request->hostname( $env->{REMOTE_HOST} )
431 if exists $env->{REMOTE_HOST};
432 $request->protocol( $env->{SERVER_PROTOCOL} );
433 $request->remote_user( $env->{REMOTE_USER} );
434 $request->method( $env->{REQUEST_METHOD} );
435 $request->secure( $env->{'psgi.url_scheme'} eq 'https' ? 1 : 0 );
440 =head2 $self->prepare_cookies($c)
442 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
446 sub prepare_cookies {
447 my ( $self, $c ) = @_;
449 if ( my $header = $c->request->header('Cookie') ) {
450 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
454 =head2 $self->prepare_headers($c)
458 sub prepare_headers {
459 my ($self, $ctx) = @_;
461 my $env = $self->env;
462 my $headers = $ctx->request->headers;
464 for my $header (keys %{ $env }) {
465 next unless $header =~ /^(HTTP|CONTENT|COOKIE)/i;
466 (my $field = $header) =~ s/^HTTPS?_//;
468 $headers->header($field => $env->{$header});
472 =head2 $self->prepare_parameters($c)
474 sets up parameters from query and post parameters.
478 sub prepare_parameters {
479 my ( $self, $c ) = @_;
481 my $request = $c->request;
482 my $parameters = $request->parameters;
483 my $body_parameters = $request->body_parameters;
484 my $query_parameters = $request->query_parameters;
485 # We copy, no references
486 foreach my $name (keys %$query_parameters) {
487 my $param = $query_parameters->{$name};
488 $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
491 # Merge query and body parameters
492 foreach my $name (keys %$body_parameters) {
493 my $param = $body_parameters->{$name};
494 my @values = ref $param eq 'ARRAY' ? @$param : ($param);
495 if ( my $existing = $parameters->{$name} ) {
496 unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
498 $parameters->{$name} = @values > 1 ? \@values : $values[0];
502 =head2 $self->prepare_path($c)
504 abstract method, implemented by engines.
509 my ($self, $ctx) = @_;
511 my $env = $self->env;
513 my $scheme = $ctx->request->secure ? 'https' : 'http';
514 my $host = $env->{HTTP_HOST} || $env->{SERVER_NAME};
515 my $port = $env->{SERVER_PORT} || 80;
516 my $base_path = $env->{SCRIPT_NAME} || "/";
518 # set the request URI
519 my $req_uri = $env->{REQUEST_URI};
520 $req_uri =~ s/\?.*$//;
524 # Using URI directly is way too slow, so we construct the URLs manually
525 my $uri_class = "URI::$scheme";
527 # HTTP_HOST will include the port even if it's 80/443
528 $host =~ s/:(?:80|443)$//;
530 if ($port !~ /^(?:80|443)$/ && $host !~ /:/) {
534 my $query = $env->{QUERY_STRING} ? '?' . $env->{QUERY_STRING} : '';
535 my $uri = $scheme . '://' . $host . '/' . $path . $query;
537 $ctx->request->uri( bless \$uri, $uri_class );
540 # base must end in a slash
541 $base_path .= '/' unless $base_path =~ m{/$};
543 my $base_uri = $scheme . '://' . $host . $base_path;
545 $ctx->request->base( bless \$base_uri, $uri_class );
550 =head2 $self->prepare_request($c)
552 =head2 $self->prepare_query_parameters($c)
554 process the query string and extract query parameters.
558 sub prepare_query_parameters {
561 my $query_string = exists $self->env->{QUERY_STRING}
562 ? $self->env->{QUERY_STRING}
565 # Check for keywords (no = signs)
566 # (yes, index() is faster than a regex :))
567 if ( index( $query_string, '=' ) < 0 ) {
568 $c->request->query_keywords( $self->unescape_uri($query_string) );
574 # replace semi-colons
575 $query_string =~ s/;/&/g;
577 my @params = grep { length $_ } split /&/, $query_string;
579 for my $item ( @params ) {
582 = map { $self->unescape_uri($_) }
583 split( /=/, $item, 2 );
585 $param = $self->unescape_uri($item) unless defined $param;
587 if ( exists $query{$param} ) {
588 if ( ref $query{$param} ) {
589 push @{ $query{$param} }, $value;
592 $query{$param} = [ $query{$param}, $value ];
596 $query{$param} = $value;
600 $c->request->query_parameters( \%query );
603 =head2 $self->prepare_read($c)
605 prepare to read from the engine.
610 my ( $self, $c ) = @_;
612 # Initialize the read position
613 $self->read_position(0);
615 # Initialize the amount of data we think we need to read
616 $self->read_length( $c->request->header('Content-Length') || 0 );
619 =head2 $self->prepare_request(@arguments)
621 Populate the context object from the request object.
625 sub prepare_request {
626 my ($self, $ctx, %args) = @_;
627 $self->_set_env($args{env});
630 =head2 $self->prepare_uploads($c)
634 sub prepare_uploads {
635 my ( $self, $c ) = @_;
637 my $request = $c->request;
638 return unless $request->_body;
640 my $uploads = $request->_body->upload;
641 my $parameters = $request->parameters;
642 foreach my $name (keys %$uploads) {
643 my $files = $uploads->{$name};
645 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
646 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
647 my $u = Catalyst::Request::Upload->new
649 size => $upload->{size},
650 type => $headers->content_type,
652 tempname => $upload->{tempname},
653 filename => $upload->{filename},
657 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
659 # support access to the filename as a normal param
660 my @filenames = map { $_->{filename} } @uploads;
661 # append, if there's already params with this name
662 if (exists $parameters->{$name}) {
663 if (ref $parameters->{$name} eq 'ARRAY') {
664 push @{ $parameters->{$name} }, @filenames;
667 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
671 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
676 =head2 $self->prepare_write($c)
678 Abstract method. Implemented by the engines.
682 sub prepare_write { }
684 =head2 $self->read($c, [$maxlength])
686 Reads from the input stream by calling C<< $self->read_chunk >>.
688 Maintains the read_length and read_position counters as data is read.
693 my ( $self, $c, $maxlength ) = @_;
695 my $remaining = $self->read_length - $self->read_position;
696 $maxlength ||= $CHUNKSIZE;
698 # Are we done reading?
699 if ( $remaining <= 0 ) {
700 $self->finalize_read($c);
704 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
705 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
707 if (0 == $rc) { # Nothing more to read even though Content-Length
708 # said there should be.
709 $self->finalize_read;
712 $self->read_position( $self->read_position + $rc );
716 Catalyst::Exception->throw(
717 message => "Unknown error reading input: $!" );
721 =head2 $self->read_chunk($c, $buffer, $length)
723 Each engine implements read_chunk as its preferred way of reading a chunk
724 of data. Returns the number of bytes read. A return of 0 indicates that
725 there is no more data to be read.
730 my ($self, $ctx) = (shift, shift);
731 return $self->env->{'psgi.input'}->read(@_);
734 =head2 $self->read_length
736 The length of input data to be read. This is obtained from the Content-Length
739 =head2 $self->read_position
741 The amount of input data that has already been read.
743 =head2 $self->run($c)
745 Start the engine. Implemented by the various engine classes.
750 my ($self, $app) = @_;
757 $self->_set_response_cb($respond);
758 $app->handle_request(env => $env);
763 =head2 $self->write($c, $buffer)
765 Writes the buffer to the client.
770 my ( $self, $c, $buffer ) = @_;
772 unless ( $self->_prepared_write ) {
773 $self->prepare_write($c);
774 $self->_prepared_write(1);
777 return 0 if !defined $buffer;
779 my $len = length($buffer);
780 $self->_writer->write($buffer);
785 =head2 $self->unescape_uri($uri)
787 Unescapes a given URI using the most efficient method available. Engines such
788 as Apache may implement this using Apache's C-based modules, for example.
793 my ( $self, $str ) = @_;
795 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
800 =head2 $self->finalize_output
802 <obsolete>, see finalize_body
806 Hash containing enviroment variables including many special variables inserted
807 by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
809 Before accesing enviroment variables consider whether the same information is
810 not directly available via Catalyst objects $c->request, $c->engine ...
812 BEWARE: If you really need to access some enviroment variable from your Catalyst
813 application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
814 as in some enviroments the %ENV hash does not contain what you would expect.
818 Catalyst Contributors, see Catalyst.pm
822 This library is free software. You can redistribute it and/or modify it under
823 the same terms as Perl itself.