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';
14 use namespace::clean -except => 'meta';
16 has env => (is => 'rw');
18 # input position and length
19 has read_length => (is => 'rw');
20 has read_position => (is => 'rw');
22 has _prepared_write => (is => 'rw');
24 # Amount of data to read from input on each pass
25 our $CHUNKSIZE = 64 * 1024;
29 Catalyst::Engine - The Catalyst Engine
40 =head2 $self->finalize_body($c)
42 Finalize body. Prints the response output.
47 my ( $self, $c ) = @_;
48 my $body = $c->response->body;
49 no warnings 'uninitialized';
50 if ( blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
51 while ( !eof $body ) {
52 read $body, my ($buffer), $CHUNKSIZE;
53 last unless $self->write( $c, $buffer );
58 $self->write( $c, $body );
62 =head2 $self->finalize_cookies($c)
64 Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
69 sub finalize_cookies {
70 my ( $self, $c ) = @_;
73 my $response = $c->response;
75 foreach my $name (keys %{ $response->cookies }) {
77 my $val = $response->cookies->{$name};
82 : CGI::Simple::Cookie->new(
84 -value => $val->{value},
85 -expires => $val->{expires},
86 -domain => $val->{domain},
87 -path => $val->{path},
88 -secure => $val->{secure} || 0
92 push @cookies, $cookie->as_string;
95 for my $cookie (@cookies) {
96 $response->headers->push_header( 'Set-Cookie' => $cookie );
100 =head2 $self->finalize_error($c)
102 Output an appropriate error message. Called if there's an error in $c
103 after the dispatch has finished. Will output debug messages if Catalyst
104 is in debug mode, or a `please come back later` message otherwise.
109 my ( $self, $c ) = @_;
111 $c->res->content_type('text/html; charset=utf-8');
112 my $name = $c->config->{name} || join(' ', split('::', ref $c));
114 my ( $title, $error, $infos );
118 $error = join '', map {
119 '<p><code class="error">'
120 . encode_entities($_)
123 $error ||= 'No output';
124 $error = qq{<pre wrap="">$error</pre>};
125 $title = $name = "$name on Catalyst $Catalyst::VERSION";
126 $name = "<h1>$name</h1>";
128 # Don't show context in the dump
129 $c->req->_clear_context;
130 $c->res->_clear_context;
132 # Don't show body parser in the dump
133 $c->req->_clear_body;
137 for my $dump ( $c->dump_these ) {
138 my $name = $dump->[0];
139 my $value = encode_entities( dump( $dump->[1] ));
140 push @infos, sprintf <<"EOF", $name, $value;
141 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
143 <pre wrap="">%s</pre>
148 $infos = join "\n", @infos;
155 (en) Please come back later
156 (fr) SVP veuillez revenir plus tard
157 (de) Bitte versuchen sie es spaeter nocheinmal
158 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
159 (no) Vennligst prov igjen senere
160 (dk) Venligst prov igen senere
161 (pl) Prosze sprobowac pozniej
162 (pt) Por favor volte mais tarde
163 (ru) Попробуйте еще раз позже
164 (ua) Спробуйте ще раз пізніше
169 $c->res->body( <<"" );
170 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
171 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
172 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
174 <meta http-equiv="Content-Language" content="en" />
175 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
176 <title>$title</title>
177 <script type="text/javascript">
179 function toggleDump (dumpElement) {
180 var e = document.getElementById( dumpElement );
181 if (e.style.display == "none") {
182 e.style.display = "";
185 e.style.display = "none";
190 <style type="text/css">
192 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
193 Tahoma, Arial, helvetica, sans-serif;
195 background-color: #eee;
199 :link, :link:hover, :visited, :visited:hover {
204 background-color: #ccc;
205 border: 1px solid #aaa;
210 background-color: #cce;
211 border: 1px solid #755;
217 background-color: #eee;
218 border: 1px solid #575;
224 background-color: #cce;
225 border: 1px solid #557;
234 div.name h1, div.error p {
242 text-decoration: underline;
248 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
249 /* Browser specific (not valid) styles to make preformatted text wrap */
251 white-space: pre-wrap; /* css-3 */
252 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
253 white-space: -pre-wrap; /* Opera 4-6 */
254 white-space: -o-pre-wrap; /* Opera 7 */
255 word-wrap: break-word; /* Internet Explorer 5.5+ */
261 <div class="error">$error</div>
262 <div class="infos">$infos</div>
263 <div class="name">$name</div>
270 $c->res->{body} .= ( ' ' x 512 );
273 $c->res->status(500);
276 =head2 $self->finalize_headers($c)
278 Abstract method, allows engines to write headers to response
282 sub finalize_headers { }
284 =head2 $self->finalize_read($c)
288 sub finalize_read { }
290 =head2 $self->finalize_uploads($c)
292 Clean up after uploads, deleting temp files.
296 sub finalize_uploads {
297 my ( $self, $c ) = @_;
299 my $request = $c->request;
300 foreach my $key (keys %{ $request->uploads }) {
301 my $upload = $request->uploads->{$key};
302 unlink grep { -e $_ } map { $_->tempname }
303 (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
308 =head2 $self->prepare_body($c)
310 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
315 my ( $self, $c ) = @_;
317 if ( my $length = $self->read_length ) {
318 my $request = $c->request;
319 unless ( $request->_body ) {
320 my $type = $request->header('Content-Type');
321 $request->_body(HTTP::Body->new( $type, $length ));
322 $request->_body->tmpdir( $c->config->{uploadtmp} )
323 if exists $c->config->{uploadtmp};
326 while ( my $buffer = $self->read($c) ) {
327 $c->prepare_body_chunk($buffer);
330 # paranoia against wrong Content-Length header
331 my $remaining = $length - $self->read_position;
332 if ( $remaining > 0 ) {
333 $self->finalize_read($c);
334 Catalyst::Exception->throw(
335 "Wrong Content-Length value: $length" );
339 # Defined but will cause all body code to be skipped
340 $c->request->_body(0);
344 =head2 $self->prepare_body_chunk($c)
346 Add a chunk to the request body.
350 sub prepare_body_chunk {
351 my ( $self, $c, $chunk ) = @_;
353 $c->request->_body->add($chunk);
356 =head2 $self->prepare_body_parameters($c)
358 Sets up parameters from body.
362 sub prepare_body_parameters {
363 my ( $self, $c ) = @_;
365 return unless $c->request->_body;
367 $c->request->body_parameters( $c->request->_body->param );
370 =head2 $self->prepare_connection($c)
372 Abstract method implemented in engines.
376 sub prepare_connection { }
378 =head2 $self->prepare_cookies($c)
380 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
384 sub prepare_cookies {
385 my ( $self, $c ) = @_;
387 if ( my $header = $c->request->header('Cookie') ) {
388 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
392 =head2 $self->prepare_headers($c)
396 sub prepare_headers { }
398 =head2 $self->prepare_parameters($c)
400 sets up parameters from query and post parameters.
404 sub prepare_parameters {
405 my ( $self, $c ) = @_;
407 my $request = $c->request;
408 my $parameters = $request->parameters;
409 my $body_parameters = $request->body_parameters;
410 my $query_parameters = $request->query_parameters;
411 # We copy, no references
412 foreach my $name (keys %$query_parameters) {
413 my $param = $query_parameters->{$name};
414 $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
417 # Merge query and body parameters
418 foreach my $name (keys %$body_parameters) {
419 my $param = $body_parameters->{$name};
420 my @values = ref $param eq 'ARRAY' ? @$param : ($param);
421 if ( my $existing = $parameters->{$name} ) {
422 unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
424 $parameters->{$name} = @values > 1 ? \@values : $values[0];
428 =head2 $self->prepare_path($c)
430 abstract method, implemented by engines.
436 =head2 $self->prepare_request($c)
438 =head2 $self->prepare_query_parameters($c)
440 process the query string and extract query parameters.
444 sub prepare_query_parameters {
445 my ( $self, $c, $query_string ) = @_;
447 # Check for keywords (no = signs)
448 # (yes, index() is faster than a regex :))
449 if ( index( $query_string, '=' ) < 0 ) {
450 $c->request->query_keywords( $self->unescape_uri($query_string) );
456 # replace semi-colons
457 $query_string =~ s/;/&/g;
459 my @params = grep { length $_ } split /&/, $query_string;
461 for my $item ( @params ) {
464 = map { $self->unescape_uri($_) }
465 split( /=/, $item, 2 );
467 $param = $self->unescape_uri($item) unless defined $param;
469 if ( exists $query{$param} ) {
470 if ( ref $query{$param} ) {
471 push @{ $query{$param} }, $value;
474 $query{$param} = [ $query{$param}, $value ];
478 $query{$param} = $value;
482 $c->request->query_parameters( \%query );
485 =head2 $self->prepare_read($c)
487 prepare to read from the engine.
492 my ( $self, $c ) = @_;
494 # Initialize the read position
495 $self->read_position(0);
497 # Initialize the amount of data we think we need to read
498 $self->read_length( $c->request->header('Content-Length') || 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 my $request = $c->request;
517 return unless $request->_body;
519 my $uploads = $request->_body->upload;
520 my $parameters = $request->parameters;
521 foreach my $name (keys %$uploads) {
522 my $files = $uploads->{$name};
524 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
525 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
526 my $u = Catalyst::Request::Upload->new
528 size => $upload->{size},
529 type => $headers->content_type,
531 tempname => $upload->{tempname},
532 filename => $upload->{filename},
536 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
538 # support access to the filename as a normal param
539 my @filenames = map { $_->{filename} } @uploads;
540 # append, if there's already params with this name
541 if (exists $parameters->{$name}) {
542 if (ref $parameters->{$name} eq 'ARRAY') {
543 push @{ $parameters->{$name} }, @filenames;
546 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
550 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
555 =head2 $self->prepare_write($c)
557 Abstract method. Implemented by the engines.
561 sub prepare_write { }
563 =head2 $self->read($c, [$maxlength])
568 my ( $self, $c, $maxlength ) = @_;
570 my $remaining = $self->read_length - $self->read_position;
571 $maxlength ||= $CHUNKSIZE;
573 # Are we done reading?
574 if ( $remaining <= 0 ) {
575 $self->finalize_read($c);
579 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
580 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
582 $self->read_position( $self->read_position + $rc );
586 Catalyst::Exception->throw(
587 message => "Unknown error reading input: $!" );
591 =head2 $self->read_chunk($c, $buffer, $length)
593 Each engine implements read_chunk as its preferred way of reading a chunk
600 =head2 $self->read_length
602 The length of input data to be read. This is obtained from the Content-Length
605 =head2 $self->read_position
607 The amount of input data that has already been read.
609 =head2 $self->run($c)
611 Start the engine. Implemented by the various engine classes.
617 =head2 $self->write($c, $buffer)
619 Writes the buffer to the client.
624 my ( $self, $c, $buffer ) = @_;
626 unless ( $self->_prepared_write ) {
627 $self->prepare_write($c);
628 $self->_prepared_write(1);
631 return 0 if !defined $buffer;
633 my $len = length($buffer);
634 my $wrote = syswrite STDOUT, $buffer;
636 if ( !defined $wrote && $! == EWOULDBLOCK ) {
637 # Unable to write on the first try, will retry in the loop below
641 if ( defined $wrote && $wrote < $len ) {
642 # We didn't write the whole buffer
644 my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
645 if ( defined $ret ) {
649 next if $! == EWOULDBLOCK;
653 last if $wrote >= $len;
660 =head2 $self->unescape_uri($uri)
662 Unescapes a given URI using the most efficient method available. Engines such
663 as Apache may implement this using Apache's C-based modules, for example.
668 my ( $self, $str ) = @_;
670 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
675 =head2 $self->finalize_output
677 <obsolete>, see finalize_body
681 Catalyst Contributors, see Catalyst.pm
685 This program is free software, you can redistribute it and/or modify it under
686 the same terms as Perl itself.