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');
20 use overload '""' => sub { return ref shift }, fallback => 1;
22 # Amount of data to read from input on each pass
23 our $CHUNKSIZE = 64 * 1024;
27 Catalyst::Engine - The Catalyst Engine
38 =head2 $self->finalize_body($c)
40 Finalize body. Prints the response output.
45 my ( $self, $c ) = @_;
46 my $body = $c->response->body;
47 no warnings 'uninitialized';
48 if ( Scalar::Util::blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
49 while ( !eof $body ) {
50 read $body, my ($buffer), $CHUNKSIZE;
51 last unless $self->write( $c, $buffer );
56 $self->write( $c, $body );
60 =head2 $self->finalize_cookies($c)
62 Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
67 sub finalize_cookies {
68 my ( $self, $c ) = @_;
71 my $response = $c->response;
73 foreach my $name (keys %{ $response->cookies }) {
75 my $val = $response->cookies->{$name};
78 Scalar::Util::blessed($val)
80 : CGI::Simple::Cookie->new(
82 -value => $val->{value},
83 -expires => $val->{expires},
84 -domain => $val->{domain},
85 -path => $val->{path},
86 -secure => $val->{secure} || 0
90 push @cookies, $cookie->as_string;
93 for my $cookie (@cookies) {
94 $response->headers->push_header( 'Set-Cookie' => $cookie );
98 =head2 $self->finalize_error($c)
100 Output an apropriate error message, called if there's an error in $c
101 after the dispatch has finished. Will output debug messages if Catalyst
102 is in debug mode, or a `please come back later` message otherwise.
107 my ( $self, $c ) = @_;
109 $c->res->content_type('text/html; charset=utf-8');
110 my $name = $c->config->{name} || join(' ', split('::', ref $c));
112 my ( $title, $error, $infos );
116 $error = join '', map {
117 '<p><code class="error">'
118 . encode_entities($_)
121 $error ||= 'No output';
122 $error = qq{<pre wrap="">$error</pre>};
123 $title = $name = "$name on Catalyst $Catalyst::VERSION";
124 $name = "<h1>$name</h1>";
126 # Don't show context in the dump
127 delete $c->req->{_context};
128 delete $c->res->{_context};
130 # Don't show body parser in the dump
131 delete $c->req->{_body};
133 # Don't show response header state in dump
134 delete $c->res->{_finalized_headers};
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
167 $c->res->body( <<"" );
168 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
169 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
170 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
172 <meta http-equiv="Content-Language" content="en" />
173 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
174 <title>$title</title>
175 <script type="text/javascript">
177 function toggleDump (dumpElement) {
178 var e = document.getElementById( dumpElement );
179 if (e.style.display == "none") {
180 e.style.display = "";
183 e.style.display = "none";
188 <style type="text/css">
190 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
191 Tahoma, Arial, helvetica, sans-serif;
193 background-color: #eee;
197 :link, :link:hover, :visited, :visited:hover {
202 background-color: #ccc;
203 border: 1px solid #aaa;
208 background-color: #cce;
209 border: 1px solid #755;
215 background-color: #eee;
216 border: 1px solid #575;
222 background-color: #cce;
223 border: 1px solid #557;
232 div.name h1, div.error p {
240 text-decoration: underline;
246 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
247 /* Browser specific (not valid) styles to make preformatted text wrap */
249 white-space: pre-wrap; /* css-3 */
250 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
251 white-space: -pre-wrap; /* Opera 4-6 */
252 white-space: -o-pre-wrap; /* Opera 7 */
253 word-wrap: break-word; /* Internet Explorer 5.5+ */
259 <div class="error">$error</div>
260 <div class="infos">$infos</div>
261 <div class="name">$name</div>
268 $c->res->{body} .= ( ' ' x 512 );
271 $c->res->status(500);
274 =head2 $self->finalize_headers($c)
276 Abstract method, allows engines to write headers to response
280 sub finalize_headers { }
282 =head2 $self->finalize_read($c)
286 sub finalize_read { }
288 =head2 $self->finalize_uploads($c)
290 Clean up after uploads, deleting temp files.
294 sub finalize_uploads {
295 my ( $self, $c ) = @_;
297 my $request = $c->request;
298 foreach my $key (keys %{ $request->uploads }) {
299 my $upload = $request->uploads->{$key};
300 unlink grep { -e $_ } map { $_->tempname }
301 (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
306 =head2 $self->prepare_body($c)
308 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
313 my ( $self, $c ) = @_;
315 if ( my $length = $self->read_length ) {
316 my $request = $c->request;
317 unless ( $request->{_body} ) {
318 my $type = $request->header('Content-Type');
319 $request->{_body} = HTTP::Body->new( $type, $length );
320 $request->{_body}->{tmpdir} = $c->config->{uploadtmp}
321 if exists $c->config->{uploadtmp};
324 while ( my $buffer = $self->read($c) ) {
325 $c->prepare_body_chunk($buffer);
328 # paranoia against wrong Content-Length header
329 my $remaining = $length - $self->read_position;
330 if ( $remaining > 0 ) {
331 $self->finalize_read($c);
332 Catalyst::Exception->throw(
333 "Wrong Content-Length value: $length" );
337 # Defined but will cause all body code to be skipped
338 $c->request->{_body} = 0;
342 =head2 $self->prepare_body_chunk($c)
344 Add a chunk to the request body.
348 sub prepare_body_chunk {
349 my ( $self, $c, $chunk ) = @_;
351 $c->request->{_body}->add($chunk);
354 =head2 $self->prepare_body_parameters($c)
356 Sets up parameters from body.
360 sub prepare_body_parameters {
361 my ( $self, $c ) = @_;
363 return unless $c->request->{_body};
365 $c->request->body_parameters( $c->request->{_body}->param );
368 =head2 $self->prepare_connection($c)
370 Abstract method implemented in engines.
374 sub prepare_connection { }
376 =head2 $self->prepare_cookies($c)
378 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
382 sub prepare_cookies {
383 my ( $self, $c ) = @_;
385 if ( my $header = $c->request->header('Cookie') ) {
386 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
390 =head2 $self->prepare_headers($c)
394 sub prepare_headers { }
396 =head2 $self->prepare_parameters($c)
398 sets up parameters from query and post parameters.
402 sub prepare_parameters {
403 my ( $self, $c ) = @_;
405 my $request = $c->request;
406 my $parameters = $request->parameters;
407 my $body_parameters = $request->body_parameters;
408 my $query_parameters = $request->query_parameters;
409 # We copy, no references
410 foreach my $name (keys %$query_parameters) {
411 my $param = $query_parameters->{$name};
412 $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
415 # Merge query and body parameters
416 foreach my $name (keys %$body_parameters) {
417 my $param = $body_parameters->{$name};
418 my @values = ref $param eq 'ARRAY' ? @$param : ($param);
419 if ( my $existing = $parameters->{$name} ) {
420 unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
422 $parameters->{$name} = @values > 1 ? \@values : $values[0];
426 =head2 $self->prepare_path($c)
428 abstract method, implemented by engines.
434 =head2 $self->prepare_request($c)
436 =head2 $self->prepare_query_parameters($c)
438 process the query string and extract query parameters.
442 sub prepare_query_parameters {
443 my ( $self, $c, $query_string ) = @_;
445 # Check for keywords (no = signs)
446 # (yes, index() is faster than a regex :))
447 if ( index( $query_string, '=' ) < 0 ) {
448 $c->request->query_keywords( $self->unescape_uri($query_string) );
454 # replace semi-colons
455 $query_string =~ s/;/&/g;
457 my @params = split /&/, $query_string;
459 for my $item ( @params ) {
462 = map { $self->unescape_uri($_) }
463 split( /=/, $item, 2 );
465 $param = $self->unescape_uri($item) unless defined $param;
467 if ( exists $query{$param} ) {
468 if ( ref $query{$param} ) {
469 push @{ $query{$param} }, $value;
472 $query{$param} = [ $query{$param}, $value ];
476 $query{$param} = $value;
480 $c->request->query_parameters( \%query );
483 =head2 $self->prepare_read($c)
485 prepare to read from the engine.
490 my ( $self, $c ) = @_;
492 # Initialize the read position
493 $self->read_position(0);
495 # Initialize the amount of data we think we need to read
496 $self->read_length( $c->request->header('Content-Length') || 0 );
499 =head2 $self->prepare_request(@arguments)
501 Populate the context object from the request object.
505 sub prepare_request { }
507 =head2 $self->prepare_uploads($c)
511 sub prepare_uploads {
512 my ( $self, $c ) = @_;
514 my $request = $c->request;
515 return unless $request->{_body};
517 my $uploads = $request->{_body}->upload;
518 my $parameters = $request->parameters;
519 foreach my $name (keys %$uploads) {
520 my $files = $uploads->{$name};
522 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
523 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
524 my $u = Catalyst::Request::Upload->new
526 size => $upload->{size},
527 type => $headers->content_type,
529 tempname => $upload->{tempname},
530 filename => $upload->{filename},
534 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
536 # support access to the filename as a normal param
537 my @filenames = map { $_->{filename} } @uploads;
538 # append, if there's already params with this name
539 if (exists $parameters->{$name}) {
540 if (ref $parameters->{$name} eq 'ARRAY') {
541 push @{ $parameters->{$name} }, @filenames;
544 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
548 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
553 =head2 $self->prepare_write($c)
555 Abstract method. Implemented by the engines.
559 sub prepare_write { }
561 =head2 $self->read($c, [$maxlength])
566 my ( $self, $c, $maxlength ) = @_;
568 my $remaining = $self->read_length - $self->read_position;
569 $maxlength ||= $CHUNKSIZE;
571 # Are we done reading?
572 if ( $remaining <= 0 ) {
573 $self->finalize_read($c);
577 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
578 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
580 $self->read_position( $self->read_position + $rc );
584 Catalyst::Exception->throw(
585 message => "Unknown error reading input: $!" );
589 =head2 $self->read_chunk($c, $buffer, $length)
591 Each engine inplements read_chunk as its preferred way of reading a chunk
598 =head2 $self->read_length
600 The length of input data to be read. This is obtained from the Content-Length
603 =head2 $self->read_position
605 The amount of input data that has already been read.
607 =head2 $self->run($c)
609 Start the engine. Implemented by the various engine classes.
615 =head2 $self->write($c, $buffer)
617 Writes the buffer to the client.
622 my ( $self, $c, $buffer ) = @_;
624 unless ( $self->{_prepared_write} ) {
625 $self->prepare_write($c);
626 $self->{_prepared_write} = 1;
629 my $len = length($buffer);
630 my $wrote = syswrite STDOUT, $buffer;
632 if ( !defined $wrote && $! == EWOULDBLOCK ) {
633 # Unable to write on the first try, will retry in the loop below
637 if ( defined $wrote && $wrote < $len ) {
638 # We didn't write the whole buffer
640 my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
641 if ( defined $ret ) {
645 next if $! == EWOULDBLOCK;
649 last if $wrote >= $len;
656 =head2 $self->unescape_uri($uri)
658 Unescapes a given URI using the most efficient method available. Engines such
659 as Apache may implement this using Apache's C-based modules, for example.
664 my ( $self, $str ) = @_;
666 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
671 =head2 $self->finalize_output
673 <obsolete>, see finalize_body
677 Sebastian Riedel, <sri@cpan.org>
679 Andy Grundman, <andy@hybridized.org>
683 This program is free software, you can redistribute it and/or modify it under
684 the same terms as Perl itself.