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;
16 use namespace::clean -except => 'meta';
18 has env => (is => 'ro', writer => '_set_env', clearer => '_clear_env');
20 # input position and length
21 has read_length => (is => 'rw');
22 has read_position => (is => 'rw');
24 has _prepared_write => (is => 'rw');
29 writer => '_set_response_cb',
30 clearer => '_clear_response_cb',
35 isa => duck_type([qw(write close)]),
36 writer => '_set_writer',
37 clearer => '_clear_writer',
40 # Amount of data to read from input on each pass
41 our $CHUNKSIZE = 64 * 1024;
45 Catalyst::Engine - The Catalyst Engine
56 =head2 $self->finalize_body($c)
58 Finalize body. Prints the response output.
63 my ( $self, $c ) = @_;
64 my $body = $c->response->body;
65 no warnings 'uninitialized';
66 if ( blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
69 $got = read $body, my ($buffer), $CHUNKSIZE;
70 $got = 0 unless $self->write( $c, $buffer );
76 $self->write( $c, $body );
79 $self->_writer->close;
86 =head2 $self->finalize_cookies($c)
88 Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
93 sub finalize_cookies {
94 my ( $self, $c ) = @_;
97 my $response = $c->response;
99 foreach my $name (keys %{ $response->cookies }) {
101 my $val = $response->cookies->{$name};
106 : CGI::Simple::Cookie->new(
108 -value => $val->{value},
109 -expires => $val->{expires},
110 -domain => $val->{domain},
111 -path => $val->{path},
112 -secure => $val->{secure} || 0,
113 -httponly => $val->{httponly} || 0,
117 push @cookies, $cookie->as_string;
120 for my $cookie (@cookies) {
121 $response->headers->push_header( 'Set-Cookie' => $cookie );
125 =head2 $self->finalize_error($c)
127 Output an appropriate error message. Called if there's an error in $c
128 after the dispatch has finished. Will output debug messages if Catalyst
129 is in debug mode, or a `please come back later` message otherwise.
133 sub _dump_error_page_element {
134 my ($self, $i, $element) = @_;
135 my ($name, $val) = @{ $element };
137 # This is fugly, but the metaclass is _HUGE_ and demands waaay too much
138 # scrolling. Suggestions for more pleasant ways to do this welcome.
139 local $val->{'__MOP__'} = "Stringified: "
140 . $val->{'__MOP__'} if ref $val eq 'HASH' && exists $val->{'__MOP__'};
142 my $text = encode_entities( dump( $val ));
143 sprintf <<"EOF", $name, $text;
144 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
146 <pre wrap="">%s</pre>
152 my ( $self, $c ) = @_;
154 $c->res->content_type('text/html; charset=utf-8');
155 my $name = ref($c)->config->{name} || join(' ', split('::', ref $c));
157 my ( $title, $error, $infos );
161 $error = join '', map {
162 '<p><code class="error">'
163 . encode_entities($_)
166 $error ||= 'No output';
167 $error = qq{<pre wrap="">$error</pre>};
168 $title = $name = "$name on Catalyst $Catalyst::VERSION";
169 $name = "<h1>$name</h1>";
171 # Don't show context in the dump
172 $c->req->_clear_context;
173 $c->res->_clear_context;
175 # Don't show body parser in the dump
176 $c->req->_clear_body;
180 for my $dump ( $c->dump_these ) {
181 push @infos, $self->_dump_error_page_element($i, $dump);
184 $infos = join "\n", @infos;
191 (en) Please come back later
192 (fr) SVP veuillez revenir plus tard
193 (de) Bitte versuchen sie es spaeter nocheinmal
194 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
195 (no) Vennligst prov igjen senere
196 (dk) Venligst prov igen senere
197 (pl) Prosze sprobowac pozniej
198 (pt) Por favor volte mais tarde
199 (ru) Попробуйте еще раз позже
200 (ua) Спробуйте ще раз пізніше
205 $c->res->body( <<"" );
206 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
207 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
208 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
210 <meta http-equiv="Content-Language" content="en" />
211 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
212 <title>$title</title>
213 <script type="text/javascript">
215 function toggleDump (dumpElement) {
216 var e = document.getElementById( dumpElement );
217 if (e.style.display == "none") {
218 e.style.display = "";
221 e.style.display = "none";
226 <style type="text/css">
228 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
229 Tahoma, Arial, helvetica, sans-serif;
231 background-color: #eee;
235 :link, :link:hover, :visited, :visited:hover {
240 background-color: #ccc;
241 border: 1px solid #aaa;
246 background-color: #cce;
247 border: 1px solid #755;
253 background-color: #eee;
254 border: 1px solid #575;
260 background-color: #cce;
261 border: 1px solid #557;
270 div.name h1, div.error p {
278 text-decoration: underline;
284 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
285 /* Browser specific (not valid) styles to make preformatted text wrap */
287 white-space: pre-wrap; /* css-3 */
288 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
289 white-space: -pre-wrap; /* Opera 4-6 */
290 white-space: -o-pre-wrap; /* Opera 7 */
291 word-wrap: break-word; /* Internet Explorer 5.5+ */
297 <div class="error">$error</div>
298 <div class="infos">$infos</div>
299 <div class="name">$name</div>
306 $c->res->{body} .= ( ' ' x 512 );
309 $c->res->status(500);
312 =head2 $self->finalize_headers($c)
314 Abstract method, allows engines to write headers to response
318 sub finalize_headers {
319 my ($self, $ctx) = @_;
322 $ctx->response->headers->scan(sub { push @headers, @_ });
324 $self->_set_writer($self->_response_cb->([ $ctx->response->status, \@headers ]));
325 $self->_clear_response_cb;
330 =head2 $self->finalize_read($c)
334 sub finalize_read { }
336 =head2 $self->finalize_uploads($c)
338 Clean up after uploads, deleting temp files.
342 sub finalize_uploads {
343 my ( $self, $c ) = @_;
345 my $request = $c->request;
346 foreach my $key (keys %{ $request->uploads }) {
347 my $upload = $request->uploads->{$key};
348 unlink grep { -e $_ } map { $_->tempname }
349 (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
354 =head2 $self->prepare_body($c)
356 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
361 my ( $self, $c ) = @_;
363 my $appclass = ref($c) || $c;
364 if ( my $length = $self->read_length ) {
365 my $request = $c->request;
366 unless ( $request->_body ) {
367 my $type = $request->header('Content-Type');
368 $request->_body(HTTP::Body->new( $type, $length ));
369 $request->_body->tmpdir( $appclass->config->{uploadtmp} )
370 if exists $appclass->config->{uploadtmp};
373 # Check for definedness as you could read '0'
374 while ( defined ( my $buffer = $self->read($c) ) ) {
375 $c->prepare_body_chunk($buffer);
378 # paranoia against wrong Content-Length header
379 my $remaining = $length - $self->read_position;
380 if ( $remaining > 0 ) {
381 $self->finalize_read($c);
382 Catalyst::Exception->throw(
383 "Wrong Content-Length value: $length" );
387 # Defined but will cause all body code to be skipped
388 $c->request->_body(0);
392 =head2 $self->prepare_body_chunk($c)
394 Add a chunk to the request body.
398 sub prepare_body_chunk {
399 my ( $self, $c, $chunk ) = @_;
401 $c->request->_body->add($chunk);
404 =head2 $self->prepare_body_parameters($c)
406 Sets up parameters from body.
410 sub prepare_body_parameters {
411 my ( $self, $c ) = @_;
413 return unless $c->request->_body;
415 $c->request->body_parameters( $c->request->_body->param );
418 =head2 $self->prepare_connection($c)
420 Abstract method implemented in engines.
424 sub prepare_connection {
425 my ($self, $ctx) = @_;
427 my $env = $self->env;
428 my $request = $ctx->request;
430 $request->address( $env->{REMOTE_ADDR} );
431 $request->hostname( $env->{REMOTE_HOST} )
432 if exists $env->{REMOTE_HOST};
433 $request->protocol( $env->{SERVER_PROTOCOL} );
434 $request->remote_user( $env->{REMOTE_USER} );
435 $request->method( $env->{REQUEST_METHOD} );
436 $request->secure( $env->{'psgi.url_scheme'} eq 'https' ? 1 : 0 );
441 =head2 $self->prepare_cookies($c)
443 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
447 sub prepare_cookies {
448 my ( $self, $c ) = @_;
450 if ( my $header = $c->request->header('Cookie') ) {
451 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
455 =head2 $self->prepare_headers($c)
459 sub prepare_headers {
460 my ($self, $ctx) = @_;
462 my $env = $self->env;
463 my $headers = $ctx->request->headers;
465 for my $header (keys %{ $env }) {
466 next unless $header =~ /^(HTTP|CONTENT|COOKIE)/i;
467 (my $field = $header) =~ s/^HTTPS?_//;
469 $headers->header($field => $env->{$header});
473 =head2 $self->prepare_parameters($c)
475 sets up parameters from query and post parameters.
479 sub prepare_parameters {
480 my ( $self, $c ) = @_;
482 my $request = $c->request;
483 my $parameters = $request->parameters;
484 my $body_parameters = $request->body_parameters;
485 my $query_parameters = $request->query_parameters;
486 # We copy, no references
487 foreach my $name (keys %$query_parameters) {
488 my $param = $query_parameters->{$name};
489 $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
492 # Merge query and body parameters
493 foreach my $name (keys %$body_parameters) {
494 my $param = $body_parameters->{$name};
495 my @values = ref $param eq 'ARRAY' ? @$param : ($param);
496 if ( my $existing = $parameters->{$name} ) {
497 unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
499 $parameters->{$name} = @values > 1 ? \@values : $values[0];
503 =head2 $self->prepare_path($c)
505 abstract method, implemented by engines.
510 my ($self, $ctx) = @_;
512 my $env = $self->env;
514 my $scheme = $ctx->request->secure ? 'https' : 'http';
515 my $host = $env->{HTTP_HOST} || $env->{SERVER_NAME};
516 my $port = $env->{SERVER_PORT} || 80;
517 my $base_path = $env->{SCRIPT_NAME} || "/";
519 # set the request URI
520 my $req_uri = $env->{REQUEST_URI};
521 $req_uri =~ s/\?.*$//;
525 # Using URI directly is way too slow, so we construct the URLs manually
526 my $uri_class = "URI::$scheme";
528 # HTTP_HOST will include the port even if it's 80/443
529 $host =~ s/:(?:80|443)$//;
531 if ($port !~ /^(?:80|443)$/ && $host !~ /:/) {
535 my $query = $env->{QUERY_STRING} ? '?' . $env->{QUERY_STRING} : '';
536 my $uri = $scheme . '://' . $host . '/' . $path . $query;
538 $ctx->request->uri( bless \$uri, $uri_class );
541 # base must end in a slash
542 $base_path .= '/' unless $base_path =~ m{/$};
544 my $base_uri = $scheme . '://' . $host . $base_path;
546 $ctx->request->base( bless \$base_uri, $uri_class );
551 =head2 $self->prepare_request($c)
553 =head2 $self->prepare_query_parameters($c)
555 process the query string and extract query parameters.
559 sub prepare_query_parameters {
562 my $query_string = exists $self->env->{QUERY_STRING}
563 ? $self->env->{QUERY_STRING}
566 # Check for keywords (no = signs)
567 # (yes, index() is faster than a regex :))
568 if ( index( $query_string, '=' ) < 0 ) {
569 $c->request->query_keywords( $self->unescape_uri($query_string) );
575 # replace semi-colons
576 $query_string =~ s/;/&/g;
578 my @params = grep { length $_ } split /&/, $query_string;
580 for my $item ( @params ) {
583 = map { $self->unescape_uri($_) }
584 split( /=/, $item, 2 );
586 $param = $self->unescape_uri($item) unless defined $param;
588 if ( exists $query{$param} ) {
589 if ( ref $query{$param} ) {
590 push @{ $query{$param} }, $value;
593 $query{$param} = [ $query{$param}, $value ];
597 $query{$param} = $value;
601 $c->request->query_parameters( \%query );
604 =head2 $self->prepare_read($c)
606 prepare to read from the engine.
611 my ( $self, $c ) = @_;
613 # Initialize the read position
614 $self->read_position(0);
616 # Initialize the amount of data we think we need to read
617 $self->read_length( $c->request->header('Content-Length') || 0 );
620 =head2 $self->prepare_request(@arguments)
622 Populate the context object from the request object.
626 sub prepare_request {
627 my ($self, $ctx, %args) = @_;
628 $self->_set_env($args{env});
631 =head2 $self->prepare_uploads($c)
635 sub prepare_uploads {
636 my ( $self, $c ) = @_;
638 my $request = $c->request;
639 return unless $request->_body;
641 my $uploads = $request->_body->upload;
642 my $parameters = $request->parameters;
643 foreach my $name (keys %$uploads) {
644 my $files = $uploads->{$name};
646 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
647 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
648 my $u = Catalyst::Request::Upload->new
650 size => $upload->{size},
651 type => $headers->content_type,
653 tempname => $upload->{tempname},
654 filename => $upload->{filename},
658 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
660 # support access to the filename as a normal param
661 my @filenames = map { $_->{filename} } @uploads;
662 # append, if there's already params with this name
663 if (exists $parameters->{$name}) {
664 if (ref $parameters->{$name} eq 'ARRAY') {
665 push @{ $parameters->{$name} }, @filenames;
668 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
672 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
677 =head2 $self->prepare_write($c)
679 Abstract method. Implemented by the engines.
683 sub prepare_write { }
685 =head2 $self->read($c, [$maxlength])
687 Reads from the input stream by calling C<< $self->read_chunk >>.
689 Maintains the read_length and read_position counters as data is read.
694 my ( $self, $c, $maxlength ) = @_;
696 my $remaining = $self->read_length - $self->read_position;
697 $maxlength ||= $CHUNKSIZE;
699 # Are we done reading?
700 if ( $remaining <= 0 ) {
701 $self->finalize_read($c);
705 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
706 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
708 if (0 == $rc) { # Nothing more to read even though Content-Length
709 # said there should be.
710 $self->finalize_read;
713 $self->read_position( $self->read_position + $rc );
717 Catalyst::Exception->throw(
718 message => "Unknown error reading input: $!" );
722 =head2 $self->read_chunk($c, $buffer, $length)
724 Each engine implements read_chunk as its preferred way of reading a chunk
725 of data. Returns the number of bytes read. A return of 0 indicates that
726 there is no more data to be read.
731 my ($self, $ctx) = (shift, shift);
732 return $self->env->{'psgi.input'}->read(@_);
735 =head2 $self->read_length
737 The length of input data to be read. This is obtained from the Content-Length
740 =head2 $self->read_position
742 The amount of input data that has already been read.
744 =head2 $self->run($c)
746 Start the engine. Implemented by the various engine classes.
751 my ($self, $app, @args) = @_;
753 # FIXME - Do something sensible with the options we're passed
754 $self->_run_psgi_app($self->_build_psgi_app($app, @args), @args);
757 sub _build_psgi_app {
758 my ($self, $app, @args) = @_;
764 $self->_set_response_cb($respond);
765 $app->handle_request(env => $env);
771 my ($self, $psgi_app, @args);
772 # FIXME - Need to be able to specify engine and pass options..
773 Plack::Loader->auto()->run($psgi_app);
776 =head2 $self->write($c, $buffer)
778 Writes the buffer to the client.
783 my ( $self, $c, $buffer ) = @_;
785 unless ( $self->_prepared_write ) {
786 $self->prepare_write($c);
787 $self->_prepared_write(1);
790 return 0 if !defined $buffer;
792 my $len = length($buffer);
793 $self->_writer->write($buffer);
798 =head2 $self->unescape_uri($uri)
800 Unescapes a given URI using the most efficient method available. Engines such
801 as Apache may implement this using Apache's C-based modules, for example.
806 my ( $self, $str ) = @_;
808 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
813 =head2 $self->finalize_output
815 <obsolete>, see finalize_body
819 Hash containing enviroment variables including many special variables inserted
820 by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
822 Before accesing enviroment variables consider whether the same information is
823 not directly available via Catalyst objects $c->request, $c->engine ...
825 BEWARE: If you really need to access some enviroment variable from your Catalyst
826 application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
827 as in some enviroments the %ENV hash does not contain what you would expect.
831 Catalyst Contributors, see Catalyst.pm
835 This library is free software. You can redistribute it and/or modify it under
836 the same terms as Perl itself.