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 # input position and length
16 has read_length => (is => 'rw');
17 has read_position => (is => 'rw');
21 # Amount of data to read from input on each pass
22 our $CHUNKSIZE = 64 * 1024;
26 Catalyst::Engine - The Catalyst Engine
37 =head2 $self->finalize_body($c)
39 Finalize body. Prints the response output.
44 my ( $self, $c ) = @_;
45 my $body = $c->response->body;
46 no warnings 'uninitialized';
47 if ( Scalar::Util::blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
48 while ( !eof $body ) {
49 read $body, my ($buffer), $CHUNKSIZE;
50 last unless $self->write( $c, $buffer );
55 $self->write( $c, $body );
59 =head2 $self->finalize_cookies($c)
61 Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
66 sub finalize_cookies {
67 my ( $self, $c ) = @_;
70 my $response = $c->response;
72 foreach my $name (keys %{ $response->cookies }) {
74 my $val = $response->cookies->{$name};
77 Scalar::Util::blessed($val)
79 : CGI::Simple::Cookie->new(
81 -value => $val->{value},
82 -expires => $val->{expires},
83 -domain => $val->{domain},
84 -path => $val->{path},
85 -secure => $val->{secure} || 0
89 push @cookies, $cookie->as_string;
92 for my $cookie (@cookies) {
93 $response->headers->push_header( 'Set-Cookie' => $cookie );
97 =head2 $self->finalize_error($c)
99 Output an appropriate error message. Called if there's an error in $c
100 after the dispatch has finished. Will output debug messages if Catalyst
101 is in debug mode, or a `please come back later` message otherwise.
106 my ( $self, $c ) = @_;
108 $c->res->content_type('text/html; charset=utf-8');
109 my $name = $c->config->{name} || join(' ', split('::', ref $c));
111 my ( $title, $error, $infos );
115 $error = join '', map {
116 '<p><code class="error">'
117 . encode_entities($_)
120 $error ||= 'No output';
121 $error = qq{<pre wrap="">$error</pre>};
122 $title = $name = "$name on Catalyst $Catalyst::VERSION";
123 $name = "<h1>$name</h1>";
125 # Don't show context in the dump
126 delete $c->req->{_context};
127 delete $c->res->{_context};
129 # Don't show body parser in the dump
130 delete $c->req->{_body};
134 for my $dump ( $c->dump_these ) {
135 my $name = $dump->[0];
136 my $value = encode_entities( dump( $dump->[1] ));
137 push @infos, sprintf <<"EOF", $name, $value;
138 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
140 <pre wrap="">%s</pre>
145 $infos = join "\n", @infos;
152 (en) Please come back later
153 (fr) SVP veuillez revenir plus tard
154 (de) Bitte versuchen sie es spaeter nocheinmal
155 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
156 (no) Vennligst prov igjen senere
157 (dk) Venligst prov igen senere
158 (pl) Prosze sprobowac pozniej
159 (pt) Por favor volte mais tarde
164 $c->res->body( <<"" );
165 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
166 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
167 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
169 <meta http-equiv="Content-Language" content="en" />
170 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
171 <title>$title</title>
172 <script type="text/javascript">
174 function toggleDump (dumpElement) {
175 var e = document.getElementById( dumpElement );
176 if (e.style.display == "none") {
177 e.style.display = "";
180 e.style.display = "none";
185 <style type="text/css">
187 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
188 Tahoma, Arial, helvetica, sans-serif;
190 background-color: #eee;
194 :link, :link:hover, :visited, :visited:hover {
199 background-color: #ccc;
200 border: 1px solid #aaa;
205 background-color: #cce;
206 border: 1px solid #755;
212 background-color: #eee;
213 border: 1px solid #575;
219 background-color: #cce;
220 border: 1px solid #557;
229 div.name h1, div.error p {
237 text-decoration: underline;
243 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
244 /* Browser specific (not valid) styles to make preformatted text wrap */
246 white-space: pre-wrap; /* css-3 */
247 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
248 white-space: -pre-wrap; /* Opera 4-6 */
249 white-space: -o-pre-wrap; /* Opera 7 */
250 word-wrap: break-word; /* Internet Explorer 5.5+ */
256 <div class="error">$error</div>
257 <div class="infos">$infos</div>
258 <div class="name">$name</div>
265 $c->res->{body} .= ( ' ' x 512 );
268 $c->res->status(500);
271 =head2 $self->finalize_headers($c)
273 Abstract method, allows engines to write headers to response
277 sub finalize_headers { }
279 =head2 $self->finalize_read($c)
283 sub finalize_read { }
285 =head2 $self->finalize_uploads($c)
287 Clean up after uploads, deleting temp files.
291 sub finalize_uploads {
292 my ( $self, $c ) = @_;
294 my $request = $c->request;
295 foreach my $key (keys %{ $request->uploads }) {
296 my $upload = $request->uploads->{$key};
297 unlink grep { -e $_ } map { $_->tempname }
298 (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
303 =head2 $self->prepare_body($c)
305 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
310 my ( $self, $c ) = @_;
312 if ( my $length = $self->read_length ) {
313 my $request = $c->request;
314 unless ( $request->{_body} ) {
315 my $type = $request->header('Content-Type');
316 $request->{_body} = HTTP::Body->new( $type, $length );
317 $request->{_body}->tmpdir( $c->config->{uploadtmp} )
318 if exists $c->config->{uploadtmp};
321 while ( my $buffer = $self->read($c) ) {
322 $c->prepare_body_chunk($buffer);
325 # paranoia against wrong Content-Length header
326 my $remaining = $length - $self->read_position;
327 if ( $remaining > 0 ) {
328 $self->finalize_read($c);
329 Catalyst::Exception->throw(
330 "Wrong Content-Length value: $length" );
334 # Defined but will cause all body code to be skipped
335 $c->request->{_body} = 0;
339 =head2 $self->prepare_body_chunk($c)
341 Add a chunk to the request body.
345 sub prepare_body_chunk {
346 my ( $self, $c, $chunk ) = @_;
348 $c->request->{_body}->add($chunk);
351 =head2 $self->prepare_body_parameters($c)
353 Sets up parameters from body.
357 sub prepare_body_parameters {
358 my ( $self, $c ) = @_;
360 return unless $c->request->{_body};
362 $c->request->body_parameters( $c->request->{_body}->param );
365 =head2 $self->prepare_connection($c)
367 Abstract method implemented in engines.
371 sub prepare_connection { }
373 =head2 $self->prepare_cookies($c)
375 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
379 sub prepare_cookies {
380 my ( $self, $c ) = @_;
382 if ( my $header = $c->request->header('Cookie') ) {
383 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
387 =head2 $self->prepare_headers($c)
391 sub prepare_headers { }
393 =head2 $self->prepare_parameters($c)
395 sets up parameters from query and post parameters.
399 sub prepare_parameters {
400 my ( $self, $c ) = @_;
402 my $request = $c->request;
403 my $parameters = $request->parameters;
404 my $body_parameters = $request->body_parameters;
405 my $query_parameters = $request->query_parameters;
406 # We copy, no references
407 foreach my $name (keys %$query_parameters) {
408 my $param = $query_parameters->{$name};
409 $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
412 # Merge query and body parameters
413 foreach my $name (keys %$body_parameters) {
414 my $param = $body_parameters->{$name};
415 my @values = ref $param eq 'ARRAY' ? @$param : ($param);
416 if ( my $existing = $parameters->{$name} ) {
417 unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
419 $parameters->{$name} = @values > 1 ? \@values : $values[0];
423 =head2 $self->prepare_path($c)
425 abstract method, implemented by engines.
431 =head2 $self->prepare_request($c)
433 =head2 $self->prepare_query_parameters($c)
435 process the query string and extract query parameters.
439 sub prepare_query_parameters {
440 my ( $self, $c, $query_string ) = @_;
442 # Check for keywords (no = signs)
443 # (yes, index() is faster than a regex :))
444 if ( index( $query_string, '=' ) < 0 ) {
445 $c->request->query_keywords( $self->unescape_uri($query_string) );
451 # replace semi-colons
452 $query_string =~ s/;/&/g;
454 my @params = grep { length $_ } split /&/, $query_string;
456 for my $item ( @params ) {
459 = map { $self->unescape_uri($_) }
460 split( /=/, $item, 2 );
462 $param = $self->unescape_uri($item) unless defined $param;
464 if ( exists $query{$param} ) {
465 if ( ref $query{$param} ) {
466 push @{ $query{$param} }, $value;
469 $query{$param} = [ $query{$param}, $value ];
473 $query{$param} = $value;
477 $c->request->query_parameters( \%query );
480 =head2 $self->prepare_read($c)
482 prepare to read from the engine.
487 my ( $self, $c ) = @_;
489 # Initialize the read position
490 $self->read_position(0);
492 # Initialize the amount of data we think we need to read
493 $self->read_length( $c->request->header('Content-Length') || 0 );
496 =head2 $self->prepare_request(@arguments)
498 Populate the context object from the request object.
502 sub prepare_request { }
504 =head2 $self->prepare_uploads($c)
508 sub prepare_uploads {
509 my ( $self, $c ) = @_;
511 my $request = $c->request;
512 return unless $request->{_body};
514 my $uploads = $request->{_body}->upload;
515 my $parameters = $request->parameters;
516 foreach my $name (keys %$uploads) {
517 my $files = $uploads->{$name};
519 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
520 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
521 my $u = Catalyst::Request::Upload->new
523 size => $upload->{size},
524 type => $headers->content_type,
526 tempname => $upload->{tempname},
527 filename => $upload->{filename},
531 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
533 # support access to the filename as a normal param
534 my @filenames = map { $_->{filename} } @uploads;
535 # append, if there's already params with this name
536 if (exists $parameters->{$name}) {
537 if (ref $parameters->{$name} eq 'ARRAY') {
538 push @{ $parameters->{$name} }, @filenames;
541 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
545 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
550 =head2 $self->prepare_write($c)
552 Abstract method. Implemented by the engines.
556 sub prepare_write { }
558 =head2 $self->read($c, [$maxlength])
563 my ( $self, $c, $maxlength ) = @_;
565 my $remaining = $self->read_length - $self->read_position;
566 $maxlength ||= $CHUNKSIZE;
568 # Are we done reading?
569 if ( $remaining <= 0 ) {
570 $self->finalize_read($c);
574 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
575 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
577 $self->read_position( $self->read_position + $rc );
581 Catalyst::Exception->throw(
582 message => "Unknown error reading input: $!" );
586 =head2 $self->read_chunk($c, $buffer, $length)
588 Each engine inplements read_chunk as its preferred way of reading a chunk
595 =head2 $self->read_length
597 The length of input data to be read. This is obtained from the Content-Length
600 =head2 $self->read_position
602 The amount of input data that has already been read.
604 =head2 $self->run($c)
606 Start the engine. Implemented by the various engine classes.
612 =head2 $self->write($c, $buffer)
614 Writes the buffer to the client.
619 my ( $self, $c, $buffer ) = @_;
621 unless ( $self->{_prepared_write} ) {
622 $self->prepare_write($c);
623 $self->{_prepared_write} = 1;
626 return 0 if !defined $buffer;
628 my $len = length($buffer);
629 my $wrote = syswrite STDOUT, $buffer;
631 if ( !defined $wrote && $! == EWOULDBLOCK ) {
632 # Unable to write on the first try, will retry in the loop below
636 if ( defined $wrote && $wrote < $len ) {
637 # We didn't write the whole buffer
639 my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
640 if ( defined $ret ) {
644 next if $! == EWOULDBLOCK;
648 last if $wrote >= $len;
655 =head2 $self->unescape_uri($uri)
657 Unescapes a given URI using the most efficient method available. Engines such
658 as Apache may implement this using Apache's C-based modules, for example.
663 my ( $self, $str ) = @_;
665 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
670 =head2 $self->finalize_output
672 <obsolete>, see finalize_body
676 Catalyst Contributors, see Catalyst.pm
680 This program is free software, you can redistribute it and/or modify it under
681 the same terms as Perl itself.