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' ) {
53 $got = read $body, my ($buffer), $CHUNKSIZE;
54 $got = 0 unless $self->write( $c, $buffer );
60 $self->write( $c, $body );
64 =head2 $self->finalize_cookies($c)
66 Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
71 sub finalize_cookies {
72 my ( $self, $c ) = @_;
75 my $response = $c->response;
77 foreach my $name (keys %{ $response->cookies }) {
79 my $val = $response->cookies->{$name};
84 : CGI::Simple::Cookie->new(
86 -value => $val->{value},
87 -expires => $val->{expires},
88 -domain => $val->{domain},
89 -path => $val->{path},
90 -secure => $val->{secure} || 0,
91 -httponly => $val->{httponly} || 0,
95 push @cookies, $cookie->as_string;
98 for my $cookie (@cookies) {
99 $response->headers->push_header( 'Set-Cookie' => $cookie );
103 =head2 $self->finalize_error($c)
105 Output an appropriate error message. Called if there's an error in $c
106 after the dispatch has finished. Will output debug messages if Catalyst
107 is in debug mode, or a `please come back later` message otherwise.
111 sub _dump_error_page_element {
112 my ($self, $i, $element) = @_;
113 my ($name, $val) = @{ $element };
115 # This is fugly, but the metaclass is _HUGE_ and demands waaay too much
116 # scrolling. Suggestions for more pleasant ways to do this welcome.
117 local $val->{'__MOP__'} = "Stringified: "
118 . $val->{'__MOP__'} if ref $val eq 'HASH' && exists $val->{'__MOP__'};
120 my $text = encode_entities( dump( $val ));
121 sprintf <<"EOF", $name, $text;
122 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
124 <pre wrap="">%s</pre>
130 my ( $self, $c ) = @_;
132 $c->res->content_type('text/html; charset=utf-8');
133 my $name = ref($c)->config->{name} || join(' ', split('::', ref $c));
135 my ( $title, $error, $infos );
139 $error = join '', map {
140 '<p><code class="error">'
141 . encode_entities($_)
144 $error ||= 'No output';
145 $error = qq{<pre wrap="">$error</pre>};
146 $title = $name = "$name on Catalyst $Catalyst::VERSION";
147 $name = "<h1>$name</h1>";
149 # Don't show context in the dump
150 $c->req->_clear_context;
151 $c->res->_clear_context;
153 # Don't show body parser in the dump
154 $c->req->_clear_body;
158 for my $dump ( $c->dump_these ) {
159 push @infos, $self->_dump_error_page_element($i, $dump);
162 $infos = join "\n", @infos;
169 (en) Please come back later
170 (fr) SVP veuillez revenir plus tard
171 (de) Bitte versuchen sie es spaeter nocheinmal
172 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
173 (no) Vennligst prov igjen senere
174 (dk) Venligst prov igen senere
175 (pl) Prosze sprobowac pozniej
176 (pt) Por favor volte mais tarde
177 (ru) Попробуйте еще раз позже
178 (ua) Спробуйте ще раз пізніше
183 $c->res->body( <<"" );
184 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
185 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
186 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
188 <meta http-equiv="Content-Language" content="en" />
189 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
190 <title>$title</title>
191 <script type="text/javascript">
193 function toggleDump (dumpElement) {
194 var e = document.getElementById( dumpElement );
195 if (e.style.display == "none") {
196 e.style.display = "";
199 e.style.display = "none";
204 <style type="text/css">
206 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
207 Tahoma, Arial, helvetica, sans-serif;
209 background-color: #eee;
213 :link, :link:hover, :visited, :visited:hover {
218 background-color: #ccc;
219 border: 1px solid #aaa;
224 background-color: #cce;
225 border: 1px solid #755;
231 background-color: #eee;
232 border: 1px solid #575;
238 background-color: #cce;
239 border: 1px solid #557;
248 div.name h1, div.error p {
256 text-decoration: underline;
262 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
263 /* Browser specific (not valid) styles to make preformatted text wrap */
265 white-space: pre-wrap; /* css-3 */
266 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
267 white-space: -pre-wrap; /* Opera 4-6 */
268 white-space: -o-pre-wrap; /* Opera 7 */
269 word-wrap: break-word; /* Internet Explorer 5.5+ */
275 <div class="error">$error</div>
276 <div class="infos">$infos</div>
277 <div class="name">$name</div>
283 # Trick IE. Old versions of IE would display their own error page instead
284 # of ours if we'd give it less than 512 bytes.
285 $c->res->{body} .= ( ' ' x 512 );
288 $c->res->status(500);
291 =head2 $self->finalize_headers($c)
293 Abstract method, allows engines to write headers to response
297 sub finalize_headers { }
299 =head2 $self->finalize_read($c)
303 sub finalize_read { }
305 =head2 $self->finalize_uploads($c)
307 Clean up after uploads, deleting temp files.
311 sub finalize_uploads {
312 my ( $self, $c ) = @_;
314 # N.B. This code is theoretically entirely unneeded due to ->cleanup(1)
315 # on the HTTP::Body object.
316 my $request = $c->request;
317 foreach my $key (keys %{ $request->uploads }) {
318 my $upload = $request->uploads->{$key};
319 unlink grep { -e $_ } map { $_->tempname }
320 (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
325 =head2 $self->prepare_body($c)
327 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
332 my ( $self, $c ) = @_;
334 my $appclass = ref($c) || $c;
335 if ( my $length = $self->read_length ) {
336 my $request = $c->request;
337 unless ( $request->_body ) {
338 my $type = $request->header('Content-Type');
339 $request->_body(HTTP::Body->new( $type, $length ));
340 $request->_body->cleanup(1); # Make extra sure!
341 $request->_body->tmpdir( $appclass->config->{uploadtmp} )
342 if exists $appclass->config->{uploadtmp};
345 # Check for definedness as you could read '0'
346 while ( defined ( my $buffer = $self->read($c) ) ) {
347 $c->prepare_body_chunk($buffer);
350 # paranoia against wrong Content-Length header
351 my $remaining = $length - $self->read_position;
352 if ( $remaining > 0 ) {
353 $self->finalize_read($c);
354 Catalyst::Exception->throw(
355 "Wrong Content-Length value: $length" );
359 # Defined but will cause all body code to be skipped
360 $c->request->_body(0);
364 =head2 $self->prepare_body_chunk($c)
366 Add a chunk to the request body.
370 sub prepare_body_chunk {
371 my ( $self, $c, $chunk ) = @_;
373 $c->request->_body->add($chunk);
376 =head2 $self->prepare_body_parameters($c)
378 Sets up parameters from body.
382 sub prepare_body_parameters {
383 my ( $self, $c ) = @_;
385 return unless $c->request->_body;
387 $c->request->body_parameters( $c->request->_body->param );
390 =head2 $self->prepare_connection($c)
392 Abstract method implemented in engines.
396 sub prepare_connection { }
398 =head2 $self->prepare_cookies($c)
400 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
404 sub prepare_cookies {
405 my ( $self, $c ) = @_;
407 if ( my $header = $c->request->header('Cookie') ) {
408 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
412 =head2 $self->prepare_headers($c)
416 sub prepare_headers { }
418 =head2 $self->prepare_parameters($c)
420 sets up parameters from query and post parameters.
424 sub prepare_parameters {
425 my ( $self, $c ) = @_;
427 my $request = $c->request;
428 my $parameters = $request->parameters;
429 my $body_parameters = $request->body_parameters;
430 my $query_parameters = $request->query_parameters;
431 # We copy, no references
432 foreach my $name (keys %$query_parameters) {
433 my $param = $query_parameters->{$name};
434 $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
437 # Merge query and body parameters
438 foreach my $name (keys %$body_parameters) {
439 my $param = $body_parameters->{$name};
440 my @values = ref $param eq 'ARRAY' ? @$param : ($param);
441 if ( my $existing = $parameters->{$name} ) {
442 unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
444 $parameters->{$name} = @values > 1 ? \@values : $values[0];
448 =head2 $self->prepare_path($c)
450 abstract method, implemented by engines.
456 =head2 $self->prepare_request($c)
458 =head2 $self->prepare_query_parameters($c)
460 process the query string and extract query parameters.
464 sub prepare_query_parameters {
465 my ( $self, $c, $query_string ) = @_;
467 # Check for keywords (no = signs)
468 # (yes, index() is faster than a regex :))
469 if ( index( $query_string, '=' ) < 0 ) {
470 $c->request->query_keywords( $self->unescape_uri($query_string) );
476 # replace semi-colons
477 $query_string =~ s/;/&/g;
479 my @params = grep { length $_ } split /&/, $query_string;
481 for my $item ( @params ) {
484 = map { $self->unescape_uri($_) }
485 split( /=/, $item, 2 );
487 $param = $self->unescape_uri($item) unless defined $param;
489 if ( exists $query{$param} ) {
490 if ( ref $query{$param} ) {
491 push @{ $query{$param} }, $value;
494 $query{$param} = [ $query{$param}, $value ];
498 $query{$param} = $value;
502 $c->request->query_parameters( \%query );
505 =head2 $self->prepare_read($c)
507 prepare to read from the engine.
512 my ( $self, $c ) = @_;
514 # Initialize the read position
515 $self->read_position(0);
517 # Initialize the amount of data we think we need to read
518 $self->read_length( $c->request->header('Content-Length') || 0 );
521 =head2 $self->prepare_request(@arguments)
523 Populate the context object from the request object.
527 sub prepare_request { }
529 =head2 $self->prepare_uploads($c)
533 sub prepare_uploads {
534 my ( $self, $c ) = @_;
536 my $request = $c->request;
537 return unless $request->_body;
539 my $uploads = $request->_body->upload;
540 my $parameters = $request->parameters;
541 foreach my $name (keys %$uploads) {
542 my $files = $uploads->{$name};
544 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
545 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
546 my $u = Catalyst::Request::Upload->new
548 size => $upload->{size},
549 type => scalar $headers->content_type,
551 tempname => $upload->{tempname},
552 filename => $upload->{filename},
556 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
558 # support access to the filename as a normal param
559 my @filenames = map { $_->{filename} } @uploads;
560 # append, if there's already params with this name
561 if (exists $parameters->{$name}) {
562 if (ref $parameters->{$name} eq 'ARRAY') {
563 push @{ $parameters->{$name} }, @filenames;
566 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
570 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
575 =head2 $self->prepare_write($c)
577 Abstract method. Implemented by the engines.
581 sub prepare_write { }
583 =head2 $self->read($c, [$maxlength])
585 Reads from the input stream by calling C<< $self->read_chunk >>.
587 Maintains the read_length and read_position counters as data is read.
592 my ( $self, $c, $maxlength ) = @_;
594 my $remaining = $self->read_length - $self->read_position;
595 $maxlength ||= $CHUNKSIZE;
597 # Are we done reading?
598 if ( $remaining <= 0 ) {
599 $self->finalize_read($c);
603 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
604 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
606 if (0 == $rc) { # Nothing more to read even though Content-Length
607 # said there should be. FIXME - Warn in the log here?
608 $self->finalize_read;
611 $self->read_position( $self->read_position + $rc );
615 Catalyst::Exception->throw(
616 message => "Unknown error reading input: $!" );
620 =head2 $self->read_chunk($c, $buffer, $length)
622 Each engine implements read_chunk as its preferred way of reading a chunk
623 of data. Returns the number of bytes read. A return of 0 indicates that
624 there is no more data to be read.
630 =head2 $self->read_length
632 The length of input data to be read. This is obtained from the Content-Length
635 =head2 $self->read_position
637 The amount of input data that has already been read.
639 =head2 $self->run($c)
641 Start the engine. Implemented by the various engine classes.
647 =head2 $self->write($c, $buffer)
649 Writes the buffer to the client.
654 my ( $self, $c, $buffer ) = @_;
656 unless ( $self->_prepared_write ) {
657 $self->prepare_write($c);
658 $self->_prepared_write(1);
661 return 0 if !defined $buffer;
663 my $len = length($buffer);
664 my $wrote = syswrite STDOUT, $buffer;
666 if ( !defined $wrote && $! == EWOULDBLOCK ) {
667 # Unable to write on the first try, will retry in the loop below
671 if ( defined $wrote && $wrote < $len ) {
672 # We didn't write the whole buffer
674 my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
675 if ( defined $ret ) {
679 next if $! == EWOULDBLOCK;
683 last if $wrote >= $len;
690 =head2 $self->unescape_uri($uri)
692 Unescapes a given URI using the most efficient method available. Engines such
693 as Apache may implement this using Apache's C-based modules, for example.
698 my ( $self, $str ) = @_;
700 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
705 =head2 $self->finalize_output
707 <obsolete>, see finalize_body
711 Hash containing environment variables including many special variables inserted
712 by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
714 Before accessing environment variables consider whether the same information is
715 not directly available via Catalyst objects $c->request, $c->engine ...
717 BEWARE: If you really need to access some environment variable from your Catalyst
718 application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
719 as in some enviroments the %ENV hash does not contain what you would expect.
723 Catalyst Contributors, see Catalyst.pm
727 This library is free software. You can redistribute it and/or modify it under
728 the same terms as Perl itself.