X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCatalyst%2FEngine.pm;h=a77c73028784a22a48e9e7479f2463616af5a776;hb=HEAD;hp=40d4281bc9c8761f0cae3d0e541f23ca5574edc1;hpb=c6ef5e69c5192516590db9aa162c29f3424cc033;p=catagits%2FCatalyst-Runtime.git diff --git a/lib/Catalyst/Engine.pm b/lib/Catalyst/Engine.pm index 40d4281..a77c730 100644 --- a/lib/Catalyst/Engine.pm +++ b/lib/Catalyst/Engine.pm @@ -1,22 +1,42 @@ package Catalyst::Engine; -use strict; -use base 'Class::Accessor::Fast'; -use CGI::Cookie; -use Data::Dumper; +use Moose; +with 'MooseX::Emulate::Class::Accessor::Fast'; + +use CGI::Simple::Cookie; +use Data::Dump qw/dump/; +use Errno 'EWOULDBLOCK'; use HTML::Entities; -use HTTP::Body; use HTTP::Headers; -use URI::QueryParam; - -# input position and length -__PACKAGE__->mk_accessors(qw/read_position read_length/); - -# Stringify to class -use overload '""' => sub { return ref shift }, fallback => 1; +use Plack::Loader; +use Catalyst::EngineLoader; +use Encode 2.21 'decode_utf8', 'encode', 'decode'; +use Plack::Request::Upload; +use Hash::MultiValue; +use namespace::clean -except => 'meta'; +use utf8; # Amount of data to read from input on each pass -our $CHUNKSIZE = 4096; +our $CHUNKSIZE = 64 * 1024; + +# XXX - this is only here for compat, do not use! +has env => ( is => 'rw', writer => '_set_env' , weak_ref=>1); +my $WARN_ABOUT_ENV = 0; +around env => sub { + my ($orig, $self, @args) = @_; + if(@args) { + warn "env as a writer is deprecated, you probably need to upgrade Catalyst::Engine::PSGI" + unless $WARN_ABOUT_ENV++; + return $self->_set_env(@args); + } + return $self->$orig; +}; + +# XXX - Only here for Engine::PSGI compat +sub prepare_connection { + my ($self, $ctx) = @_; + $ctx->request->prepare_connection; +} =head1 NAME @@ -30,33 +50,134 @@ See L. =head1 METHODS -=over 4 - -=item $self->finalize_output -, see finalize_body +=head2 $self->finalize_body($c) -=item $self->finalize_body($c) +Finalize body. Prints the response output as blocking stream if it looks like +a filehandle, otherwise write it out all in one go. If there is no body in +the response, we assume you are handling it 'manually', such as for nonblocking +style or asynchronous streaming responses. You do this by calling L +several times (which sends HTTP headers if needed) or you close over +C<< $response->write_fh >>. -Finalize body. Prints the response output. +See L and L for more. =cut sub finalize_body { my ( $self, $c ) = @_; - if ( ref $c->response->body && $c->response->body->can('read') ) { - while ( !$c->response->body->eof() ) { - $c->response->body->read( my $buffer, $CHUNKSIZE ); - $self->write( $c, $buffer ); + my $res = $c->response; # We use this all over + + ## If we've asked for the write 'filehandle' that means the application is + ## doing something custom and is expected to close the response + return if $res->_has_write_fh; + + my $body = $res->body; # save some typing + if($res->_has_response_cb) { + ## we have not called the response callback yet, so we are safe to send + ## the whole body to PSGI + + my @headers; + $res->headers->scan(sub { push @headers, @_ }); + + # We need to figure out what kind of body we have and normalize it to something + # PSGI can deal with + if(defined $body) { + # Handle objects first + if(blessed($body)) { + if($body->can('getline')) { + # Body is an IO handle that meets the PSGI spec. Nothing to normalize + } elsif($body->can('read')) { + + # In the past, Catalyst only looked for ->read not ->getline. It is very possible + # that one might have an object that respected read but did not have getline. + # As a result, we need to handle this case for backcompat. + + # We will just do the old loop for now. In a future version of Catalyst this support + # will be removed and one will have to rewrite their custom object or use + # Plack::Middleware::AdaptFilehandleRead. In anycase support for this is officially + # deprecated and described as such as of 5.90060 + + my $got; + do { + $got = read $body, my ($buffer), $CHUNKSIZE; + $got = 0 unless $self->write($c, $buffer ); + } while $got > 0; + + close $body; + return; + } else { + # Looks like for backcompat reasons we need to be able to deal + # with stringyfiable objects. + $body = ["$body"]; + } + } elsif(ref $body) { + if( (ref($body) eq 'GLOB') or (ref($body) eq 'ARRAY')) { + # Again, PSGI can just accept this, no transform needed. We don't officially + # document the body as arrayref at this time (and there's not specific test + # cases. we support it because it simplifies some plack compatibility logic + # and we might make it official at some point. + } else { + $c->log->error("${\ref($body)} is not a valid value for Response->body"); + return; + } + } else { + # Body is defined and not an object or reference. We assume a simple value + # and wrap it in an array for PSGI + $body = [$body]; + } + } else { + # There's no body... + $body = []; } - $c->response->body->close(); - } - else { - $self->write( $c, $c->response->body ); + $res->_response_cb->([ $res->status, \@headers, $body]); + $res->_clear_response_cb; + + } else { + ## Now, if there's no response callback anymore, that means someone has + ## called ->write in order to stream 'some stuff along the way'. I think + ## for backcompat we still need to handle a ->body. I guess I could see + ## someone calling ->write to presend some stuff, and then doing the rest + ## via ->body, like in a template. + + ## We'll just use the old, existing code for this (or most of it) + + if(my $body = $res->body) { + + if ( blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) { + + ## In this case we have no choice and will fall back on the old + ## manual streaming stuff. Not optimal. This is deprecated as of 5.900560+ + + my $got; + do { + $got = read $body, my ($buffer), $CHUNKSIZE; + $got = 0 unless $self->write($c, $buffer ); + } while $got > 0; + + close $body; + } + else { + + # Case where body was set after calling ->write. We'd prefer not to + # support this, but I can see some use cases with the way most of the + # views work. Since body has already been encoded, we need to do + # an 'unencoded_write' here. + $self->unencoded_write( $c, $body ); + } + } + + $res->_writer->close; + $res->_clear_writer; } + + return; } -=item $self->finalize_cookies($c) +=head2 $self->finalize_cookies($c) + +Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as +response headers. =cut @@ -64,78 +185,104 @@ sub finalize_cookies { my ( $self, $c ) = @_; my @cookies; - while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) { - - my $cookie = CGI::Cookie->new( - -name => $name, - -value => $cookie->{value}, - -expires => $cookie->{expires}, - -domain => $cookie->{domain}, - -path => $cookie->{path}, - -secure => $cookie->{secure} || 0 + my $response = $c->response; + + foreach my $name (keys %{ $response->cookies }) { + + my $val = $response->cookies->{$name}; + + my $cookie = ( + blessed($val) + ? $val + : CGI::Simple::Cookie->new( + -name => $name, + -value => $val->{value}, + -expires => $val->{expires}, + -domain => $val->{domain}, + -path => $val->{path}, + -secure => $val->{secure} || 0, + -httponly => $val->{httponly} || 0, + -samesite => $val->{samesite}, + ) ); + if (!defined $cookie) { + $c->log->warn("undef passed in '$name' cookie value - not setting cookie") + if $c->debug; + next; + } push @cookies, $cookie->as_string; } - if (@cookies) { - $c->res->headers->push_header( 'Set-Cookie' => join ',', @cookies ); + for my $cookie (@cookies) { + $response->headers->push_header( 'Set-Cookie' => $cookie ); } } -=item $self->finalize_error($c) +=head2 $self->finalize_error($c) + +Output an appropriate error message. Called if there's an error in $c +after the dispatch has finished. Will output debug messages if Catalyst +is in debug mode, or a `please come back later` message otherwise. =cut +sub _dump_error_page_element { + my ($self, $i, $element) = @_; + my ($name, $val) = @{ $element }; + + # This is fugly, but the metaclass is _HUGE_ and demands waaay too much + # scrolling. Suggestions for more pleasant ways to do this welcome. + local $val->{'__MOP__'} = "Stringified: " + . $val->{'__MOP__'} if ref $val eq 'HASH' && exists $val->{'__MOP__'}; + + my $text = encode_entities( dump( $val )); + sprintf <<"EOF", $name, $text; +

%s

+
+ 
%s
+
+EOF +} + sub finalize_error { my ( $self, $c ) = @_; - $c->res->headers->content_type('text/html'); - my $name = $c->config->{name} || 'Catalyst Application'; + $c->res->content_type('text/html; charset=utf-8'); + my $name = ref($c)->config->{name} || join(' ', split('::', ref $c)); + + # Prevent Catalyst::Plugin::Unicode::Encoding from running. + # This is a little nasty, but it's the best way to be clean whether or + # not the user has an encoding plugin. + + if ($c->can('encoding')) { + $c->{encoding} = ''; + } my ( $title, $error, $infos ); if ( $c->debug ) { # For pretty dumps - local $Data::Dumper::Terse = 1; - $error = join '', - map { '' . encode_entities($_) . '' } - @{ $c->error }; + $error = join '', map { + '

' + . encode_entities($_) + . '

' + } @{ $c->error }; $error ||= 'No output'; + $error = qq{
$error
}; $title = $name = "$name on Catalyst $Catalyst::VERSION"; + $name = "

$name

"; # Don't show context in the dump - delete $c->req->{_context}; - delete $c->res->{_context}; + $c->res->_clear_context; # Don't show body parser in the dump - delete $c->req->{_body}; - - # Don't show response header state in dump - delete $c->res->{_finalized_headers}; - - my $req = encode_entities Dumper $c->req; - my $res = encode_entities Dumper $c->res; - my $stash = encode_entities Dumper $c->stash; + $c->req->_clear_body; my @infos; my $i = 0; - warn "BAAR"; for my $dump ( $c->dump_these ) { - warn "FOOO"; - my $name = $dump->[0]; - my $value = encode_entities( Dumper $dump->[1] ); - push @infos, sprintf <<"EOF", $name, $value; -
- - %s - -
-
-
- 
%s
-
-EOF + push @infos, $self->_dump_error_page_element($i, $dump); $i++; } $infos = join "\n", @infos; @@ -146,29 +293,37 @@ EOF $infos = <<""; 
 (en) Please come back later
+(fr) SVP veuillez revenir plus tard
 (de) Bitte versuchen sie es spaeter nocheinmal
-(nl) Gelieve te komen later terug
+(at) Konnten's bitt'schoen spaeter nochmal reinschauen
 (no) Vennligst prov igjen senere
-(fr) Veuillez revenir plus tard
-(es) Vuelto por favor mas adelante
-(pt) Voltado por favor mais tarde
-(it) Ritornato prego più successivamente
+(dk) Venligst prov igen senere
+(pl) Prosze sprobowac pozniej
+(pt) Por favor volte mais tarde
+(ru) Попробуйте еще раз позже
+(ua) Спробуйте ще раз пізніше
+(it) Per favore riprova più tardi
$name = ''; } $c->res->body( <<"" ); - + + + + $title -