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 apropriate 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
163 $c->res->body( <<"" );
164 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
165 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
166 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
168 <meta http-equiv="Content-Language" content="en" />
169 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
170 <title>$title</title>
171 <script type="text/javascript">
173 function toggleDump (dumpElement) {
174 var e = document.getElementById( dumpElement );
175 if (e.style.display == "none") {
176 e.style.display = "";
179 e.style.display = "none";
184 <style type="text/css">
186 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
187 Tahoma, Arial, helvetica, sans-serif;
189 background-color: #eee;
193 :link, :link:hover, :visited, :visited:hover {
198 background-color: #ccc;
199 border: 1px solid #aaa;
204 background-color: #cce;
205 border: 1px solid #755;
211 background-color: #eee;
212 border: 1px solid #575;
218 background-color: #cce;
219 border: 1px solid #557;
228 div.name h1, div.error p {
236 text-decoration: underline;
242 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
243 /* Browser specific (not valid) styles to make preformatted text wrap */
245 white-space: pre-wrap; /* css-3 */
246 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
247 white-space: -pre-wrap; /* Opera 4-6 */
248 white-space: -o-pre-wrap; /* Opera 7 */
249 word-wrap: break-word; /* Internet Explorer 5.5+ */
255 <div class="error">$error</div>
256 <div class="infos">$infos</div>
257 <div class="name">$name</div>
264 $c->res->{body} .= ( ' ' x 512 );
267 $c->res->status(500);
270 =head2 $self->finalize_headers($c)
272 Abstract method, allows engines to write headers to response
276 sub finalize_headers { }
278 =head2 $self->finalize_read($c)
282 sub finalize_read { }
284 =head2 $self->finalize_uploads($c)
286 Clean up after uploads, deleting temp files.
290 sub finalize_uploads {
291 my ( $self, $c ) = @_;
293 my $request = $c->request;
294 foreach my $key (keys %{ $request->uploads }) {
295 my $upload = $request->uploads->{$key};
296 unlink grep { -e $_ } map { $_->tempname }
297 (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
302 =head2 $self->prepare_body($c)
304 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
309 my ( $self, $c ) = @_;
311 if ( my $length = $self->read_length ) {
312 my $request = $c->request;
313 unless ( $request->{_body} ) {
314 my $type = $request->header('Content-Type');
315 $request->{_body} = HTTP::Body->new( $type, $length );
316 $request->{_body}->{tmpdir} = $c->config->{uploadtmp}
317 if exists $c->config->{uploadtmp};
320 while ( my $buffer = $self->read($c) ) {
321 $c->prepare_body_chunk($buffer);
324 # paranoia against wrong Content-Length header
325 my $remaining = $length - $self->read_position;
326 if ( $remaining > 0 ) {
327 $self->finalize_read($c);
328 Catalyst::Exception->throw(
329 "Wrong Content-Length value: $length" );
333 # Defined but will cause all body code to be skipped
334 $c->request->{_body} = 0;
338 =head2 $self->prepare_body_chunk($c)
340 Add a chunk to the request body.
344 sub prepare_body_chunk {
345 my ( $self, $c, $chunk ) = @_;
347 $c->request->{_body}->add($chunk);
350 =head2 $self->prepare_body_parameters($c)
352 Sets up parameters from body.
356 sub prepare_body_parameters {
357 my ( $self, $c ) = @_;
359 return unless $c->request->{_body};
361 $c->request->body_parameters( $c->request->{_body}->param );
364 =head2 $self->prepare_connection($c)
366 Abstract method implemented in engines.
370 sub prepare_connection { }
372 =head2 $self->prepare_cookies($c)
374 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
378 sub prepare_cookies {
379 my ( $self, $c ) = @_;
381 if ( my $header = $c->request->header('Cookie') ) {
382 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
386 =head2 $self->prepare_headers($c)
390 sub prepare_headers { }
392 =head2 $self->prepare_parameters($c)
394 sets up parameters from query and post parameters.
398 sub prepare_parameters {
399 my ( $self, $c ) = @_;
401 my $request = $c->request;
402 my $parameters = $request->parameters;
403 my $body_parameters = $request->body_parameters;
404 my $query_parameters = $request->query_parameters;
405 # We copy, no references
406 foreach my $name (keys %$query_parameters) {
407 my $param = $query_parameters->{$name};
408 $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
411 # Merge query and body parameters
412 foreach my $name (keys %$body_parameters) {
413 my $param = $body_parameters->{$name};
414 my @values = ref $param eq 'ARRAY' ? @$param : ($param);
415 if ( my $existing = $parameters->{$name} ) {
416 unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
418 $parameters->{$name} = @values > 1 ? \@values : $values[0];
422 =head2 $self->prepare_path($c)
424 abstract method, implemented by engines.
430 =head2 $self->prepare_request($c)
432 =head2 $self->prepare_query_parameters($c)
434 process the query string and extract query parameters.
438 sub prepare_query_parameters {
439 my ( $self, $c, $query_string ) = @_;
441 # Check for keywords (no = signs)
442 # (yes, index() is faster than a regex :))
443 if ( index( $query_string, '=' ) < 0 ) {
444 $c->request->query_keywords( $self->unescape_uri($query_string) );
450 # replace semi-colons
451 $query_string =~ s/;/&/g;
453 my @params = split /&/, $query_string;
455 for my $item ( @params ) {
458 = map { $self->unescape_uri($_) }
459 split( /=/, $item, 2 );
461 $param = $self->unescape_uri($item) unless defined $param;
463 if ( exists $query{$param} ) {
464 if ( ref $query{$param} ) {
465 push @{ $query{$param} }, $value;
468 $query{$param} = [ $query{$param}, $value ];
472 $query{$param} = $value;
476 $c->request->query_parameters( \%query );
479 =head2 $self->prepare_read($c)
481 prepare to read from the engine.
486 my ( $self, $c ) = @_;
488 # Initialize the read position
489 $self->read_position(0);
491 # Initialize the amount of data we think we need to read
492 $self->read_length( $c->request->header('Content-Length') || 0 );
495 =head2 $self->prepare_request(@arguments)
497 Populate the context object from the request object.
501 sub prepare_request { }
503 =head2 $self->prepare_uploads($c)
507 sub prepare_uploads {
508 my ( $self, $c ) = @_;
510 my $request = $c->request;
511 return unless $request->{_body};
513 my $uploads = $request->{_body}->upload;
514 my $parameters = $request->parameters;
515 foreach my $name (keys %$uploads) {
516 my $files = $uploads->{$name};
518 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
519 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
520 my $u = Catalyst::Request::Upload->new
522 size => $upload->{size},
523 type => $headers->content_type,
525 tempname => $upload->{tempname},
526 filename => $upload->{filename},
530 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
532 # support access to the filename as a normal param
533 my @filenames = map { $_->{filename} } @uploads;
534 # append, if there's already params with this name
535 if (exists $parameters->{$name}) {
536 if (ref $parameters->{$name} eq 'ARRAY') {
537 push @{ $parameters->{$name} }, @filenames;
540 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
544 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
549 =head2 $self->prepare_write($c)
551 Abstract method. Implemented by the engines.
555 sub prepare_write { }
557 =head2 $self->read($c, [$maxlength])
562 my ( $self, $c, $maxlength ) = @_;
564 my $remaining = $self->read_length - $self->read_position;
565 $maxlength ||= $CHUNKSIZE;
567 # Are we done reading?
568 if ( $remaining <= 0 ) {
569 $self->finalize_read($c);
573 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
574 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
576 $self->read_position( $self->read_position + $rc );
580 Catalyst::Exception->throw(
581 message => "Unknown error reading input: $!" );
585 =head2 $self->read_chunk($c, $buffer, $length)
587 Each engine inplements read_chunk as its preferred way of reading a chunk
594 =head2 $self->read_length
596 The length of input data to be read. This is obtained from the Content-Length
599 =head2 $self->read_position
601 The amount of input data that has already been read.
603 =head2 $self->run($c)
605 Start the engine. Implemented by the various engine classes.
611 =head2 $self->write($c, $buffer)
613 Writes the buffer to the client.
618 my ( $self, $c, $buffer ) = @_;
620 unless ( $self->{_prepared_write} ) {
621 $self->prepare_write($c);
622 $self->{_prepared_write} = 1;
625 my $len = length($buffer);
626 my $wrote = syswrite STDOUT, $buffer;
628 if ( !defined $wrote && $! == EWOULDBLOCK ) {
629 # Unable to write on the first try, will retry in the loop below
633 if ( defined $wrote && $wrote < $len ) {
634 # We didn't write the whole buffer
636 my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
637 if ( defined $ret ) {
641 next if $! == EWOULDBLOCK;
645 last if $wrote >= $len;
652 =head2 $self->unescape_uri($uri)
654 Unescapes a given URI using the most efficient method available. Engines such
655 as Apache may implement this using Apache's C-based modules, for example.
660 my ( $self, $str ) = @_;
662 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
667 =head2 $self->finalize_output
669 <obsolete>, see finalize_body
673 Sebastian Riedel, <sri@cpan.org>
675 Andy Grundman, <andy@hybridized.org>
679 This program is free software, you can redistribute it and/or modify it under
680 the same terms as Perl itself.