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';
15 use namespace::clean -except => 'meta';
17 # input position and length
18 has read_length => (is => 'rw');
19 has read_position => (is => 'rw');
21 has _prepared_write => (is => 'rw');
23 # Amount of data to read from input on each pass
24 our $CHUNKSIZE = 64 * 1024;
28 Catalyst::Engine - The Catalyst Engine
39 =head2 $self->finalize_body($c)
41 Finalize body. Prints the response output.
46 my ( $self, $c ) = @_;
47 my $body = $c->response->body;
48 no warnings 'uninitialized';
49 if ( Scalar::Util::blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
50 while ( !eof $body ) {
51 read $body, my ($buffer), $CHUNKSIZE;
52 last unless $self->write( $c, $buffer );
57 $self->write( $c, $body );
61 =head2 $self->finalize_cookies($c)
63 Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
68 sub finalize_cookies {
69 my ( $self, $c ) = @_;
72 my $response = $c->response;
74 foreach my $name (keys %{ $response->cookies }) {
76 my $val = $response->cookies->{$name};
79 Scalar::Util::blessed($val)
81 : CGI::Simple::Cookie->new(
83 -value => $val->{value},
84 -expires => $val->{expires},
85 -domain => $val->{domain},
86 -path => $val->{path},
87 -secure => $val->{secure} || 0
91 push @cookies, $cookie->as_string;
94 for my $cookie (@cookies) {
95 $response->headers->push_header( 'Set-Cookie' => $cookie );
99 =head2 $self->finalize_error($c)
101 Output an appropriate error message. Called if there's an error in $c
102 after the dispatch has finished. Will output debug messages if Catalyst
103 is in debug mode, or a `please come back later` message otherwise.
108 my ( $self, $c ) = @_;
110 $c->res->content_type('text/html; charset=utf-8');
111 my $name = $c->config->{name} || join(' ', split('::', ref $c));
113 my ( $title, $error, $infos );
117 $error = join '', map {
118 '<p><code class="error">'
119 . encode_entities($_)
122 $error ||= 'No output';
123 $error = qq{<pre wrap="">$error</pre>};
124 $title = $name = "$name on Catalyst $Catalyst::VERSION";
125 $name = "<h1>$name</h1>";
127 # Don't show context in the dump
128 $c->req->_clear_context;
129 $c->res->_clear_context;
131 # Don't show body parser in the dump
132 $c->req->_clear_body;
136 for my $dump ( $c->dump_these ) {
137 my $name = $dump->[0];
138 my $value = encode_entities( dump( $dump->[1] ));
139 push @infos, sprintf <<"EOF", $name, $value;
140 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
142 <pre wrap="">%s</pre>
147 $infos = join "\n", @infos;
154 (en) Please come back later
155 (fr) SVP veuillez revenir plus tard
156 (de) Bitte versuchen sie es spaeter nocheinmal
157 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
158 (no) Vennligst prov igjen senere
159 (dk) Venligst prov igen senere
160 (pl) Prosze sprobowac pozniej
161 (pt) Por favor volte mais tarde
162 (ru) Попробуйте еще раз позже
163 (ua) Спробуйте ще раз пізніше
168 $c->res->body( <<"" );
169 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
170 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
171 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
173 <meta http-equiv="Content-Language" content="en" />
174 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
175 <title>$title</title>
176 <script type="text/javascript">
178 function toggleDump (dumpElement) {
179 var e = document.getElementById( dumpElement );
180 if (e.style.display == "none") {
181 e.style.display = "";
184 e.style.display = "none";
189 <style type="text/css">
191 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
192 Tahoma, Arial, helvetica, sans-serif;
194 background-color: #eee;
198 :link, :link:hover, :visited, :visited:hover {
203 background-color: #ccc;
204 border: 1px solid #aaa;
209 background-color: #cce;
210 border: 1px solid #755;
216 background-color: #eee;
217 border: 1px solid #575;
223 background-color: #cce;
224 border: 1px solid #557;
233 div.name h1, div.error p {
241 text-decoration: underline;
247 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
248 /* Browser specific (not valid) styles to make preformatted text wrap */
250 white-space: pre-wrap; /* css-3 */
251 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
252 white-space: -pre-wrap; /* Opera 4-6 */
253 white-space: -o-pre-wrap; /* Opera 7 */
254 word-wrap: break-word; /* Internet Explorer 5.5+ */
260 <div class="error">$error</div>
261 <div class="infos">$infos</div>
262 <div class="name">$name</div>
269 $c->res->{body} .= ( ' ' x 512 );
272 $c->res->status(500);
275 =head2 $self->finalize_headers($c)
277 Abstract method, allows engines to write headers to response
281 sub finalize_headers { }
283 =head2 $self->finalize_read($c)
287 sub finalize_read { }
289 =head2 $self->finalize_uploads($c)
291 Clean up after uploads, deleting temp files.
295 sub finalize_uploads {
296 my ( $self, $c ) = @_;
298 my $request = $c->request;
299 foreach my $key (keys %{ $request->uploads }) {
300 my $upload = $request->uploads->{$key};
301 unlink grep { -e $_ } map { $_->tempname }
302 (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
307 =head2 $self->prepare_body($c)
309 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
314 my ( $self, $c ) = @_;
316 if ( my $length = $self->read_length ) {
317 my $request = $c->request;
318 unless ( $request->_body ) {
319 my $type = $request->header('Content-Type');
320 $request->_body(HTTP::Body->new( $type, $length ));
321 $request->_body->tmpdir( $c->config->{uploadtmp} )
322 if exists $c->config->{uploadtmp};
325 while ( my $buffer = $self->read($c) ) {
326 $c->prepare_body_chunk($buffer);
329 # paranoia against wrong Content-Length header
330 my $remaining = $length - $self->read_position;
331 if ( $remaining > 0 ) {
332 $self->finalize_read($c);
333 Catalyst::Exception->throw(
334 "Wrong Content-Length value: $length" );
338 # Defined but will cause all body code to be skipped
339 $c->request->_body(0);
343 =head2 $self->prepare_body_chunk($c)
345 Add a chunk to the request body.
349 sub prepare_body_chunk {
350 my ( $self, $c, $chunk ) = @_;
352 $c->request->_body->add($chunk);
355 =head2 $self->prepare_body_parameters($c)
357 Sets up parameters from body.
361 sub prepare_body_parameters {
362 my ( $self, $c ) = @_;
364 return unless $c->request->_body;
366 $c->request->body_parameters( $c->request->_body->param );
369 =head2 $self->prepare_connection($c)
371 Abstract method implemented in engines.
375 sub prepare_connection { }
377 =head2 $self->prepare_cookies($c)
379 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
383 sub prepare_cookies {
384 my ( $self, $c ) = @_;
386 if ( my $header = $c->request->header('Cookie') ) {
387 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
391 =head2 $self->prepare_headers($c)
395 sub prepare_headers { }
397 =head2 $self->prepare_parameters($c)
399 sets up parameters from query and post parameters.
403 sub prepare_parameters {
404 my ( $self, $c ) = @_;
406 my $request = $c->request;
407 my $parameters = $request->parameters;
408 my $body_parameters = $request->body_parameters;
409 my $query_parameters = $request->query_parameters;
410 # We copy, no references
411 foreach my $name (keys %$query_parameters) {
412 my $param = $query_parameters->{$name};
413 $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
416 # Merge query and body parameters
417 foreach my $name (keys %$body_parameters) {
418 my $param = $body_parameters->{$name};
419 my @values = ref $param eq 'ARRAY' ? @$param : ($param);
420 if ( my $existing = $parameters->{$name} ) {
421 unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
423 $parameters->{$name} = @values > 1 ? \@values : $values[0];
427 =head2 $self->prepare_path($c)
429 abstract method, implemented by engines.
435 =head2 $self->prepare_request($c)
437 =head2 $self->prepare_query_parameters($c)
439 process the query string and extract query parameters.
443 sub prepare_query_parameters {
444 my ( $self, $c, $query_string ) = @_;
446 # Check for keywords (no = signs)
447 # (yes, index() is faster than a regex :))
448 if ( index( $query_string, '=' ) < 0 ) {
449 $c->request->query_keywords( $self->unescape_uri($query_string) );
455 # replace semi-colons
456 $query_string =~ s/;/&/g;
458 my @params = grep { length $_ } split /&/, $query_string;
460 for my $item ( @params ) {
463 = map { $self->unescape_uri($_) }
464 split( /=/, $item, 2 );
466 $param = $self->unescape_uri($item) unless defined $param;
468 if ( exists $query{$param} ) {
469 if ( ref $query{$param} ) {
470 push @{ $query{$param} }, $value;
473 $query{$param} = [ $query{$param}, $value ];
477 $query{$param} = $value;
481 $c->request->query_parameters( \%query );
484 =head2 $self->prepare_read($c)
486 prepare to read from the engine.
491 my ( $self, $c ) = @_;
493 # Initialize the read position
494 $self->read_position(0);
496 # Initialize the amount of data we think we need to read
497 $self->read_length( $c->request->header('Content-Length') || 0 );
500 =head2 $self->prepare_request(@arguments)
502 Populate the context object from the request object.
506 sub prepare_request { }
508 =head2 $self->prepare_uploads($c)
512 sub prepare_uploads {
513 my ( $self, $c ) = @_;
515 my $request = $c->request;
516 return unless $request->_body;
518 my $uploads = $request->_body->upload;
519 my $parameters = $request->parameters;
520 foreach my $name (keys %$uploads) {
521 my $files = $uploads->{$name};
523 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
524 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
525 my $u = Catalyst::Request::Upload->new
527 size => $upload->{size},
528 type => $headers->content_type,
530 tempname => $upload->{tempname},
531 filename => $upload->{filename},
535 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
537 # support access to the filename as a normal param
538 my @filenames = map { $_->{filename} } @uploads;
539 # append, if there's already params with this name
540 if (exists $parameters->{$name}) {
541 if (ref $parameters->{$name} eq 'ARRAY') {
542 push @{ $parameters->{$name} }, @filenames;
545 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
549 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
554 =head2 $self->prepare_write($c)
556 Abstract method. Implemented by the engines.
560 sub prepare_write { }
562 =head2 $self->read($c, [$maxlength])
567 my ( $self, $c, $maxlength ) = @_;
569 my $remaining = $self->read_length - $self->read_position;
570 $maxlength ||= $CHUNKSIZE;
572 # Are we done reading?
573 if ( $remaining <= 0 ) {
574 $self->finalize_read($c);
578 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
579 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
581 $self->read_position( $self->read_position + $rc );
585 Catalyst::Exception->throw(
586 message => "Unknown error reading input: $!" );
590 =head2 $self->read_chunk($c, $buffer, $length)
592 Each engine implements read_chunk as its preferred way of reading a chunk
599 =head2 $self->read_length
601 The length of input data to be read. This is obtained from the Content-Length
604 =head2 $self->read_position
606 The amount of input data that has already been read.
608 =head2 $self->run($c)
610 Start the engine. Implemented by the various engine classes.
616 =head2 $self->write($c, $buffer)
618 Writes the buffer to the client.
623 my ( $self, $c, $buffer ) = @_;
625 unless ( $self->_prepared_write ) {
626 $self->prepare_write($c);
627 $self->_prepared_write(1);
630 return 0 if !defined $buffer;
632 my $len = length($buffer);
633 my $wrote = syswrite STDOUT, $buffer;
635 if ( !defined $wrote && $! == EWOULDBLOCK ) {
636 # Unable to write on the first try, will retry in the loop below
640 if ( defined $wrote && $wrote < $len ) {
641 # We didn't write the whole buffer
643 my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
644 if ( defined $ret ) {
648 next if $! == EWOULDBLOCK;
652 last if $wrote >= $len;
659 =head2 $self->unescape_uri($uri)
661 Unescapes a given URI using the most efficient method available. Engines such
662 as Apache may implement this using Apache's C-based modules, for example.
667 my ( $self, $str ) = @_;
669 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
674 =head2 $self->finalize_output
676 <obsolete>, see finalize_body
680 Catalyst Contributors, see Catalyst.pm
684 This program is free software, you can redistribute it and/or modify it under
685 the same terms as Perl itself.