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 my $request = $c->request;
315 foreach my $key (keys %{ $request->uploads }) {
316 my $upload = $request->uploads->{$key};
317 unlink grep { -e $_ } map { $_->tempname }
318 (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
323 =head2 $self->prepare_body($c)
325 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
330 my ( $self, $c ) = @_;
332 my $appclass = ref($c) || $c;
333 if ( my $length = $self->read_length ) {
334 my $request = $c->request;
335 unless ( $request->_body ) {
336 my $type = $request->header('Content-Type');
337 $request->_body(HTTP::Body->new( $type, $length ));
338 $request->_body->tmpdir( $appclass->config->{uploadtmp} )
339 if exists $appclass->config->{uploadtmp};
342 # Check for definedness as you could read '0'
343 while ( defined ( my $buffer = $self->read($c) ) ) {
344 $c->prepare_body_chunk($buffer);
347 # paranoia against wrong Content-Length header
348 my $remaining = $length - $self->read_position;
349 if ( $remaining > 0 ) {
350 $self->finalize_read($c);
351 Catalyst::Exception->throw(
352 "Wrong Content-Length value: $length" );
356 # Defined but will cause all body code to be skipped
357 $c->request->_body(0);
361 =head2 $self->prepare_body_chunk($c)
363 Add a chunk to the request body.
367 sub prepare_body_chunk {
368 my ( $self, $c, $chunk ) = @_;
370 $c->request->_body->add($chunk);
373 =head2 $self->prepare_body_parameters($c)
375 Sets up parameters from body.
379 sub prepare_body_parameters {
380 my ( $self, $c ) = @_;
382 return unless $c->request->_body;
384 $c->request->body_parameters( $c->request->_body->param );
387 =head2 $self->prepare_connection($c)
389 Abstract method implemented in engines.
393 sub prepare_connection { }
395 =head2 $self->prepare_cookies($c)
397 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
401 sub prepare_cookies {
402 my ( $self, $c ) = @_;
404 if ( my $header = $c->request->header('Cookie') ) {
405 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
409 =head2 $self->prepare_headers($c)
413 sub prepare_headers { }
415 =head2 $self->prepare_parameters($c)
417 sets up parameters from query and post parameters.
421 sub prepare_parameters {
422 my ( $self, $c ) = @_;
424 my $request = $c->request;
425 my $parameters = $request->parameters;
426 my $body_parameters = $request->body_parameters;
427 my $query_parameters = $request->query_parameters;
428 # We copy, no references
429 foreach my $name (keys %$query_parameters) {
430 my $param = $query_parameters->{$name};
431 $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
434 # Merge query and body parameters
435 foreach my $name (keys %$body_parameters) {
436 my $param = $body_parameters->{$name};
437 my @values = ref $param eq 'ARRAY' ? @$param : ($param);
438 if ( my $existing = $parameters->{$name} ) {
439 unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
441 $parameters->{$name} = @values > 1 ? \@values : $values[0];
445 =head2 $self->prepare_path($c)
447 abstract method, implemented by engines.
453 =head2 $self->prepare_request($c)
455 =head2 $self->prepare_query_parameters($c)
457 process the query string and extract query parameters.
461 sub prepare_query_parameters {
462 my ( $self, $c, $query_string ) = @_;
464 # Check for keywords (no = signs)
465 # (yes, index() is faster than a regex :))
466 if ( index( $query_string, '=' ) < 0 ) {
467 $c->request->query_keywords( $self->unescape_uri($query_string) );
473 # replace semi-colons
474 $query_string =~ s/;/&/g;
476 my @params = grep { length $_ } split /&/, $query_string;
478 for my $item ( @params ) {
481 = map { $self->unescape_uri($_) }
482 split( /=/, $item, 2 );
484 $param = $self->unescape_uri($item) unless defined $param;
486 if ( exists $query{$param} ) {
487 if ( ref $query{$param} ) {
488 push @{ $query{$param} }, $value;
491 $query{$param} = [ $query{$param}, $value ];
495 $query{$param} = $value;
499 $c->request->query_parameters( \%query );
502 =head2 $self->prepare_read($c)
504 prepare to read from the engine.
509 my ( $self, $c ) = @_;
511 # Initialize the read position
512 $self->read_position(0);
514 # Initialize the amount of data we think we need to read
515 $self->read_length( $c->request->header('Content-Length') || 0 );
518 =head2 $self->prepare_request(@arguments)
520 Populate the context object from the request object.
524 sub prepare_request { }
526 =head2 $self->prepare_uploads($c)
530 sub prepare_uploads {
531 my ( $self, $c ) = @_;
533 my $request = $c->request;
534 return unless $request->_body;
536 my $uploads = $request->_body->upload;
537 my $parameters = $request->parameters;
538 foreach my $name (keys %$uploads) {
539 my $files = $uploads->{$name};
541 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
542 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
543 my $u = Catalyst::Request::Upload->new
545 size => $upload->{size},
546 type => $headers->content_type,
548 tempname => $upload->{tempname},
549 filename => $upload->{filename},
553 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
555 # support access to the filename as a normal param
556 my @filenames = map { $_->{filename} } @uploads;
557 # append, if there's already params with this name
558 if (exists $parameters->{$name}) {
559 if (ref $parameters->{$name} eq 'ARRAY') {
560 push @{ $parameters->{$name} }, @filenames;
563 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
567 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
572 =head2 $self->prepare_write($c)
574 Abstract method. Implemented by the engines.
578 sub prepare_write { }
580 =head2 $self->read($c, [$maxlength])
582 Reads from the input stream by calling C<< $self->read_chunk >>.
584 Maintains the read_length and read_position counters as data is read.
589 my ( $self, $c, $maxlength ) = @_;
591 my $remaining = $self->read_length - $self->read_position;
592 $maxlength ||= $CHUNKSIZE;
594 # Are we done reading?
595 if ( $remaining <= 0 ) {
596 $self->finalize_read($c);
600 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
601 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
603 if (0 == $rc) { # Nothing more to read even though Content-Length
604 # said there should be. FIXME - Warn in the log here?
605 $self->finalize_read;
608 $self->read_position( $self->read_position + $rc );
612 Catalyst::Exception->throw(
613 message => "Unknown error reading input: $!" );
617 =head2 $self->read_chunk($c, $buffer, $length)
619 Each engine implements read_chunk as its preferred way of reading a chunk
620 of data. Returns the number of bytes read. A return of 0 indicates that
621 there is no more data to be read.
627 =head2 $self->read_length
629 The length of input data to be read. This is obtained from the Content-Length
632 =head2 $self->read_position
634 The amount of input data that has already been read.
636 =head2 $self->run($c)
638 Start the engine. Implemented by the various engine classes.
644 =head2 $self->write($c, $buffer)
646 Writes the buffer to the client.
651 my ( $self, $c, $buffer ) = @_;
653 unless ( $self->_prepared_write ) {
654 $self->prepare_write($c);
655 $self->_prepared_write(1);
658 return 0 if !defined $buffer;
660 my $len = length($buffer);
661 my $wrote = syswrite STDOUT, $buffer;
663 if ( !defined $wrote && $! == EWOULDBLOCK ) {
664 # Unable to write on the first try, will retry in the loop below
668 if ( defined $wrote && $wrote < $len ) {
669 # We didn't write the whole buffer
671 my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
672 if ( defined $ret ) {
676 next if $! == EWOULDBLOCK;
680 last if $wrote >= $len;
687 =head2 $self->unescape_uri($uri)
689 Unescapes a given URI using the most efficient method available. Engines such
690 as Apache may implement this using Apache's C-based modules, for example.
695 my ( $self, $str ) = @_;
697 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
702 =head2 $self->finalize_output
704 <obsolete>, see finalize_body
708 Hash containing enviroment variables including many special variables inserted
709 by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
711 Before accesing enviroment variables consider whether the same information is
712 not directly available via Catalyst objects $c->request, $c->engine ...
714 BEWARE: If you really need to access some enviroment variable from your Catalyst
715 application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
716 as in some enviroments the %ENV hash does not contain what you would expect.
720 Catalyst Contributors, see Catalyst.pm
724 This library is free software. You can redistribute it and/or modify it under
725 the same terms as Perl itself.