1 package Catalyst::Engine;
4 use base 'Class::Accessor::Fast';
5 use CGI::Simple::Cookie;
6 use Data::Dump qw/dump/;
13 # input position and length
14 __PACKAGE__->mk_accessors(qw/read_position read_length/);
17 use overload '""' => sub { return ref shift }, fallback => 1;
19 # Amount of data to read from input on each pass
20 our $CHUNKSIZE = 64 * 1024;
24 Catalyst::Engine - The Catalyst Engine
35 =head2 $self->finalize_body($c)
37 Finalize body. Prints the response output.
42 my ( $self, $c ) = @_;
43 my $body = $c->response->body;
44 no warnings 'uninitialized';
45 if ( Scalar::Util::blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
46 while ( !eof $body ) {
47 read $body, my ($buffer), $CHUNKSIZE;
48 last unless $self->write( $c, $buffer );
53 $self->write( $c, $body );
57 =head2 $self->finalize_cookies($c)
59 Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
64 sub finalize_cookies {
65 my ( $self, $c ) = @_;
69 foreach my $name ( keys %{ $c->response->cookies } ) {
71 my $val = $c->response->cookies->{$name};
74 Scalar::Util::blessed($val)
76 : CGI::Simple::Cookie->new(
78 -value => $val->{value},
79 -expires => $val->{expires},
80 -domain => $val->{domain},
81 -path => $val->{path},
82 -secure => $val->{secure} || 0
86 push @cookies, $cookie->as_string;
89 for my $cookie (@cookies) {
90 $c->res->headers->push_header( 'Set-Cookie' => $cookie );
94 =head2 $self->finalize_error($c)
96 Output an apropriate error message, called if there's an error in $c
97 after the dispatch has finished. Will output debug messages if Catalyst
98 is in debug mode, or a `please come back later` message otherwise.
103 my ( $self, $c ) = @_;
105 $c->res->content_type('text/html; charset=utf-8');
106 my $name = $c->config->{name} || join(' ', split('::', ref $c));
108 my ( $title, $error, $infos );
112 $error = join '', map {
113 '<p><code class="error">'
114 . encode_entities($_)
117 $error ||= 'No output';
118 $error = qq{<pre wrap="">$error</pre>};
119 $title = $name = "$name on Catalyst $Catalyst::VERSION";
120 $name = "<h1>$name</h1>";
122 # Don't show context in the dump
123 delete $c->req->{_context};
124 delete $c->res->{_context};
126 # Don't show body parser in the dump
127 delete $c->req->{_body};
129 # Don't show response header state in dump
130 delete $c->res->{_finalized_headers};
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)
283 my ( $self, $c ) = @_;
285 undef $self->{_prepared_read};
288 =head2 $self->finalize_uploads($c)
290 Clean up after uploads, deleting temp files.
294 sub finalize_uploads {
295 my ( $self, $c ) = @_;
297 if ( keys %{ $c->request->uploads } ) {
298 for my $key ( keys %{ $c->request->uploads } ) {
299 my $upload = $c->request->uploads->{$key};
300 unlink map { $_->tempname }
301 grep { -e $_->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 my $length = $c->request->header('Content-Length') || 0;
318 $self->read_length( $length );
321 unless ( $c->request->{_body} ) {
322 my $type = $c->request->header('Content-Type');
323 $c->request->{_body} = HTTP::Body->new( $type, $length );
324 $c->request->{_body}->{tmpdir} = $c->config->{uploadtmp}
325 if exists $c->config->{uploadtmp};
328 while ( my $buffer = $self->read($c) ) {
329 $c->prepare_body_chunk($buffer);
332 # paranoia against wrong Content-Length header
333 my $remaining = $length - $self->read_position;
334 if ( $remaining > 0 ) {
335 $self->finalize_read($c);
336 Catalyst::Exception->throw(
337 "Wrong Content-Length value: $length" );
341 # Defined but will cause all body code to be skipped
342 $c->request->{_body} = 0;
346 =head2 $self->prepare_body_chunk($c)
348 Add a chunk to the request body.
352 sub prepare_body_chunk {
353 my ( $self, $c, $chunk ) = @_;
355 $c->request->{_body}->add($chunk);
358 =head2 $self->prepare_body_parameters($c)
360 Sets up parameters from body.
364 sub prepare_body_parameters {
365 my ( $self, $c ) = @_;
367 return unless $c->request->{_body};
369 $c->request->body_parameters( $c->request->{_body}->param );
372 =head2 $self->prepare_connection($c)
374 Abstract method implemented in engines.
378 sub prepare_connection { }
380 =head2 $self->prepare_cookies($c)
382 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
386 sub prepare_cookies {
387 my ( $self, $c ) = @_;
389 if ( my $header = $c->request->header('Cookie') ) {
390 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
394 =head2 $self->prepare_headers($c)
398 sub prepare_headers { }
400 =head2 $self->prepare_parameters($c)
402 sets up parameters from query and post parameters.
406 sub prepare_parameters {
407 my ( $self, $c ) = @_;
409 # We copy, no references
410 foreach my $name ( keys %{ $c->request->query_parameters } ) {
411 my $param = $c->request->query_parameters->{$name};
412 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
413 $c->request->parameters->{$name} = $param;
416 # Merge query and body parameters
417 foreach my $name ( keys %{ $c->request->body_parameters } ) {
418 my $param = $c->request->body_parameters->{$name};
419 $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
420 if ( my $old_param = $c->request->parameters->{$name} ) {
421 if ( ref $old_param eq 'ARRAY' ) {
422 push @{ $c->request->parameters->{$name} },
423 ref $param eq 'ARRAY' ? @$param : $param;
425 else { $c->request->parameters->{$name} = [ $old_param, $param ] }
427 else { $c->request->parameters->{$name} = $param }
431 =head2 $self->prepare_path($c)
433 abstract method, implemented by engines.
439 =head2 $self->prepare_request($c)
441 =head2 $self->prepare_query_parameters($c)
443 process the query string and extract query parameters.
447 sub prepare_query_parameters {
448 my ( $self, $c, $query_string ) = @_;
450 # Check for keywords (no = signs)
451 # (yes, index() is faster than a regex :))
452 if ( index( $query_string, '=' ) < 0 ) {
453 $c->request->query_keywords( $self->unescape_uri($query_string) );
459 # replace semi-colons
460 $query_string =~ s/;/&/g;
462 my @params = split /&/, $query_string;
464 for my $item ( @params ) {
467 = map { $self->unescape_uri($_) }
470 $param = $self->unescape_uri($item) unless defined $param;
472 if ( exists $query{$param} ) {
473 if ( ref $query{$param} ) {
474 push @{ $query{$param} }, $value;
477 $query{$param} = [ $query{$param}, $value ];
481 $query{$param} = $value;
485 $c->request->query_parameters( \%query );
488 =head2 $self->prepare_read($c)
490 prepare to read from the engine.
495 my ( $self, $c ) = @_;
497 # Reset the read position
498 $self->read_position(0);
501 =head2 $self->prepare_request(@arguments)
503 Populate the context object from the request object.
507 sub prepare_request { }
509 =head2 $self->prepare_uploads($c)
513 sub prepare_uploads {
514 my ( $self, $c ) = @_;
516 return unless $c->request->{_body};
518 my $uploads = $c->request->{_body}->upload;
519 for my $name ( keys %$uploads ) {
520 my $files = $uploads->{$name};
521 $files = ref $files eq 'ARRAY' ? $files : [$files];
523 for my $upload (@$files) {
524 my $u = Catalyst::Request::Upload->new;
525 $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
526 $u->type( $u->headers->content_type );
527 $u->tempname( $upload->{tempname} );
528 $u->size( $upload->{size} );
529 $u->filename( $upload->{filename} );
532 $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
534 # support access to the filename as a normal param
535 my @filenames = map { $_->{filename} } @uploads;
536 # append, if there's already params with this name
537 if (exists $c->request->parameters->{$name}) {
538 if (ref $c->request->parameters->{$name} eq 'ARRAY') {
539 push @{ $c->request->parameters->{$name} }, @filenames;
542 $c->request->parameters->{$name} =
543 [ $c->request->parameters->{$name}, @filenames ];
547 $c->request->parameters->{$name} =
548 @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 unless ( $self->{_prepared_read} ) {
569 $self->prepare_read($c);
570 $self->{_prepared_read} = 1;
573 my $remaining = $self->read_length - $self->read_position;
574 $maxlength ||= $CHUNKSIZE;
576 # Are we done reading?
577 if ( $remaining <= 0 ) {
578 $self->finalize_read($c);
582 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
583 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
585 $self->read_position( $self->read_position + $rc );
589 Catalyst::Exception->throw(
590 message => "Unknown error reading input: $!" );
594 =head2 $self->read_chunk($c, $buffer, $length)
596 Each engine inplements read_chunk as its preferred way of reading a chunk
603 =head2 $self->read_length
605 The length of input data to be read. This is obtained from the Content-Length
608 =head2 $self->read_position
610 The amount of input data that has already been read.
612 =head2 $self->run($c)
614 Start the engine. Implemented by the various engine classes.
620 =head2 $self->write($c, $buffer)
622 Writes the buffer to the client. Can only be called once for a request.
627 my ( $self, $c, $buffer ) = @_;
629 unless ( $self->{_prepared_write} ) {
630 $self->prepare_write($c);
631 $self->{_prepared_write} = 1;
634 print STDOUT $buffer;
637 =head2 $self->unescape_uri($uri)
639 Unescapes a given URI using the most efficient method available. Engines such
640 as Apache may implement this using Apache's C-based modules, for example.
645 my ( $self, $str ) = @_;
647 $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
653 =head2 $self->finalize_output
655 <obsolete>, see finalize_body
659 Sebastian Riedel, <sri@cpan.org>
661 Andy Grundman, <andy@hybridized.org>
665 This program is free software, you can redistribute it and/or modify it under
666 the same terms as Perl itself.