1 package Catalyst::Engine;
6 with 'MooseX::Emulate::Class::Accessor::Fast';
8 use CGI::Simple::Cookie;
9 use Data::Dump qw/dump/;
10 use Errno 'EWOULDBLOCK';
17 # input position and length
18 has read_length => (is => 'rw');
19 has read_position => (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 apropriate 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 delete $c->req->{_context};
129 delete $c->res->{_context};
131 # Don't show body parser in the dump
132 delete $c->req->{_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
165 $c->res->body( <<"" );
166 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
167 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
168 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
170 <meta http-equiv="Content-Language" content="en" />
171 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
172 <title>$title</title>
173 <script type="text/javascript">
175 function toggleDump (dumpElement) {
176 var e = document.getElementById( dumpElement );
177 if (e.style.display == "none") {
178 e.style.display = "";
181 e.style.display = "none";
186 <style type="text/css">
188 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
189 Tahoma, Arial, helvetica, sans-serif;
191 background-color: #eee;
195 :link, :link:hover, :visited, :visited:hover {
200 background-color: #ccc;
201 border: 1px solid #aaa;
206 background-color: #cce;
207 border: 1px solid #755;
213 background-color: #eee;
214 border: 1px solid #575;
220 background-color: #cce;
221 border: 1px solid #557;
230 div.name h1, div.error p {
238 text-decoration: underline;
244 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
245 /* Browser specific (not valid) styles to make preformatted text wrap */
247 white-space: pre-wrap; /* css-3 */
248 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
249 white-space: -pre-wrap; /* Opera 4-6 */
250 white-space: -o-pre-wrap; /* Opera 7 */
251 word-wrap: break-word; /* Internet Explorer 5.5+ */
257 <div class="error">$error</div>
258 <div class="infos">$infos</div>
259 <div class="name">$name</div>
266 $c->res->{body} .= ( ' ' x 512 );
269 $c->res->status(500);
272 =head2 $self->finalize_headers($c)
274 Abstract method, allows engines to write headers to response
278 sub finalize_headers { }
280 =head2 $self->finalize_read($c)
284 sub finalize_read { }
286 =head2 $self->finalize_uploads($c)
288 Clean up after uploads, deleting temp files.
292 sub finalize_uploads {
293 my ( $self, $c ) = @_;
295 my $request = $c->request;
296 foreach my $key (keys %{ $request->uploads }) {
297 my $upload = $request->uploads->{$key};
298 unlink grep { -e $_ } map { $_->tempname }
299 (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
304 =head2 $self->prepare_body($c)
306 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
311 my ( $self, $c ) = @_;
313 if ( my $length = $self->read_length ) {
314 my $request = $c->request;
315 unless ( $request->{_body} ) {
316 my $type = $request->header('Content-Type');
317 $request->{_body} = HTTP::Body->new( $type, $length );
318 $request->{_body}->{tmpdir} = $c->config->{uploadtmp}
319 if exists $c->config->{uploadtmp};
322 while ( my $buffer = $self->read($c) ) {
323 $c->prepare_body_chunk($buffer);
326 # paranoia against wrong Content-Length header
327 my $remaining = $length - $self->read_position;
328 if ( $remaining > 0 ) {
329 $self->finalize_read($c);
330 Catalyst::Exception->throw(
331 "Wrong Content-Length value: $length" );
335 # Defined but will cause all body code to be skipped
336 $c->request->{_body} = 0;
340 =head2 $self->prepare_body_chunk($c)
342 Add a chunk to the request body.
346 sub prepare_body_chunk {
347 my ( $self, $c, $chunk ) = @_;
349 $c->request->{_body}->add($chunk);
352 =head2 $self->prepare_body_parameters($c)
354 Sets up parameters from body.
358 sub prepare_body_parameters {
359 my ( $self, $c ) = @_;
361 return unless $c->request->{_body};
363 $c->request->body_parameters( $c->request->{_body}->param );
366 =head2 $self->prepare_connection($c)
368 Abstract method implemented in engines.
372 sub prepare_connection { }
374 =head2 $self->prepare_cookies($c)
376 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
380 sub prepare_cookies {
381 my ( $self, $c ) = @_;
383 if ( my $header = $c->request->header('Cookie') ) {
384 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
388 =head2 $self->prepare_headers($c)
392 sub prepare_headers { }
394 =head2 $self->prepare_parameters($c)
396 sets up parameters from query and post parameters.
400 sub prepare_parameters {
401 my ( $self, $c ) = @_;
403 my $request = $c->request;
404 my $parameters = $request->parameters;
405 my $body_parameters = $request->body_parameters;
406 my $query_parameters = $request->query_parameters;
407 # We copy, no references
408 foreach my $name (keys %$query_parameters) {
409 my $param = $query_parameters->{$name};
410 $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
413 # Merge query and body parameters
414 foreach my $name (keys %$body_parameters) {
415 my $param = $body_parameters->{$name};
416 my @values = ref $param eq 'ARRAY' ? @$param : ($param);
417 if ( my $existing = $parameters->{$name} ) {
418 unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
420 $parameters->{$name} = @values > 1 ? \@values : $values[0];
424 =head2 $self->prepare_path($c)
426 abstract method, implemented by engines.
432 =head2 $self->prepare_request($c)
434 =head2 $self->prepare_query_parameters($c)
436 process the query string and extract query parameters.
440 sub prepare_query_parameters {
441 my ( $self, $c, $query_string ) = @_;
443 # Check for keywords (no = signs)
444 # (yes, index() is faster than a regex :))
445 if ( index( $query_string, '=' ) < 0 ) {
446 $c->request->query_keywords( $self->unescape_uri($query_string) );
452 # replace semi-colons
453 $query_string =~ s/;/&/g;
455 my @params = split /&/, $query_string;
457 for my $item ( @params ) {
460 = map { $self->unescape_uri($_) }
461 split( /=/, $item, 2 );
463 $param = $self->unescape_uri($item) unless defined $param;
465 if ( exists $query{$param} ) {
466 if ( ref $query{$param} ) {
467 push @{ $query{$param} }, $value;
470 $query{$param} = [ $query{$param}, $value ];
474 $query{$param} = $value;
478 $c->request->query_parameters( \%query );
481 =head2 $self->prepare_read($c)
483 prepare to read from the engine.
488 my ( $self, $c ) = @_;
490 # Initialize the read position
491 $self->read_position(0);
493 # Initialize the amount of data we think we need to read
494 $self->read_length( $c->request->header('Content-Length') || 0 );
497 =head2 $self->prepare_request(@arguments)
499 Populate the context object from the request object.
503 sub prepare_request { }
505 =head2 $self->prepare_uploads($c)
509 sub prepare_uploads {
510 my ( $self, $c ) = @_;
512 my $request = $c->request;
513 return unless $request->{_body};
515 my $uploads = $request->{_body}->upload;
516 my $parameters = $request->parameters;
517 foreach my $name (keys %$uploads) {
518 my $files = $uploads->{$name};
520 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
521 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
522 my $u = Catalyst::Request::Upload->new
524 size => $upload->{size},
525 type => $headers->content_type,
527 tempname => $upload->{tempname},
528 filename => $upload->{filename},
532 $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 $parameters->{$name}) {
538 if (ref $parameters->{$name} eq 'ARRAY') {
539 push @{ $parameters->{$name} }, @filenames;
542 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
546 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
551 =head2 $self->prepare_write($c)
553 Abstract method. Implemented by the engines.
557 sub prepare_write { }
559 =head2 $self->read($c, [$maxlength])
564 my ( $self, $c, $maxlength ) = @_;
566 my $remaining = $self->read_length - $self->read_position;
567 $maxlength ||= $CHUNKSIZE;
569 # Are we done reading?
570 if ( $remaining <= 0 ) {
571 $self->finalize_read($c);
575 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
576 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
578 $self->read_position( $self->read_position + $rc );
582 Catalyst::Exception->throw(
583 message => "Unknown error reading input: $!" );
587 =head2 $self->read_chunk($c, $buffer, $length)
589 Each engine inplements read_chunk as its preferred way of reading a chunk
596 =head2 $self->read_length
598 The length of input data to be read. This is obtained from the Content-Length
601 =head2 $self->read_position
603 The amount of input data that has already been read.
605 =head2 $self->run($c)
607 Start the engine. Implemented by the various engine classes.
613 =head2 $self->write($c, $buffer)
615 Writes the buffer to the client.
620 my ( $self, $c, $buffer ) = @_;
622 unless ( $self->{_prepared_write} ) {
623 $self->prepare_write($c);
624 $self->{_prepared_write} = 1;
627 my $len = length($buffer);
628 my $wrote = syswrite STDOUT, $buffer;
630 if ( !defined $wrote && $! == EWOULDBLOCK ) {
631 # Unable to write on the first try, will retry in the loop below
635 if ( defined $wrote && $wrote < $len ) {
636 # We didn't write the whole buffer
638 my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
639 if ( defined $ret ) {
643 next if $! == EWOULDBLOCK;
647 last if $wrote >= $len;
654 =head2 $self->unescape_uri($uri)
656 Unescapes a given URI using the most efficient method available. Engines such
657 as Apache may implement this using Apache's C-based modules, for example.
662 my ( $self, $str ) = @_;
664 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
669 =head2 $self->finalize_output
671 <obsolete>, see finalize_body
675 Sebastian Riedel, <sri@cpan.org>
677 Andy Grundman, <andy@hybridized.org>
681 This program is free software, you can redistribute it and/or modify it under
682 the same terms as Perl itself.