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 (es) Por favor inténtelo de nuevo más tarde
170 (en) Please come back later
171 (fr) SVP veuillez revenir plus tard
172 (de) Bitte versuchen sie es spaeter nocheinmal
173 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
174 (no) Vennligst prov igjen senere
175 (dk) Venligst prov igen senere
176 (pl) Prosze sprobowac pozniej
177 (pt) Por favor volte mais tarde
178 (ru) Попробуйте еще раз позже
179 (ua) Спробуйте ще раз пізніше
184 $c->res->body( <<"" );
185 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
186 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
187 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
189 <meta http-equiv="Content-Language" content="en" />
190 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
191 <title>$title</title>
192 <script type="text/javascript">
194 function toggleDump (dumpElement) {
195 var e = document.getElementById( dumpElement );
196 if (e.style.display == "none") {
197 e.style.display = "";
200 e.style.display = "none";
205 <style type="text/css">
207 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
208 Tahoma, Arial, helvetica, sans-serif;
210 background-color: #eee;
214 :link, :link:hover, :visited, :visited:hover {
219 background-color: #ccc;
220 border: 1px solid #aaa;
225 background-color: #cce;
226 border: 1px solid #755;
232 background-color: #eee;
233 border: 1px solid #575;
239 background-color: #cce;
240 border: 1px solid #557;
249 div.name h1, div.error p {
257 text-decoration: underline;
263 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
264 /* Browser specific (not valid) styles to make preformatted text wrap */
266 white-space: pre-wrap; /* css-3 */
267 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
268 white-space: -pre-wrap; /* Opera 4-6 */
269 white-space: -o-pre-wrap; /* Opera 7 */
270 word-wrap: break-word; /* Internet Explorer 5.5+ */
276 <div class="error">$error</div>
277 <div class="infos">$infos</div>
278 <div class="name">$name</div>
284 # Trick IE. Old versions of IE would display their own error page instead
285 # of ours if we'd give it less than 512 bytes.
286 $c->res->{body} .= ( ' ' x 512 );
289 $c->res->status(500);
292 =head2 $self->finalize_headers($c)
294 Abstract method, allows engines to write headers to response
298 sub finalize_headers { }
300 =head2 $self->finalize_read($c)
304 sub finalize_read { }
306 =head2 $self->finalize_uploads($c)
308 Clean up after uploads, deleting temp files.
312 sub finalize_uploads {
313 my ( $self, $c ) = @_;
315 # N.B. This code is theoretically entirely unneeded due to ->cleanup(1)
316 # on the HTTP::Body object.
317 my $request = $c->request;
318 foreach my $key (keys %{ $request->uploads }) {
319 my $upload = $request->uploads->{$key};
320 unlink grep { -e $_ } map { $_->tempname }
321 (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
326 =head2 $self->prepare_body($c)
328 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
333 my ( $self, $c ) = @_;
335 my $appclass = ref($c) || $c;
336 if ( my $length = $self->read_length ) {
337 my $request = $c->request;
338 unless ( $request->_body ) {
339 my $type = $request->header('Content-Type');
340 $request->_body(HTTP::Body->new( $type, $length ));
341 $request->_body->cleanup(1); # Make extra sure!
342 $request->_body->tmpdir( $appclass->config->{uploadtmp} )
343 if exists $appclass->config->{uploadtmp};
346 # Check for definedness as you could read '0'
347 while ( defined ( my $buffer = $self->read($c) ) ) {
348 $c->prepare_body_chunk($buffer);
351 # paranoia against wrong Content-Length header
352 my $remaining = $length - $self->read_position;
353 if ( $remaining > 0 ) {
354 $self->finalize_read($c);
355 Catalyst::Exception->throw(
356 "Wrong Content-Length value: $length" );
360 # Defined but will cause all body code to be skipped
361 $c->request->_body(0);
365 =head2 $self->prepare_body_chunk($c)
367 Add a chunk to the request body.
371 sub prepare_body_chunk {
372 my ( $self, $c, $chunk ) = @_;
374 $c->request->_body->add($chunk);
377 =head2 $self->prepare_body_parameters($c)
379 Sets up parameters from body.
383 sub prepare_body_parameters {
384 my ( $self, $c ) = @_;
386 return unless $c->request->_body;
388 $c->request->body_parameters( $c->request->_body->param );
391 =head2 $self->prepare_connection($c)
393 Abstract method implemented in engines.
397 sub prepare_connection { }
399 =head2 $self->prepare_cookies($c)
401 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
405 sub prepare_cookies {
406 my ( $self, $c ) = @_;
408 if ( my $header = $c->request->header('Cookie') ) {
409 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
413 =head2 $self->prepare_headers($c)
417 sub prepare_headers { }
419 =head2 $self->prepare_parameters($c)
421 sets up parameters from query and post parameters.
425 sub prepare_parameters {
426 my ( $self, $c ) = @_;
428 my $request = $c->request;
429 my $parameters = $request->parameters;
430 my $body_parameters = $request->body_parameters;
431 my $query_parameters = $request->query_parameters;
432 # We copy, no references
433 foreach my $name (keys %$query_parameters) {
434 my $param = $query_parameters->{$name};
435 $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
438 # Merge query and body parameters
439 foreach my $name (keys %$body_parameters) {
440 my $param = $body_parameters->{$name};
441 my @values = ref $param eq 'ARRAY' ? @$param : ($param);
442 if ( my $existing = $parameters->{$name} ) {
443 unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
445 $parameters->{$name} = @values > 1 ? \@values : $values[0];
449 =head2 $self->prepare_path($c)
451 abstract method, implemented by engines.
457 =head2 $self->prepare_request($c)
459 =head2 $self->prepare_query_parameters($c)
461 process the query string and extract query parameters.
465 sub prepare_query_parameters {
466 my ( $self, $c, $query_string ) = @_;
468 # Check for keywords (no = signs)
469 # (yes, index() is faster than a regex :))
470 if ( index( $query_string, '=' ) < 0 ) {
471 $c->request->query_keywords( $self->unescape_uri($query_string) );
477 # replace semi-colons
478 $query_string =~ s/;/&/g;
480 my @params = grep { length $_ } split /&/, $query_string;
482 for my $item ( @params ) {
485 = map { $self->unescape_uri($_) }
486 split( /=/, $item, 2 );
488 $param = $self->unescape_uri($item) unless defined $param;
490 if ( exists $query{$param} ) {
491 if ( ref $query{$param} ) {
492 push @{ $query{$param} }, $value;
495 $query{$param} = [ $query{$param}, $value ];
499 $query{$param} = $value;
503 $c->request->query_parameters( \%query );
506 =head2 $self->prepare_read($c)
508 prepare to read from the engine.
513 my ( $self, $c ) = @_;
515 # Initialize the read position
516 $self->read_position(0);
518 # Initialize the amount of data we think we need to read
519 $self->read_length( $c->request->header('Content-Length') || 0 );
522 =head2 $self->prepare_request(@arguments)
524 Populate the context object from the request object.
528 sub prepare_request { }
530 =head2 $self->prepare_uploads($c)
534 sub prepare_uploads {
535 my ( $self, $c ) = @_;
537 my $request = $c->request;
538 return unless $request->_body;
540 my $uploads = $request->_body->upload;
541 my $parameters = $request->parameters;
542 foreach my $name (keys %$uploads) {
543 my $files = $uploads->{$name};
545 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
546 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
547 my $u = Catalyst::Request::Upload->new
549 size => $upload->{size},
550 type => scalar $headers->content_type,
552 tempname => $upload->{tempname},
553 filename => $upload->{filename},
557 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
559 # support access to the filename as a normal param
560 my @filenames = map { $_->{filename} } @uploads;
561 # append, if there's already params with this name
562 if (exists $parameters->{$name}) {
563 if (ref $parameters->{$name} eq 'ARRAY') {
564 push @{ $parameters->{$name} }, @filenames;
567 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
571 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
576 =head2 $self->prepare_write($c)
578 Abstract method. Implemented by the engines.
582 sub prepare_write { }
584 =head2 $self->read($c, [$maxlength])
586 Reads from the input stream by calling C<< $self->read_chunk >>.
588 Maintains the read_length and read_position counters as data is read.
593 my ( $self, $c, $maxlength ) = @_;
595 my $remaining = $self->read_length - $self->read_position;
596 $maxlength ||= $CHUNKSIZE;
598 # Are we done reading?
599 if ( $remaining <= 0 ) {
600 $self->finalize_read($c);
604 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
605 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
607 if (0 == $rc) { # Nothing more to read even though Content-Length
608 # said there should be. FIXME - Warn in the log here?
609 $self->finalize_read;
612 $self->read_position( $self->read_position + $rc );
616 Catalyst::Exception->throw(
617 message => "Unknown error reading input: $!" );
621 =head2 $self->read_chunk($c, $buffer, $length)
623 Each engine implements read_chunk as its preferred way of reading a chunk
624 of data. Returns the number of bytes read. A return of 0 indicates that
625 there is no more data to be read.
631 =head2 $self->read_length
633 The length of input data to be read. This is obtained from the Content-Length
636 =head2 $self->read_position
638 The amount of input data that has already been read.
640 =head2 $self->run($c)
642 Start the engine. Implemented by the various engine classes.
648 =head2 $self->write($c, $buffer)
650 Writes the buffer to the client.
655 my ( $self, $c, $buffer ) = @_;
657 unless ( $self->_prepared_write ) {
658 $self->prepare_write($c);
659 $self->_prepared_write(1);
662 return 0 if !defined $buffer;
664 my $len = length($buffer);
665 my $wrote = syswrite STDOUT, $buffer;
667 if ( !defined $wrote && $! == EWOULDBLOCK ) {
668 # Unable to write on the first try, will retry in the loop below
672 if ( defined $wrote && $wrote < $len ) {
673 # We didn't write the whole buffer
675 my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
676 if ( defined $ret ) {
680 next if $! == EWOULDBLOCK;
684 last if $wrote >= $len;
691 =head2 $self->unescape_uri($uri)
693 Unescapes a given URI using the most efficient method available. Engines such
694 as Apache may implement this using Apache's C-based modules, for example.
699 my ( $self, $str ) = @_;
701 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
706 =head2 $self->finalize_output
708 <obsolete>, see finalize_body
712 Hash containing environment variables including many special variables inserted
713 by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
715 Before accessing environment variables consider whether the same information is
716 not directly available via Catalyst objects $c->request, $c->engine ...
718 BEWARE: If you really need to access some environment variable from your Catalyst
719 application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
720 as in some enviroments the %ENV hash does not contain what you would expect.
724 Catalyst Contributors, see Catalyst.pm
728 This library is free software. You can redistribute it and/or modify it under
729 the same terms as Perl itself.