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';
16 use namespace::clean -except => 'meta';
18 has env => (is => 'rw');
20 # input position and length
21 has read_length => (is => 'rw');
22 has read_position => (is => 'rw');
24 has _prepared_write => (is => 'rw');
26 # Amount of data to read from input on each pass
27 our $CHUNKSIZE = 64 * 1024;
31 Catalyst::Engine - The Catalyst Engine
42 =head2 $self->finalize_body($c)
44 Finalize body. Prints the response output.
49 my ( $self, $c ) = @_;
50 my $body = $c->response->body;
51 no warnings 'uninitialized';
52 if ( blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
55 $got = read $body, my ($buffer), $CHUNKSIZE;
56 $got = 0 unless $self->write( $c, $buffer );
62 $self->write( $c, $body );
66 =head2 $self->finalize_cookies($c)
68 Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
73 sub finalize_cookies {
74 my ( $self, $c ) = @_;
77 my $response = $c->response;
79 foreach my $name (keys %{ $response->cookies }) {
81 my $val = $response->cookies->{$name};
86 : CGI::Simple::Cookie->new(
88 -value => $val->{value},
89 -expires => $val->{expires},
90 -domain => $val->{domain},
91 -path => $val->{path},
92 -secure => $val->{secure} || 0,
93 -httponly => $val->{httponly} || 0,
97 push @cookies, $cookie->as_string;
100 for my $cookie (@cookies) {
101 $response->headers->push_header( 'Set-Cookie' => $cookie );
105 =head2 $self->finalize_error($c)
107 Output an appropriate error message. Called if there's an error in $c
108 after the dispatch has finished. Will output debug messages if Catalyst
109 is in debug mode, or a `please come back later` message otherwise.
113 sub _dump_error_page_element {
114 my ($self, $i, $element) = @_;
115 my ($name, $val) = @{ $element };
117 # This is fugly, but the metaclass is _HUGE_ and demands waaay too much
118 # scrolling. Suggestions for more pleasant ways to do this welcome.
119 local $val->{'__MOP__'} = "Stringified: "
120 . $val->{'__MOP__'} if ref $val eq 'HASH' && exists $val->{'__MOP__'};
122 my $text = encode_entities( dump( $val ));
123 sprintf <<"EOF", $name, $text;
124 <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
126 <pre wrap="">%s</pre>
132 my ( $self, $c ) = @_;
134 $c->res->content_type('text/html; charset=utf-8');
135 my $name = ref($c)->config->{name} || join(' ', split('::', ref $c));
137 # Prevent Catalyst::Plugin::Unicode::Encoding from running.
138 # This is a little nasty, but it's the best way to be clean whether or
139 # not the user has an encoding plugin.
141 if ($c->can('encoding')) {
145 my ( $title, $error, $infos );
149 $error = join '', map {
150 '<p><code class="error">'
151 . encode_entities($_)
154 $error ||= 'No output';
155 $error = qq{<pre wrap="">$error</pre>};
156 $title = $name = "$name on Catalyst $Catalyst::VERSION";
157 $name = "<h1>$name</h1>";
159 # Don't show context in the dump
160 $c->req->_clear_context;
161 $c->res->_clear_context;
163 # Don't show body parser in the dump
164 $c->req->_clear_body;
168 for my $dump ( $c->dump_these ) {
169 push @infos, $self->_dump_error_page_element($i, $dump);
172 $infos = join "\n", @infos;
179 (en) Please come back later
180 (fr) SVP veuillez revenir plus tard
181 (de) Bitte versuchen sie es spaeter nocheinmal
182 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
183 (no) Vennligst prov igjen senere
184 (dk) Venligst prov igen senere
185 (pl) Prosze sprobowac pozniej
186 (pt) Por favor volte mais tarde
187 (ru) Попробуйте еще раз позже
188 (ua) Спробуйте ще раз пізніше
193 $c->res->body( <<"" );
194 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
195 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
196 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
198 <meta http-equiv="Content-Language" content="en" />
199 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
200 <title>$title</title>
201 <script type="text/javascript">
203 function toggleDump (dumpElement) {
204 var e = document.getElementById( dumpElement );
205 if (e.style.display == "none") {
206 e.style.display = "";
209 e.style.display = "none";
214 <style type="text/css">
216 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
217 Tahoma, Arial, helvetica, sans-serif;
219 background-color: #eee;
223 :link, :link:hover, :visited, :visited:hover {
228 background-color: #ccc;
229 border: 1px solid #aaa;
234 background-color: #cce;
235 border: 1px solid #755;
241 background-color: #eee;
242 border: 1px solid #575;
248 background-color: #cce;
249 border: 1px solid #557;
258 div.name h1, div.error p {
266 text-decoration: underline;
272 /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
273 /* Browser specific (not valid) styles to make preformatted text wrap */
275 white-space: pre-wrap; /* css-3 */
276 white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
277 white-space: -pre-wrap; /* Opera 4-6 */
278 white-space: -o-pre-wrap; /* Opera 7 */
279 word-wrap: break-word; /* Internet Explorer 5.5+ */
285 <div class="error">$error</div>
286 <div class="infos">$infos</div>
287 <div class="name">$name</div>
292 # Trick IE. Old versions of IE would display their own error page instead
293 # of ours if we'd give it less than 512 bytes.
294 $c->res->{body} .= ( ' ' x 512 );
296 $c->res->{body} = Encode::encode("UTF-8", $c->res->{body});
299 $c->res->status(500);
302 =head2 $self->finalize_headers($c)
304 Abstract method, allows engines to write headers to response
308 sub finalize_headers { }
310 =head2 $self->finalize_read($c)
314 sub finalize_read { }
316 =head2 $self->finalize_uploads($c)
318 Clean up after uploads, deleting temp files.
322 sub finalize_uploads {
323 my ( $self, $c ) = @_;
325 # N.B. This code is theoretically entirely unneeded due to ->cleanup(1)
326 # on the HTTP::Body object.
327 my $request = $c->request;
328 foreach my $key (keys %{ $request->uploads }) {
329 my $upload = $request->uploads->{$key};
330 unlink grep { -e $_ } map { $_->tempname }
331 (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
336 =head2 $self->prepare_body($c)
338 sets up the L<Catalyst::Request> object body using L<HTTP::Body>
343 my ( $self, $c ) = @_;
345 my $appclass = ref($c) || $c;
346 if ( my $length = $self->read_length ) {
347 my $request = $c->request;
348 unless ( $request->_body ) {
349 my $type = $request->header('Content-Type');
350 $request->_body(HTTP::Body->new( $type, $length ));
351 $request->_body->cleanup(1); # Make extra sure!
352 $request->_body->tmpdir( $appclass->config->{uploadtmp} )
353 if exists $appclass->config->{uploadtmp};
356 # Check for definedness as you could read '0'
357 while ( defined ( my $buffer = $self->read($c) ) ) {
358 $c->prepare_body_chunk($buffer);
361 # paranoia against wrong Content-Length header
362 my $remaining = $length - $self->read_position;
363 if ( $remaining > 0 ) {
364 $self->finalize_read($c);
365 Catalyst::Exception->throw(
366 "Wrong Content-Length value: $length" );
370 # Defined but will cause all body code to be skipped
371 $c->request->_body(0);
375 =head2 $self->prepare_body_chunk($c)
377 Add a chunk to the request body.
381 sub prepare_body_chunk {
382 my ( $self, $c, $chunk ) = @_;
384 $c->request->_body->add($chunk);
387 =head2 $self->prepare_body_parameters($c)
389 Sets up parameters from body.
393 sub prepare_body_parameters {
394 my ( $self, $c ) = @_;
396 return unless $c->request->_body;
398 $c->request->body_parameters( $c->request->_body->param );
401 =head2 $self->prepare_connection($c)
403 Abstract method implemented in engines.
407 sub prepare_connection { }
409 =head2 $self->prepare_cookies($c)
411 Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
415 sub prepare_cookies {
416 my ( $self, $c ) = @_;
418 if ( my $header = $c->request->header('Cookie') ) {
419 $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
423 =head2 $self->prepare_headers($c)
427 sub prepare_headers { }
429 =head2 $self->prepare_parameters($c)
431 sets up parameters from query and post parameters.
435 sub prepare_parameters {
436 my ( $self, $c ) = @_;
438 my $request = $c->request;
439 my $parameters = $request->parameters;
440 my $body_parameters = $request->body_parameters;
441 my $query_parameters = $request->query_parameters;
442 # We copy, no references
443 foreach my $name (keys %$query_parameters) {
444 my $param = $query_parameters->{$name};
445 $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
448 # Merge query and body parameters
449 foreach my $name (keys %$body_parameters) {
450 my $param = $body_parameters->{$name};
451 my @values = ref $param eq 'ARRAY' ? @$param : ($param);
452 if ( my $existing = $parameters->{$name} ) {
453 unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
455 $parameters->{$name} = @values > 1 ? \@values : $values[0];
459 =head2 $self->prepare_path($c)
461 abstract method, implemented by engines.
467 =head2 $self->prepare_request($c)
469 =head2 $self->prepare_query_parameters($c)
471 process the query string and extract query parameters.
475 sub prepare_query_parameters {
476 my ( $self, $c, $query_string ) = @_;
478 # Check for keywords (no = signs)
479 # (yes, index() is faster than a regex :))
480 if ( index( $query_string, '=' ) < 0 ) {
481 $c->request->query_keywords( $self->unescape_uri($query_string) );
487 # replace semi-colons
488 $query_string =~ s/;/&/g;
490 my @params = grep { length $_ } split /&/, $query_string;
492 for my $item ( @params ) {
495 = map { $self->unescape_uri($_) }
496 split( /=/, $item, 2 );
498 $param = $self->unescape_uri($item) unless defined $param;
500 if ( exists $query{$param} ) {
501 if ( ref $query{$param} ) {
502 push @{ $query{$param} }, $value;
505 $query{$param} = [ $query{$param}, $value ];
509 $query{$param} = $value;
513 $c->request->query_parameters( \%query );
516 =head2 $self->prepare_read($c)
518 prepare to read from the engine.
523 my ( $self, $c ) = @_;
525 # Initialize the read position
526 $self->read_position(0);
528 # Initialize the amount of data we think we need to read
529 $self->read_length( $c->request->header('Content-Length') || 0 );
532 =head2 $self->prepare_request(@arguments)
534 Populate the context object from the request object.
538 sub prepare_request { }
540 =head2 $self->prepare_uploads($c)
544 sub prepare_uploads {
545 my ( $self, $c ) = @_;
547 my $request = $c->request;
548 return unless $request->_body;
550 my $uploads = $request->_body->upload;
551 my $parameters = $request->parameters;
552 foreach my $name (keys %$uploads) {
553 my $files = $uploads->{$name};
555 for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
556 my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
557 my $u = Catalyst::Request::Upload->new
559 size => $upload->{size},
560 type => scalar $headers->content_type,
562 tempname => $upload->{tempname},
563 filename => $upload->{filename},
567 $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
569 # support access to the filename as a normal param
570 my @filenames = map { $_->{filename} } @uploads;
571 # append, if there's already params with this name
572 if (exists $parameters->{$name}) {
573 if (ref $parameters->{$name} eq 'ARRAY') {
574 push @{ $parameters->{$name} }, @filenames;
577 $parameters->{$name} = [ $parameters->{$name}, @filenames ];
581 $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
586 =head2 $self->prepare_write($c)
588 Abstract method. Implemented by the engines.
592 sub prepare_write { }
594 =head2 $self->read($c, [$maxlength])
596 Reads from the input stream by calling C<< $self->read_chunk >>.
598 Maintains the read_length and read_position counters as data is read.
603 my ( $self, $c, $maxlength ) = @_;
605 my $remaining = $self->read_length - $self->read_position;
606 $maxlength ||= $CHUNKSIZE;
608 # Are we done reading?
609 if ( $remaining <= 0 ) {
610 $self->finalize_read($c);
614 my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
615 my $rc = $self->read_chunk( $c, my $buffer, $readlen );
617 if (0 == $rc) { # Nothing more to read even though Content-Length
618 # said there should be. FIXME - Warn in the log here?
619 $self->finalize_read;
622 $self->read_position( $self->read_position + $rc );
626 Catalyst::Exception->throw(
627 message => "Unknown error reading input: $!" );
631 =head2 $self->read_chunk($c, $buffer, $length)
633 Each engine implements read_chunk as its preferred way of reading a chunk
634 of data. Returns the number of bytes read. A return of 0 indicates that
635 there is no more data to be read.
641 =head2 $self->read_length
643 The length of input data to be read. This is obtained from the Content-Length
646 =head2 $self->read_position
648 The amount of input data that has already been read.
650 =head2 $self->run($c)
652 Start the engine. Implemented by the various engine classes.
658 =head2 $self->write($c, $buffer)
660 Writes the buffer to the client.
665 my ( $self, $c, $buffer ) = @_;
667 unless ( $self->_prepared_write ) {
668 $self->prepare_write($c);
669 $self->_prepared_write(1);
672 return 0 if !defined $buffer;
674 my $len = length($buffer);
675 my $wrote = syswrite STDOUT, $buffer;
677 if ( !defined $wrote && $! == EWOULDBLOCK ) {
678 # Unable to write on the first try, will retry in the loop below
682 if ( defined $wrote && $wrote < $len ) {
683 # We didn't write the whole buffer
685 my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
686 if ( defined $ret ) {
690 next if $! == EWOULDBLOCK;
694 last if $wrote >= $len;
701 =head2 $self->unescape_uri($uri)
703 Unescapes a given URI using the most efficient method available. Engines such
704 as Apache may implement this using Apache's C-based modules, for example.
709 my ( $self, $str ) = @_;
711 $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
716 =head2 $self->finalize_output
718 <obsolete>, see finalize_body
722 Hash containing environment variables including many special variables inserted
723 by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
725 Before accessing environment variables consider whether the same information is
726 not directly available via Catalyst objects $c->request, $c->engine ...
728 BEWARE: If you really need to access some environment variable from your Catalyst
729 application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
730 as in some enviroments the %ENV hash does not contain what you would expect.
734 Catalyst Contributors, see Catalyst.pm
738 This library is free software. You can redistribute it and/or modify it under
739 the same terms as Perl itself.