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' ) {
53 $got = read $body, my ($buffer), $CHUNKSIZE;
54 $got = 0 unless $self->write( $c, $buffer );
60 $self->write( $c, $body );
64 =head2 $self->finalize_cookies($c)
66 Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
71 sub finalize_cookies {
72 my ( $self, $c ) = @_;
75 my $response = $c->response;
77 foreach my $name (keys %{ $response->cookies }) {
79 my $val = $response->cookies->{$name};
84 : CGI::Simple::Cookie->new(
86 -value => $val->{value},
87 -expires => $val->{expires},
88 -domain => $val->{domain},
89 -path => $val->{path},
90 -secure => $val->{secure} || 0,
91 -httponly => $val->{httponly} || 0,
95 push @cookies, $cookie->as_string;
98 for my $cookie (@cookies) {
99 $response->headers->push_header( 'Set-Cookie' => $cookie );
103 =head2 $self->finalize_error($c)
105 Output an appropriate error message. Called if there's an error in $c
106 after the dispatch has finished. Will output debug messages if Catalyst
107 is in debug mode, or a `please come back later` message otherwise.
112 my ( $self, $c ) = @_;
114 $c->res->content_type('text/html; charset=utf-8');
115 my $name = ref($c)->config->{name} || join(' ', split('::', ref $c));
117 my ( $title, $error, $infos );
121 $error = join '', map {
122 '<p><code class="error">'
123 . encode_entities($_)
126 $error ||= 'No output';
127 $error = qq{<pre wrap="">$error</pre>};
128 $title = $name = "$name on Catalyst $Catalyst::VERSION";
129 $name = "<h1>$name</h1>";
131 # Don't show context in the dump
132 $c->req->_clear_context;
133 $c->res->_clear_context;
135 # Don't show body parser in the dump
136 $c->req->_clear_body;
140 for my $dump ( $c->dump_these ) {
141 my $name = $dump->[0];
142 my $value = encode_entities( dump( $dump->[1] ));
143 push @infos, sprintf <<"EOF", $name, $value;
144 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
146 <pre wrap="">%s</pre>
151 $infos = join "\n", @infos;
158 (en) Please come back later
159 (fr) SVP veuillez revenir plus tard
160 (de) Bitte versuchen sie es spaeter nocheinmal
161 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
162 (no) Vennligst prov igjen senere
163 (dk) Venligst prov igen senere
164 (pl) Prosze sprobowac pozniej
165 (pt) Por favor volte mais tarde
166 (ru) Попробуйте еще раз позже
167 (ua) Спробуйте ще раз пізніше
172 $c->res->body( <<"" );
173 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
174 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
175 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
177 <meta http-equiv="Content-Language" content="en" />
178 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
179 <title>$title</title>
180 <script type="text/javascript">
182 function toggleDump (dumpElement) {
183 var e = document.getElementById( dumpElement );
184 if (e.style.display == "none") {
185 e.style.display = "";
188 e.style.display = "none";
193 <style type="text/css">
195 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
196 Tahoma, Arial, helvetica, sans-serif;
198 background-color: #eee;
202 :link, :link:hover, :visited, :visited:hover {
207 background-color: #ccc;
208 border: 1px solid #aaa;
213 background-color: #cce;
214 border: 1px solid #755;
220 background-color: #eee;
221 border: 1px solid #575;
227 background-color: #cce;
228 border: 1px solid #557;
237 div.name h1, div.error p {
245 text-decoration: underline;
251 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
252 /* Browser specific (not valid) styles to make preformatted text wrap */
254 white-space: pre-wrap; /* css-3 */
255 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
256 white-space: -pre-wrap; /* Opera 4-6 */
257 white-space: -o-pre-wrap; /* Opera 7 */
258 word-wrap: break-word; /* Internet Explorer 5.5+ */
264 <div class="error">$error</div>
265 <div class="infos">$infos</div>
266 <div class="name">$name</div>
273 $c->res->{body} .= ( ' ' x 512 );
276 $c->res->status(500);
279 =head2 $self->finalize_headers($c)
281 Abstract method, allows engines to write headers to response
285 sub finalize_headers { }
287 =head2 $self->finalize_read($c)
291 sub finalize_read { }
293 =head2 $self->finalize_uploads($c)
295 Clean up after uploads, deleting temp files.
299 sub finalize_uploads {
300 my ( $self, $c ) = @_;
302 my $request = $c->request;
303 foreach my $key (keys %{ $request->uploads }) {
304 my $upload = $request->uploads->{$key};
305 unlink grep { -e $_ } map { $_->tempname }
306 (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
311 =head2 $self->prepare_body($c)
313 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
318 my ( $self, $c ) = @_;
320 my $appclass = ref($c) || $c;
321 if ( my $length = $self->read_length ) {
322 my $request = $c->request;
323 unless ( $request->_body ) {
324 my $type = $request->header('Content-Type');
325 $request->_body(HTTP::Body->new( $type, $length ));
326 $request->_body->tmpdir( $appclass->config->{uploadtmp} )
327 if exists $appclass->config->{uploadtmp};
330 while ( my $buffer = $self->read($c) ) {
331 $c->prepare_body_chunk($buffer);
334 # paranoia against wrong Content-Length header
335 my $remaining = $length - $self->read_position;
336 if ( $remaining > 0 ) {
337 $self->finalize_read($c);
338 Catalyst::Exception->throw(
339 "Wrong Content-Length value: $length" );
343 # Defined but will cause all body code to be skipped
344 $c->request->_body(0);
348 =head2 $self->prepare_body_chunk($c)
350 Add a chunk to the request body.
354 sub prepare_body_chunk {
355 my ( $self, $c, $chunk ) = @_;
357 $c->request->_body->add($chunk);
360 =head2 $self->prepare_body_parameters($c)
362 Sets up parameters from body.
366 sub prepare_body_parameters {
367 my ( $self, $c ) = @_;
369 return unless $c->request->_body;
371 $c->request->body_parameters( $c->request->_body->param );
374 =head2 $self->prepare_connection($c)
376 Abstract method implemented in engines.
380 sub prepare_connection { }
382 =head2 $self->prepare_cookies($c)
384 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
388 sub prepare_cookies {
389 my ( $self, $c ) = @_;
391 if ( my $header = $c->request->header('Cookie') ) {
392 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
396 =head2 $self->prepare_headers($c)
400 sub prepare_headers { }
402 =head2 $self->prepare_parameters($c)
404 sets up parameters from query and post parameters.
408 sub prepare_parameters {
409 my ( $self, $c ) = @_;
411 my $request = $c->request;
412 my $parameters = $request->parameters;
413 my $body_parameters = $request->body_parameters;
414 my $query_parameters = $request->query_parameters;
415 # We copy, no references
416 foreach my $name (keys %$query_parameters) {
417 my $param = $query_parameters->{$name};
418 $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
421 # Merge query and body parameters
422 foreach my $name (keys %$body_parameters) {
423 my $param = $body_parameters->{$name};
424 my @values = ref $param eq 'ARRAY' ? @$param : ($param);
425 if ( my $existing = $parameters->{$name} ) {
426 unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
428 $parameters->{$name} = @values > 1 ? \@values : $values[0];
432 =head2 $self->prepare_path($c)
434 abstract method, implemented by engines.
440 =head2 $self->prepare_request($c)
442 =head2 $self->prepare_query_parameters($c)
444 process the query string and extract query parameters.
448 sub prepare_query_parameters {
449 my ( $self, $c, $query_string ) = @_;
451 # Check for keywords (no = signs)
452 # (yes, index() is faster than a regex :))
453 if ( index( $query_string, '=' ) < 0 ) {
454 $c->request->query_keywords( $self->unescape_uri($query_string) );
460 # replace semi-colons
461 $query_string =~ s/;/&/g;
463 my @params = grep { length $_ } split /&/, $query_string;
465 for my $item ( @params ) {
468 = map { $self->unescape_uri($_) }
469 split( /=/, $item, 2 );
471 $param = $self->unescape_uri($item) unless defined $param;
473 if ( exists $query{$param} ) {
474 if ( ref $query{$param} ) {
475 push @{ $query{$param} }, $value;
478 $query{$param} = [ $query{$param}, $value ];
482 $query{$param} = $value;
486 $c->request->query_parameters( \%query );
489 =head2 $self->prepare_read($c)
491 prepare to read from the engine.
496 my ( $self, $c ) = @_;
498 # Initialize the read position
499 $self->read_position(0);
501 # Initialize the amount of data we think we need to read
502 $self->read_length( $c->request->header('Content-Length') || 0 );
505 =head2 $self->prepare_request(@arguments)
507 Populate the context object from the request object.
511 sub prepare_request { }
513 =head2 $self->prepare_uploads($c)
517 sub prepare_uploads {
518 my ( $self, $c ) = @_;
520 my $request = $c->request;
521 return unless $request->_body;
523 my $uploads = $request->_body->upload;
524 my $parameters = $request->parameters;
525 foreach my $name (keys %$uploads) {
526 my $files = $uploads->{$name};
528 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
529 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
530 my $u = Catalyst::Request::Upload->new
532 size => $upload->{size},
533 type => $headers->content_type,
535 tempname => $upload->{tempname},
536 filename => $upload->{filename},
540 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
542 # support access to the filename as a normal param
543 my @filenames = map { $_->{filename} } @uploads;
544 # append, if there's already params with this name
545 if (exists $parameters->{$name}) {
546 if (ref $parameters->{$name} eq 'ARRAY') {
547 push @{ $parameters->{$name} }, @filenames;
550 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
554 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
559 =head2 $self->prepare_write($c)
561 Abstract method. Implemented by the engines.
565 sub prepare_write { }
567 =head2 $self->read($c, [$maxlength])
572 my ( $self, $c, $maxlength ) = @_;
574 my $remaining = $self->read_length - $self->read_position;
575 $maxlength ||= $CHUNKSIZE;
577 # Are we done reading?
578 if ( $remaining <= 0 ) {
579 $self->finalize_read($c);
583 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
584 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
586 $self->read_position( $self->read_position + $rc );
590 Catalyst::Exception->throw(
591 message => "Unknown error reading input: $!" );
595 =head2 $self->read_chunk($c, $buffer, $length)
597 Each engine implements read_chunk as its preferred way of reading a chunk
604 =head2 $self->read_length
606 The length of input data to be read. This is obtained from the Content-Length
609 =head2 $self->read_position
611 The amount of input data that has already been read.
613 =head2 $self->run($c)
615 Start the engine. Implemented by the various engine classes.
621 =head2 $self->write($c, $buffer)
623 Writes the buffer to the client.
628 my ( $self, $c, $buffer ) = @_;
630 unless ( $self->_prepared_write ) {
631 $self->prepare_write($c);
632 $self->_prepared_write(1);
635 return 0 if !defined $buffer;
637 my $len = length($buffer);
638 my $wrote = syswrite STDOUT, $buffer;
640 if ( !defined $wrote && $! == EWOULDBLOCK ) {
641 # Unable to write on the first try, will retry in the loop below
645 if ( defined $wrote && $wrote < $len ) {
646 # We didn't write the whole buffer
648 my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
649 if ( defined $ret ) {
653 next if $! == EWOULDBLOCK;
657 last if $wrote >= $len;
664 =head2 $self->unescape_uri($uri)
666 Unescapes a given URI using the most efficient method available. Engines such
667 as Apache may implement this using Apache's C-based modules, for example.
672 my ( $self, $str ) = @_;
674 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
679 =head2 $self->finalize_output
681 <obsolete>, see finalize_body
685 Hash containing enviroment variables including many special variables inserted
686 by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
688 Before accesing enviroment variables consider whether the same information is
689 not directly available via Catalyst objects $c->request, $c->engine ...
691 BEWARE: If you really need to access some enviroment variable from your Catalyst
692 application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
693 as in some enviroments the %ENV hash does not contain what you would expect.
697 Catalyst Contributors, see Catalyst.pm
701 This library is free software. You can redistribute it and/or modify it under
702 the same terms as Perl itself.