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 namespace::clean -except => 'meta';
16 has env => (is => 'rw');
18 # input position and length
19 has read_length => (is => 'rw');
20 has read_position => (is => 'rw');
22 has _prepared_write => (is => 'rw');
24 # Amount of data to read from input on each pass
25 our $CHUNKSIZE = 64 * 1024;
29 Catalyst::Engine - The Catalyst Engine
40 =head2 $self->finalize_body($c)
42 Finalize body. Prints the response output.
47 my ( $self, $c ) = @_;
48 my $body = $c->response->body;
49 no warnings 'uninitialized';
50 if ( blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
51 while ( !eof $body ) {
52 read $body, my ($buffer), $CHUNKSIZE;
53 last unless $self->write( $c, $buffer );
58 $self->write( $c, $body );
62 =head2 $self->finalize_cookies($c)
64 Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
69 sub finalize_cookies {
70 my ( $self, $c ) = @_;
73 my $response = $c->response;
75 foreach my $name (keys %{ $response->cookies }) {
77 my $val = $response->cookies->{$name};
82 : CGI::Simple::Cookie->new(
84 -value => $val->{value},
85 -expires => $val->{expires},
86 -domain => $val->{domain},
87 -path => $val->{path},
88 -secure => $val->{secure} || 0,
89 -httponly => $val->{httponly} || 0,
93 push @cookies, $cookie->as_string;
96 for my $cookie (@cookies) {
97 $response->headers->push_header( 'Set-Cookie' => $cookie );
101 =head2 $self->finalize_error($c)
103 Output an appropriate error message. Called if there's an error in $c
104 after the dispatch has finished. Will output debug messages if Catalyst
105 is in debug mode, or a `please come back later` message otherwise.
110 my ( $self, $c ) = @_;
112 $c->res->content_type('text/html; charset=utf-8');
113 my $name = $c->config->{name} || join(' ', split('::', ref $c));
115 my ( $title, $error, $infos );
119 $error = join '', map {
120 '<p><code class="error">'
121 . encode_entities($_)
124 $error ||= 'No output';
125 $error = qq{<pre wrap="">$error</pre>};
126 $title = $name = "$name on Catalyst $Catalyst::VERSION";
127 $name = "<h1>$name</h1>";
129 # Don't show context in the dump
130 $c->req->_clear_context;
131 $c->res->_clear_context;
133 # Don't show body parser in the dump
134 $c->req->_clear_body;
138 for my $dump ( $c->dump_these ) {
139 my $name = $dump->[0];
140 my $value = encode_entities( dump( $dump->[1] ));
141 push @infos, sprintf <<"EOF", $name, $value;
142 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
144 <pre wrap="">%s</pre>
149 $infos = join "\n", @infos;
156 (en) Please come back later
157 (fr) SVP veuillez revenir plus tard
158 (de) Bitte versuchen sie es spaeter nocheinmal
159 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
160 (no) Vennligst prov igjen senere
161 (dk) Venligst prov igen senere
162 (pl) Prosze sprobowac pozniej
163 (pt) Por favor volte mais tarde
164 (ru) Попробуйте еще раз позже
165 (ua) Спробуйте ще раз пізніше
170 $c->res->body( <<"" );
171 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
172 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
173 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
175 <meta http-equiv="Content-Language" content="en" />
176 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
177 <title>$title</title>
178 <script type="text/javascript">
180 function toggleDump (dumpElement) {
181 var e = document.getElementById( dumpElement );
182 if (e.style.display == "none") {
183 e.style.display = "";
186 e.style.display = "none";
191 <style type="text/css">
193 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
194 Tahoma, Arial, helvetica, sans-serif;
196 background-color: #eee;
200 :link, :link:hover, :visited, :visited:hover {
205 background-color: #ccc;
206 border: 1px solid #aaa;
211 background-color: #cce;
212 border: 1px solid #755;
218 background-color: #eee;
219 border: 1px solid #575;
225 background-color: #cce;
226 border: 1px solid #557;
235 div.name h1, div.error p {
243 text-decoration: underline;
249 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
250 /* Browser specific (not valid) styles to make preformatted text wrap */
252 white-space: pre-wrap; /* css-3 */
253 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
254 white-space: -pre-wrap; /* Opera 4-6 */
255 white-space: -o-pre-wrap; /* Opera 7 */
256 word-wrap: break-word; /* Internet Explorer 5.5+ */
262 <div class="error">$error</div>
263 <div class="infos">$infos</div>
264 <div class="name">$name</div>
271 $c->res->{body} .= ( ' ' x 512 );
274 $c->res->status(500);
277 =head2 $self->finalize_headers($c)
279 Abstract method, allows engines to write headers to response
283 sub finalize_headers { }
285 =head2 $self->finalize_read($c)
289 sub finalize_read { }
291 =head2 $self->finalize_uploads($c)
293 Clean up after uploads, deleting temp files.
297 sub finalize_uploads {
298 my ( $self, $c ) = @_;
300 my $request = $c->request;
301 foreach my $key (keys %{ $request->uploads }) {
302 my $upload = $request->uploads->{$key};
303 unlink grep { -e $_ } map { $_->tempname }
304 (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
309 =head2 $self->prepare_body($c)
311 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
316 my ( $self, $c ) = @_;
318 if ( my $length = $self->read_length ) {
319 my $request = $c->request;
320 unless ( $request->_body ) {
321 my $type = $request->header('Content-Type');
322 $request->_body(HTTP::Body->new( $type, $length ));
323 $request->_body->tmpdir( $c->config->{uploadtmp} )
324 if exists $c->config->{uploadtmp};
327 while ( my $buffer = $self->read($c) ) {
328 $c->prepare_body_chunk($buffer);
331 # paranoia against wrong Content-Length header
332 my $remaining = $length - $self->read_position;
333 if ( $remaining > 0 ) {
334 $self->finalize_read($c);
335 Catalyst::Exception->throw(
336 "Wrong Content-Length value: $length" );
340 # Defined but will cause all body code to be skipped
341 $c->request->_body(0);
345 =head2 $self->prepare_body_chunk($c)
347 Add a chunk to the request body.
351 sub prepare_body_chunk {
352 my ( $self, $c, $chunk ) = @_;
354 $c->request->_body->add($chunk);
357 =head2 $self->prepare_body_parameters($c)
359 Sets up parameters from body.
363 sub prepare_body_parameters {
364 my ( $self, $c ) = @_;
366 return unless $c->request->_body;
368 $c->request->body_parameters( $c->request->_body->param );
371 =head2 $self->prepare_connection($c)
373 Abstract method implemented in engines.
377 sub prepare_connection { }
379 =head2 $self->prepare_cookies($c)
381 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
385 sub prepare_cookies {
386 my ( $self, $c ) = @_;
388 if ( my $header = $c->request->header('Cookie') ) {
389 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
393 =head2 $self->prepare_headers($c)
397 sub prepare_headers { }
399 =head2 $self->prepare_parameters($c)
401 sets up parameters from query and post parameters.
405 sub prepare_parameters {
406 my ( $self, $c ) = @_;
408 my $request = $c->request;
409 my $parameters = $request->parameters;
410 my $body_parameters = $request->body_parameters;
411 my $query_parameters = $request->query_parameters;
412 # We copy, no references
413 foreach my $name (keys %$query_parameters) {
414 my $param = $query_parameters->{$name};
415 $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
418 # Merge query and body parameters
419 foreach my $name (keys %$body_parameters) {
420 my $param = $body_parameters->{$name};
421 my @values = ref $param eq 'ARRAY' ? @$param : ($param);
422 if ( my $existing = $parameters->{$name} ) {
423 unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
425 $parameters->{$name} = @values > 1 ? \@values : $values[0];
429 =head2 $self->prepare_path($c)
431 abstract method, implemented by engines.
437 =head2 $self->prepare_request($c)
439 =head2 $self->prepare_query_parameters($c)
441 process the query string and extract query parameters.
445 sub prepare_query_parameters {
446 my ( $self, $c, $query_string ) = @_;
448 # Check for keywords (no = signs)
449 # (yes, index() is faster than a regex :))
450 if ( index( $query_string, '=' ) < 0 ) {
451 $c->request->query_keywords( $self->unescape_uri($query_string) );
457 # replace semi-colons
458 $query_string =~ s/;/&/g;
460 my @params = grep { length $_ } split /&/, $query_string;
462 for my $item ( @params ) {
465 = map { $self->unescape_uri($_) }
466 split( /=/, $item, 2 );
468 $param = $self->unescape_uri($item) unless defined $param;
470 if ( exists $query{$param} ) {
471 if ( ref $query{$param} ) {
472 push @{ $query{$param} }, $value;
475 $query{$param} = [ $query{$param}, $value ];
479 $query{$param} = $value;
483 $c->request->query_parameters( \%query );
486 =head2 $self->prepare_read($c)
488 prepare to read from the engine.
493 my ( $self, $c ) = @_;
495 # Initialize the read position
496 $self->read_position(0);
498 # Initialize the amount of data we think we need to read
499 $self->read_length( $c->request->header('Content-Length') || 0 );
502 =head2 $self->prepare_request(@arguments)
504 Populate the context object from the request object.
508 sub prepare_request { }
510 =head2 $self->prepare_uploads($c)
514 sub prepare_uploads {
515 my ( $self, $c ) = @_;
517 my $request = $c->request;
518 return unless $request->_body;
520 my $uploads = $request->_body->upload;
521 my $parameters = $request->parameters;
522 foreach my $name (keys %$uploads) {
523 my $files = $uploads->{$name};
525 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
526 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
527 my $u = Catalyst::Request::Upload->new
529 size => $upload->{size},
530 type => $headers->content_type,
532 tempname => $upload->{tempname},
533 filename => $upload->{filename},
537 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
539 # support access to the filename as a normal param
540 my @filenames = map { $_->{filename} } @uploads;
541 # append, if there's already params with this name
542 if (exists $parameters->{$name}) {
543 if (ref $parameters->{$name} eq 'ARRAY') {
544 push @{ $parameters->{$name} }, @filenames;
547 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
551 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
556 =head2 $self->prepare_write($c)
558 Abstract method. Implemented by the engines.
562 sub prepare_write { }
564 =head2 $self->read($c, [$maxlength])
569 my ( $self, $c, $maxlength ) = @_;
571 my $remaining = $self->read_length - $self->read_position;
572 $maxlength ||= $CHUNKSIZE;
574 # Are we done reading?
575 if ( $remaining <= 0 ) {
576 $self->finalize_read($c);
580 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
581 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
583 $self->read_position( $self->read_position + $rc );
587 Catalyst::Exception->throw(
588 message => "Unknown error reading input: $!" );
592 =head2 $self->read_chunk($c, $buffer, $length)
594 Each engine implements read_chunk as its preferred way of reading a chunk
601 =head2 $self->read_length
603 The length of input data to be read. This is obtained from the Content-Length
606 =head2 $self->read_position
608 The amount of input data that has already been read.
610 =head2 $self->run($c)
612 Start the engine. Implemented by the various engine classes.
618 =head2 $self->write($c, $buffer)
620 Writes the buffer to the client.
625 my ( $self, $c, $buffer ) = @_;
627 unless ( $self->_prepared_write ) {
628 $self->prepare_write($c);
629 $self->_prepared_write(1);
632 return 0 if !defined $buffer;
634 my $len = length($buffer);
635 my $wrote = syswrite STDOUT, $buffer;
637 if ( !defined $wrote && $! == EWOULDBLOCK ) {
638 # Unable to write on the first try, will retry in the loop below
642 if ( defined $wrote && $wrote < $len ) {
643 # We didn't write the whole buffer
645 my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
646 if ( defined $ret ) {
650 next if $! == EWOULDBLOCK;
654 last if $wrote >= $len;
661 =head2 $self->unescape_uri($uri)
663 Unescapes a given URI using the most efficient method available. Engines such
664 as Apache may implement this using Apache's C-based modules, for example.
669 my ( $self, $str ) = @_;
671 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
676 =head2 $self->finalize_output
678 <obsolete>, see finalize_body
682 Hash containing enviroment variables including many special variables inserted
683 by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
685 Before accesing enviroment variables consider whether the same information is
686 not directly available via Catalyst objects $c->request, $c->engine ...
688 BEWARE: If you really need to access some enviroment variable from your Catalyst
689 application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
690 as in some enviroments the %ENV hash does not contain what you would expect.
694 Catalyst Contributors, see Catalyst.pm
698 This library is free software. You can redistribute it and/or modify it under
699 the same terms as Perl itself.