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');
19 has _prepared_write => (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 appropriate 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 $c->req->_clear_context;
129 $c->res->_clear_context;
131 # Don't show body parser in the dump
132 $c->req->_clear_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
161 (pt) Por favor volte mais tarde
166 $c->res->body( <<"" );
167 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
168 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
169 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
171 <meta http-equiv="Content-Language" content="en" />
172 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
173 <title>$title</title>
174 <script type="text/javascript">
176 function toggleDump (dumpElement) {
177 var e = document.getElementById( dumpElement );
178 if (e.style.display == "none") {
179 e.style.display = "";
182 e.style.display = "none";
187 <style type="text/css">
189 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
190 Tahoma, Arial, helvetica, sans-serif;
192 background-color: #eee;
196 :link, :link:hover, :visited, :visited:hover {
201 background-color: #ccc;
202 border: 1px solid #aaa;
207 background-color: #cce;
208 border: 1px solid #755;
214 background-color: #eee;
215 border: 1px solid #575;
221 background-color: #cce;
222 border: 1px solid #557;
231 div.name h1, div.error p {
239 text-decoration: underline;
245 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
246 /* Browser specific (not valid) styles to make preformatted text wrap */
248 white-space: pre-wrap; /* css-3 */
249 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
250 white-space: -pre-wrap; /* Opera 4-6 */
251 white-space: -o-pre-wrap; /* Opera 7 */
252 word-wrap: break-word; /* Internet Explorer 5.5+ */
258 <div class="error">$error</div>
259 <div class="infos">$infos</div>
260 <div class="name">$name</div>
267 $c->res->{body} .= ( ' ' x 512 );
270 $c->res->status(500);
273 =head2 $self->finalize_headers($c)
275 Abstract method, allows engines to write headers to response
279 sub finalize_headers { }
281 =head2 $self->finalize_read($c)
285 sub finalize_read { }
287 =head2 $self->finalize_uploads($c)
289 Clean up after uploads, deleting temp files.
293 sub finalize_uploads {
294 my ( $self, $c ) = @_;
296 my $request = $c->request;
297 foreach my $key (keys %{ $request->uploads }) {
298 my $upload = $request->uploads->{$key};
299 unlink grep { -e $_ } map { $_->tempname }
300 (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
305 =head2 $self->prepare_body($c)
307 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
312 my ( $self, $c ) = @_;
314 if ( my $length = $self->read_length ) {
315 my $request = $c->request;
316 unless ( $request->_body ) {
317 my $type = $request->header('Content-Type');
318 $request->_body(HTTP::Body->new( $type, $length ));
319 $request->_body->tmpdir( $c->config->{uploadtmp} )
320 if exists $c->config->{uploadtmp};
323 while ( my $buffer = $self->read($c) ) {
324 $c->prepare_body_chunk($buffer);
327 # paranoia against wrong Content-Length header
328 my $remaining = $length - $self->read_position;
329 if ( $remaining > 0 ) {
330 $self->finalize_read($c);
331 Catalyst::Exception->throw(
332 "Wrong Content-Length value: $length" );
336 # Defined but will cause all body code to be skipped
337 $c->request->_body(0);
341 =head2 $self->prepare_body_chunk($c)
343 Add a chunk to the request body.
347 sub prepare_body_chunk {
348 my ( $self, $c, $chunk ) = @_;
350 $c->request->_body->add($chunk);
353 =head2 $self->prepare_body_parameters($c)
355 Sets up parameters from body.
359 sub prepare_body_parameters {
360 my ( $self, $c ) = @_;
362 return unless $c->request->_body;
364 $c->request->body_parameters( $c->request->_body->param );
367 =head2 $self->prepare_connection($c)
369 Abstract method implemented in engines.
373 sub prepare_connection { }
375 =head2 $self->prepare_cookies($c)
377 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
381 sub prepare_cookies {
382 my ( $self, $c ) = @_;
384 if ( my $header = $c->request->header('Cookie') ) {
385 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
389 =head2 $self->prepare_headers($c)
393 sub prepare_headers { }
395 =head2 $self->prepare_parameters($c)
397 sets up parameters from query and post parameters.
401 sub prepare_parameters {
402 my ( $self, $c ) = @_;
404 my $request = $c->request;
405 my $parameters = $request->parameters;
406 my $body_parameters = $request->body_parameters;
407 my $query_parameters = $request->query_parameters;
408 # We copy, no references
409 foreach my $name (keys %$query_parameters) {
410 my $param = $query_parameters->{$name};
411 $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
414 # Merge query and body parameters
415 foreach my $name (keys %$body_parameters) {
416 my $param = $body_parameters->{$name};
417 my @values = ref $param eq 'ARRAY' ? @$param : ($param);
418 if ( my $existing = $parameters->{$name} ) {
419 unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
421 $parameters->{$name} = @values > 1 ? \@values : $values[0];
425 =head2 $self->prepare_path($c)
427 abstract method, implemented by engines.
433 =head2 $self->prepare_request($c)
435 =head2 $self->prepare_query_parameters($c)
437 process the query string and extract query parameters.
441 sub prepare_query_parameters {
442 my ( $self, $c, $query_string ) = @_;
444 # Check for keywords (no = signs)
445 # (yes, index() is faster than a regex :))
446 if ( index( $query_string, '=' ) < 0 ) {
447 $c->request->query_keywords( $self->unescape_uri($query_string) );
453 # replace semi-colons
454 $query_string =~ s/;/&/g;
456 my @params = grep { length $_ } split /&/, $query_string;
458 for my $item ( @params ) {
461 = map { $self->unescape_uri($_) }
462 split( /=/, $item, 2 );
464 $param = $self->unescape_uri($item) unless defined $param;
466 if ( exists $query{$param} ) {
467 if ( ref $query{$param} ) {
468 push @{ $query{$param} }, $value;
471 $query{$param} = [ $query{$param}, $value ];
475 $query{$param} = $value;
479 $c->request->query_parameters( \%query );
482 =head2 $self->prepare_read($c)
484 prepare to read from the engine.
489 my ( $self, $c ) = @_;
491 # Initialize the read position
492 $self->read_position(0);
494 # Initialize the amount of data we think we need to read
495 $self->read_length( $c->request->header('Content-Length') || 0 );
498 =head2 $self->prepare_request(@arguments)
500 Populate the context object from the request object.
504 sub prepare_request { }
506 =head2 $self->prepare_uploads($c)
510 sub prepare_uploads {
511 my ( $self, $c ) = @_;
513 my $request = $c->request;
514 return unless $request->_body;
516 my $uploads = $request->_body->upload;
517 my $parameters = $request->parameters;
518 foreach my $name (keys %$uploads) {
519 my $files = $uploads->{$name};
521 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
522 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
523 my $u = Catalyst::Request::Upload->new
525 size => $upload->{size},
526 type => $headers->content_type,
528 tempname => $upload->{tempname},
529 filename => $upload->{filename},
533 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
535 # support access to the filename as a normal param
536 my @filenames = map { $_->{filename} } @uploads;
537 # append, if there's already params with this name
538 if (exists $parameters->{$name}) {
539 if (ref $parameters->{$name} eq 'ARRAY') {
540 push @{ $parameters->{$name} }, @filenames;
543 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
547 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
552 =head2 $self->prepare_write($c)
554 Abstract method. Implemented by the engines.
558 sub prepare_write { }
560 =head2 $self->read($c, [$maxlength])
565 my ( $self, $c, $maxlength ) = @_;
567 my $remaining = $self->read_length - $self->read_position;
568 $maxlength ||= $CHUNKSIZE;
570 # Are we done reading?
571 if ( $remaining <= 0 ) {
572 $self->finalize_read($c);
576 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
577 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
579 $self->read_position( $self->read_position + $rc );
583 Catalyst::Exception->throw(
584 message => "Unknown error reading input: $!" );
588 =head2 $self->read_chunk($c, $buffer, $length)
590 Each engine inplements read_chunk as its preferred way of reading a chunk
597 =head2 $self->read_length
599 The length of input data to be read. This is obtained from the Content-Length
602 =head2 $self->read_position
604 The amount of input data that has already been read.
606 =head2 $self->run($c)
608 Start the engine. Implemented by the various engine classes.
614 =head2 $self->write($c, $buffer)
616 Writes the buffer to the client.
621 my ( $self, $c, $buffer ) = @_;
623 unless ( $self->_prepared_write ) {
624 $self->prepare_write($c);
625 $self->_prepared_write(1);
628 return 0 if !defined $buffer;
630 my $len = length($buffer);
631 my $wrote = syswrite STDOUT, $buffer;
633 if ( !defined $wrote && $! == EWOULDBLOCK ) {
634 # Unable to write on the first try, will retry in the loop below
638 if ( defined $wrote && $wrote < $len ) {
639 # We didn't write the whole buffer
641 my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
642 if ( defined $ret ) {
646 next if $! == EWOULDBLOCK;
650 last if $wrote >= $len;
657 =head2 $self->unescape_uri($uri)
659 Unescapes a given URI using the most efficient method available. Engines such
660 as Apache may implement this using Apache's C-based modules, for example.
665 my ( $self, $str ) = @_;
667 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
672 =head2 $self->finalize_output
674 <obsolete>, see finalize_body
678 Catalyst Contributors, see Catalyst.pm
682 This program is free software, you can redistribute it and/or modify it under
683 the same terms as Perl itself.