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.
111 sub _dump_error_page_element {
112 my ($self, $i, $element) = @_;
113 my ($name, $val) = @{ $element };
115 # This is fugly, but the metaclass is _HUGE_ and demands waaay too much
116 # scrolling. Suggestions for more pleasant ways to do this welcome.
117 local $val->{'__MOP__'} = "Stringified: "
118 . $val->{'__MOP__'} if ref $val eq 'HASH' && exists $val->{'__MOP__'};
120 my $text = encode_entities( dump( $val ));
121 sprintf <<"EOF", $name, $text;
122 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
124 <pre wrap="">%s</pre>
130 my ( $self, $c ) = @_;
132 $c->res->content_type('text/html; charset=utf-8');
133 my $name = ref($c)->config->{name} || join(' ', split('::', ref $c));
135 my ( $title, $error, $infos );
139 $error = join '', map {
140 '<p><code class="error">'
141 . encode_entities($_)
144 $error ||= 'No output';
145 $error = qq{<pre wrap="">$error</pre>};
146 $title = $name = "$name on Catalyst $Catalyst::VERSION";
147 $name = "<h1>$name</h1>";
149 # Don't show context in the dump
150 $c->req->_clear_context;
151 $c->res->_clear_context;
153 # Don't show body parser in the dump
154 $c->req->_clear_body;
158 for my $dump ( $c->dump_these ) {
159 push @infos, $self->_dump_error_page_element($i, $dump);
162 $infos = join "\n", @infos;
169 (en) Please come back later
170 (fr) SVP veuillez revenir plus tard
171 (de) Bitte versuchen sie es spaeter nocheinmal
172 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
173 (no) Vennligst prov igjen senere
174 (dk) Venligst prov igen senere
175 (pl) Prosze sprobowac pozniej
176 (pt) Por favor volte mais tarde
177 (ru) Попробуйте еще раз позже
178 (ua) Спробуйте ще раз пізніше
183 $c->res->body( <<"" );
184 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
185 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
186 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
188 <meta http-equiv="Content-Language" content="en" />
189 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
190 <title>$title</title>
191 <script type="text/javascript">
193 function toggleDump (dumpElement) {
194 var e = document.getElementById( dumpElement );
195 if (e.style.display == "none") {
196 e.style.display = "";
199 e.style.display = "none";
204 <style type="text/css">
206 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
207 Tahoma, Arial, helvetica, sans-serif;
209 background-color: #eee;
213 :link, :link:hover, :visited, :visited:hover {
218 background-color: #ccc;
219 border: 1px solid #aaa;
224 background-color: #cce;
225 border: 1px solid #755;
231 background-color: #eee;
232 border: 1px solid #575;
238 background-color: #cce;
239 border: 1px solid #557;
248 div.name h1, div.error p {
256 text-decoration: underline;
262 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
263 /* Browser specific (not valid) styles to make preformatted text wrap */
265 white-space: pre-wrap; /* css-3 */
266 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
267 white-space: -pre-wrap; /* Opera 4-6 */
268 white-space: -o-pre-wrap; /* Opera 7 */
269 word-wrap: break-word; /* Internet Explorer 5.5+ */
275 <div class="error">$error</div>
276 <div class="infos">$infos</div>
277 <div class="name">$name</div>
284 $c->res->{body} .= ( ' ' x 512 );
287 $c->res->status(500);
290 =head2 $self->finalize_headers($c)
292 Abstract method, allows engines to write headers to response
296 sub finalize_headers { }
298 =head2 $self->finalize_read($c)
302 sub finalize_read { }
304 =head2 $self->finalize_uploads($c)
306 Clean up after uploads, deleting temp files.
310 sub finalize_uploads {
311 my ( $self, $c ) = @_;
313 my $request = $c->request;
314 foreach my $key (keys %{ $request->uploads }) {
315 my $upload = $request->uploads->{$key};
316 unlink grep { -e $_ } map { $_->tempname }
317 (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
322 =head2 $self->prepare_body($c)
324 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
329 my ( $self, $c ) = @_;
331 my $appclass = ref($c) || $c;
332 if ( my $length = $self->read_length ) {
333 my $request = $c->request;
334 unless ( $request->_body ) {
335 my $type = $request->header('Content-Type');
336 $request->_body(HTTP::Body->new( $type, $length ));
337 $request->_body->tmpdir( $appclass->config->{uploadtmp} )
338 if exists $appclass->config->{uploadtmp};
341 # Check for definedness as you could read '0'
342 while ( defined ( my $buffer = $self->read($c) ) ) {
343 $c->prepare_body_chunk($buffer);
346 # paranoia against wrong Content-Length header
347 my $remaining = $length - $self->read_position;
348 if ( $remaining > 0 ) {
349 $self->finalize_read($c);
350 Catalyst::Exception->throw(
351 "Wrong Content-Length value: $length" );
355 # Defined but will cause all body code to be skipped
356 $c->request->_body(0);
360 =head2 $self->prepare_body_chunk($c)
362 Add a chunk to the request body.
366 sub prepare_body_chunk {
367 my ( $self, $c, $chunk ) = @_;
369 $c->request->_body->add($chunk);
372 =head2 $self->prepare_body_parameters($c)
374 Sets up parameters from body.
378 sub prepare_body_parameters {
379 my ( $self, $c ) = @_;
381 return unless $c->request->_body;
383 $c->request->body_parameters( $c->request->_body->param );
386 =head2 $self->prepare_connection($c)
388 Abstract method implemented in engines.
392 sub prepare_connection { }
394 =head2 $self->prepare_cookies($c)
396 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
400 sub prepare_cookies {
401 my ( $self, $c ) = @_;
403 if ( my $header = $c->request->header('Cookie') ) {
404 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
408 =head2 $self->prepare_headers($c)
412 sub prepare_headers { }
414 =head2 $self->prepare_parameters($c)
416 sets up parameters from query and post parameters.
420 sub prepare_parameters {
421 my ( $self, $c ) = @_;
423 my $request = $c->request;
424 my $parameters = $request->parameters;
425 my $body_parameters = $request->body_parameters;
426 my $query_parameters = $request->query_parameters;
427 # We copy, no references
428 foreach my $name (keys %$query_parameters) {
429 my $param = $query_parameters->{$name};
430 $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
433 # Merge query and body parameters
434 foreach my $name (keys %$body_parameters) {
435 my $param = $body_parameters->{$name};
436 my @values = ref $param eq 'ARRAY' ? @$param : ($param);
437 if ( my $existing = $parameters->{$name} ) {
438 unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
440 $parameters->{$name} = @values > 1 ? \@values : $values[0];
444 =head2 $self->prepare_path($c)
446 abstract method, implemented by engines.
452 =head2 $self->prepare_request($c)
454 =head2 $self->prepare_query_parameters($c)
456 process the query string and extract query parameters.
460 sub prepare_query_parameters {
461 my ( $self, $c, $query_string ) = @_;
463 # Check for keywords (no = signs)
464 # (yes, index() is faster than a regex :))
465 if ( index( $query_string, '=' ) < 0 ) {
466 $c->request->query_keywords( $self->unescape_uri($query_string) );
472 # replace semi-colons
473 $query_string =~ s/;/&/g;
475 my @params = grep { length $_ } split /&/, $query_string;
477 for my $item ( @params ) {
480 = map { $self->unescape_uri($_) }
481 split( /=/, $item, 2 );
483 $param = $self->unescape_uri($item) unless defined $param;
485 if ( exists $query{$param} ) {
486 if ( ref $query{$param} ) {
487 push @{ $query{$param} }, $value;
490 $query{$param} = [ $query{$param}, $value ];
494 $query{$param} = $value;
498 $c->request->query_parameters( \%query );
501 =head2 $self->prepare_read($c)
503 prepare to read from the engine.
508 my ( $self, $c ) = @_;
510 # Initialize the read position
511 $self->read_position(0);
513 # Initialize the amount of data we think we need to read
514 $self->read_length( $c->request->header('Content-Length') || 0 );
517 =head2 $self->prepare_request(@arguments)
519 Populate the context object from the request object.
523 sub prepare_request { }
525 =head2 $self->prepare_uploads($c)
529 sub prepare_uploads {
530 my ( $self, $c ) = @_;
532 my $request = $c->request;
533 return unless $request->_body;
535 my $uploads = $request->_body->upload;
536 my $parameters = $request->parameters;
537 foreach my $name (keys %$uploads) {
538 my $files = $uploads->{$name};
540 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
541 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
542 my $u = Catalyst::Request::Upload->new
544 size => $upload->{size},
545 type => $headers->content_type,
547 tempname => $upload->{tempname},
548 filename => $upload->{filename},
552 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
554 # support access to the filename as a normal param
555 my @filenames = map { $_->{filename} } @uploads;
556 # append, if there's already params with this name
557 if (exists $parameters->{$name}) {
558 if (ref $parameters->{$name} eq 'ARRAY') {
559 push @{ $parameters->{$name} }, @filenames;
562 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
566 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
571 =head2 $self->prepare_write($c)
573 Abstract method. Implemented by the engines.
577 sub prepare_write { }
579 =head2 $self->read($c, [$maxlength])
581 Reads from the input stream by calling C<< $self->read_chunk >>.
583 Maintains the read_length and read_position counters as data is read.
588 my ( $self, $c, $maxlength ) = @_;
590 my $remaining = $self->read_length - $self->read_position;
591 $maxlength ||= $CHUNKSIZE;
593 # Are we done reading?
594 if ( $remaining <= 0 ) {
595 $self->finalize_read($c);
599 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
600 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
602 if (0 == $rc) { # Nothing more to read even though Content-Length
603 # said there should be. FIXME - Warn in the log here?
604 $self->finalize_read;
607 $self->read_position( $self->read_position + $rc );
611 Catalyst::Exception->throw(
612 message => "Unknown error reading input: $!" );
616 =head2 $self->read_chunk($c, $buffer, $length)
618 Each engine implements read_chunk as its preferred way of reading a chunk
619 of data. Returns the number of bytes read. A return of 0 indicates that
620 there is no more data to be read.
626 =head2 $self->read_length
628 The length of input data to be read. This is obtained from the Content-Length
631 =head2 $self->read_position
633 The amount of input data that has already been read.
635 =head2 $self->run($c)
637 Start the engine. Implemented by the various engine classes.
643 =head2 $self->write($c, $buffer)
645 Writes the buffer to the client.
650 my ( $self, $c, $buffer ) = @_;
652 unless ( $self->_prepared_write ) {
653 $self->prepare_write($c);
654 $self->_prepared_write(1);
657 return 0 if !defined $buffer;
659 my $len = length($buffer);
660 my $wrote = syswrite STDOUT, $buffer;
662 if ( !defined $wrote && $! == EWOULDBLOCK ) {
663 # Unable to write on the first try, will retry in the loop below
667 if ( defined $wrote && $wrote < $len ) {
668 # We didn't write the whole buffer
670 my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
671 if ( defined $ret ) {
675 next if $! == EWOULDBLOCK;
679 last if $wrote >= $len;
686 =head2 $self->unescape_uri($uri)
688 Unescapes a given URI using the most efficient method available. Engines such
689 as Apache may implement this using Apache's C-based modules, for example.
694 my ( $self, $str ) = @_;
696 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
701 =head2 $self->finalize_output
703 <obsolete>, see finalize_body
707 Hash containing enviroment variables including many special variables inserted
708 by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
710 Before accesing enviroment variables consider whether the same information is
711 not directly available via Catalyst objects $c->request, $c->engine ...
713 BEWARE: If you really need to access some enviroment variable from your Catalyst
714 application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
715 as in some enviroments the %ENV hash does not contain what you would expect.
719 Catalyst Contributors, see Catalyst.pm
723 This library is free software. You can redistribute it and/or modify it under
724 the same terms as Perl itself.