X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=blobdiff_plain;f=lib%2FCatalyst%2FEngine.pm;h=150c269f78eba183c19a8f3dd1599d9888391f1e;hp=9a6c287d2c2d3d3d1866ed2848962197e73b5d60;hb=103f2d968b5a1a732c19c39ae03cdd9a44a96a4b;hpb=87f504360777193d96945014faa1d058224fcb0e diff --git a/lib/Catalyst/Engine.pm b/lib/Catalyst/Engine.pm index 9a6c287..150c269 100644 --- a/lib/Catalyst/Engine.pm +++ b/lib/Catalyst/Engine.pm @@ -7,21 +7,20 @@ use CGI::Simple::Cookie; use Data::Dump qw/dump/; use Errno 'EWOULDBLOCK'; use HTML::Entities; -use HTTP::Body; use HTTP::Headers; -use URI::QueryParam; use Plack::Loader; use Catalyst::EngineLoader; -use Encode (); -use utf8; - +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 = 64 * 1024; # XXX - this is only here for compat, do not use! -has env => ( is => 'rw', writer => '_set_env' ); +has env => ( is => 'rw', writer => '_set_env' , weak_ref=>1); my $WARN_ABOUT_ENV = 0; around env => sub { my ($orig, $self, @args) = @_; @@ -33,6 +32,12 @@ around env => sub { return $self->$orig; }; +# XXX - Only here for Engine::PSGI compat +sub prepare_connection { + my ($self, $ctx) = @_; + $ctx->request->prepare_connection; +} + =head1 NAME Catalyst::Engine - The Catalyst Engine @@ -48,30 +53,123 @@ See L. =head2 $self->finalize_body($c) -Finalize body. Prints the response output. +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 >>. + +See L and L for more. =cut sub finalize_body { my ( $self, $c ) = @_; - my $body = $c->response->body; - no warnings 'uninitialized'; - if ( blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) { - my $got; - do { - $got = read $body, my ($buffer), $CHUNKSIZE; - $got = 0 unless $self->write( $c, $buffer ); - } while $got > 0; - - close $body; - } - else { - $self->write( $c, $body ); - } + 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 = []; + } + $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 ); + } + } - my $res = $c->response; - $res->_writer->close; - $res->_clear_writer; + $res->_writer->close; + $res->_clear_writer; + } return; } @@ -175,7 +273,6 @@ sub finalize_error { $name = "

$name

"; # Don't show context in the dump - $c->req->_clear_context; $c->res->_clear_context; # Don't show body parser in the dump @@ -204,6 +301,7 @@ sub finalize_error { (pt) Por favor volte mais tarde (ru) Попробуйте еще раз позже (ua) Спробуйте ще раз пізніше +(it) Per favore riprova più tardi $name = ''; @@ -319,29 +417,14 @@ sub finalize_error { =head2 $self->finalize_headers($c) -Abstract method, allows engines to write headers to response +Allows engines to write headers to response =cut sub finalize_headers { my ($self, $ctx) = @_; - # This is a less-than-pretty hack to avoid breaking the old - # Catalyst::Engine::PSGI. 5.9 Catalyst::Engine sets a response_cb and - # expects us to pass headers to it here, whereas Catalyst::Enngine::PSGI - # just pulls the headers out of $ctx->response in its run method and never - # sets response_cb. So take the lack of a response_cb as a sign that we - # don't need to set the headers. - - return unless ($ctx->response->_has_response_cb); - - my @headers; - $ctx->response->headers->scan(sub { push @headers, @_ }); - - my $writer = $ctx->response->_response_cb->([ $ctx->response->status, \@headers ]); - $ctx->response->_set_writer($writer); - $ctx->response->_clear_response_cb; - + $ctx->finalize_headers unless $ctx->response->finalized_headers; return; } @@ -374,33 +457,7 @@ sets up the L object body using L sub prepare_body { my ( $self, $c ) = @_; - my $appclass = ref($c) || $c; - my $request = $c->request; - if ( my $length = $request->_read_length ) { - unless ( $request->_body ) { - my $type = $request->header('Content-Type'); - $request->_body(HTTP::Body->new( $type, $length )); - $request->_body->cleanup(1); # Make extra sure! - $request->_body->tmpdir( $appclass->config->{uploadtmp} ) - if exists $appclass->config->{uploadtmp}; - } - - # Check for definedness as you could read '0' - while ( defined ( my $buffer = $self->read($c) ) ) { - $c->prepare_body_chunk($buffer); - } - - # paranoia against wrong Content-Length header - my $remaining = $length - $c->request->_read_position; - if ( $remaining > 0 ) { - Catalyst::Exception->throw( - "Wrong Content-Length value: $length" ); - } - } - else { - # Defined but will cause all body code to be skipped - $c->request->_body(0); - } + $c->request->prepare_body; } =head2 $self->prepare_body_chunk($c) @@ -409,10 +466,11 @@ Add a chunk to the request body. =cut +# XXX - Can this be deleted? sub prepare_body_chunk { my ( $self, $c, $chunk ) = @_; - $c->request->_body->add($chunk); + $c->request->prepare_body_chunk($chunk); } =head2 $self->prepare_body_parameters($c) @@ -424,94 +482,22 @@ Sets up parameters from body. sub prepare_body_parameters { my ( $self, $c ) = @_; - return unless $c->request->_body; - - $c->request->body_parameters( $c->request->_body->param ); -} - -=head2 $self->prepare_connection($c) - -Abstract method implemented in engines. - -=cut - -sub prepare_connection { - my ($self, $ctx) = @_; - - my $request = $ctx->request; - my $env = $ctx->request->env; - - $request->address( $env->{REMOTE_ADDR} ); - $request->hostname( $env->{REMOTE_HOST} ) - if exists $env->{REMOTE_HOST}; - $request->protocol( $env->{SERVER_PROTOCOL} ); - $request->remote_user( $env->{REMOTE_USER} ); - $request->method( $env->{REQUEST_METHOD} ); - $request->secure( $env->{'psgi.url_scheme'} eq 'https' ? 1 : 0 ); - - return; -} - -=head2 $self->prepare_cookies($c) - -Parse cookies from header. Sets a L object. - -=cut - -sub prepare_cookies { - my ( $self, $c ) = @_; - - if ( my $header = $c->request->header('Cookie') ) { - $c->req->cookies( { CGI::Simple::Cookie->parse($header) } ); - } -} - -=head2 $self->prepare_headers($c) - -=cut - -sub prepare_headers { - my ($self, $ctx) = @_; - - my $env = $ctx->request->env; - my $headers = $ctx->request->headers; - - for my $header (keys %{ $env }) { - next unless $header =~ /^(HTTP|CONTENT|COOKIE)/i; - (my $field = $header) =~ s/^HTTPS?_//; - $field =~ tr/_/-/; - $headers->header($field => $env->{$header}); - } + $c->request->prepare_body_parameters; } =head2 $self->prepare_parameters($c) -sets up parameters from query and post parameters. +Sets up parameters from query and post parameters. +If parameters have already been set up will clear +existing parameters and set up again. =cut sub prepare_parameters { my ( $self, $c ) = @_; - my $request = $c->request; - my $parameters = $request->parameters; - my $body_parameters = $request->body_parameters; - my $query_parameters = $request->query_parameters; - # We copy, no references - foreach my $name (keys %$query_parameters) { - my $param = $query_parameters->{$name}; - $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param; - } - - # Merge query and body parameters - foreach my $name (keys %$body_parameters) { - my $param = $body_parameters->{$name}; - my @values = ref $param eq 'ARRAY' ? @$param : ($param); - if ( my $existing = $parameters->{$name} ) { - unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing)); - } - $parameters->{$name} = @values > 1 ? \@values : $values[0]; - } + $c->request->_clear_parameters; + return $c->request->parameters; } =head2 $self->prepare_path($c) @@ -586,8 +572,22 @@ process the query string and extract query parameters. sub prepare_query_parameters { my ($self, $c) = @_; - my $env = $c->request->env; + my $do_not_decode_query = $c->config->{do_not_decode_query}; + + my $old_encoding; + if(my $new = $c->config->{default_query_encoding}) { + $old_encoding = $c->encoding; + $c->encoding($new); + } + + my $check = $c->config->{do_not_check_query_encoding} ? undef :$c->_encode_check; + my $decoder = sub { + my $str = shift; + return $str if $do_not_decode_query; + return $c->_handle_param_unicode_decoding($str, $check); + }; + my $query_string = exists $env->{QUERY_STRING} ? $env->{QUERY_STRING} : ''; @@ -595,44 +595,27 @@ sub prepare_query_parameters { # Check for keywords (no = signs) # (yes, index() is faster than a regex :)) if ( index( $query_string, '=' ) < 0 ) { - $c->request->query_keywords( $self->unescape_uri($query_string) ); + my $keywords = $self->unescape_uri($query_string); + $keywords = $decoder->($keywords); + $c->request->query_keywords($keywords); return; } - my %query; - - # replace semi-colons - $query_string =~ s/;/&/g; - - my @params = grep { length $_ } split /&/, $query_string; - - for my $item ( @params ) { + $query_string =~ s/\A[&;]+//; - my ($param, $value) - = map { $self->unescape_uri($_) } - split( /=/, $item, 2 ); - - $param = $self->unescape_uri($item) unless defined $param; - - if ( exists $query{$param} ) { - if ( ref $query{$param} ) { - push @{ $query{$param} }, $value; - } - else { - $query{$param} = [ $query{$param}, $value ]; - } - } - else { - $query{$param} = $value; - } - } + my $p = Hash::MultiValue->new( + map { defined $_ ? $decoder->($self->unescape_uri($_)) : $_ } + map { ( split /=/, $_, 2 )[0,1] } # slice forces two elements + split /[&;]+/, $query_string + ); - $c->request->query_parameters( \%query ); + $c->encoding($old_encoding) if $old_encoding; + $c->request->query_parameters( $c->request->_use_hash_multivalue ? $p : $p->mixed ); } =head2 $self->prepare_read($c) -prepare to read from the engine. +Prepare to read by initializing the Content-Length from headers. =cut @@ -651,6 +634,7 @@ Populate the context object from the request object. sub prepare_request { my ($self, $ctx, %args) = @_; + $ctx->log->psgienv($args{env}) if $ctx->log->can('psgienv'); $ctx->request->_set_env($args{env}); $self->_set_env($args{env}); # Nasty back compat! $ctx->response->_set_response_cb($args{response_cb}); @@ -666,20 +650,26 @@ sub prepare_uploads { my $request = $c->request; return unless $request->_body; + my $enc = $c->encoding; my $uploads = $request->_body->upload; my $parameters = $request->parameters; foreach my $name (keys %$uploads) { my $files = $uploads->{$name}; + $name = $c->_handle_unicode_decoding($name) if $enc; my @uploads; for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) { my $headers = HTTP::Headers->new( %{ $upload->{headers} } ); + my $filename = $upload->{filename}; + $filename = $c->_handle_unicode_decoding($filename) if $enc; + my $u = Catalyst::Request::Upload->new ( size => $upload->{size}, type => scalar $headers->content_type, + charset => scalar $headers->content_type_charset, headers => $headers, tempname => $upload->{tempname}, - filename => $upload->{filename}, + filename => $filename, ); push @uploads, $u; } @@ -702,6 +692,32 @@ sub prepare_uploads { } } +=head2 $self->write($c, $buffer) + +Writes the buffer to the client. + +=cut + +sub write { + my ( $self, $c, $buffer ) = @_; + + $c->response->write($buffer); +} + +=head2 $self->unencoded_write($c, $buffer) + +Writes the buffer to the client without encoding. Necessary for +already encoded buffers. Used when a $c->write has been done +followed by $c->res->body. + +=cut + +sub unencoded_write { + my ( $self, $c, $buffer ) = @_; + + $c->response->unencoded_write($buffer); +} + =head2 $self->read($c, [$maxlength]) Reads from the input stream by calling C<< $self->read_chunk >>. @@ -713,30 +729,7 @@ Maintains the read_length and read_position counters as data is read. sub read { my ( $self, $c, $maxlength ) = @_; - my $request = $c->request; - my $remaining = $request->_read_length - $request->_read_position; - $maxlength ||= $CHUNKSIZE; - - # Are we done reading? - if ( $remaining <= 0 ) { - return; - } - - my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining; - my $rc = $self->read_chunk( $c, my $buffer, $readlen ); - if ( defined $rc ) { - if (0 == $rc) { # Nothing more to read even though Content-Length - # said there should be. - return; - } - my $request = $c->request; - $request->_read_position( $request->_read_position + $rc ); - return $buffer; - } - else { - Catalyst::Exception->throw( - message => "Unknown error reading input: $!" ); - } + $c->request->read($maxlength); } =head2 $self->read_chunk($c, \$buffer, $length) @@ -752,15 +745,6 @@ sub read_chunk { return $ctx->request->read_chunk(@_); } -=head2 $self->read_length - -The length of input data to be read. This is obtained from the Content-Length -header. - -=head2 $self->read_position - -The amount of input data that has already been read. - =head2 $self->run($app, $server) Start the engine. Builds a PSGI application and calls the @@ -800,8 +784,7 @@ sub run { =head2 build_psgi_app ($app, @args) -Builds and returns a PSGI application closure, wrapping it in the reverse proxy -middleware if the using_frontend_proxy config setting is set. +Builds and returns a PSGI application closure. (Raw, not wrapped in middleware) =cut @@ -813,30 +796,12 @@ sub build_psgi_app { return sub { my ($respond) = @_; + confess("Did not get a response callback for writer, cannot continue") unless $respond; $app->handle_request(env => $env, response_cb => $respond); }; }; } -=head2 $self->write($c, $buffer) - -Writes the buffer to the client. - -=cut - -sub write { - my ( $self, $c, $buffer ) = @_; - - my $response = $c->response; - - $buffer = q[] unless defined $buffer; - - my $len = length($buffer); - $c->res->_writer->write($buffer); - - return $len; -} - =head2 $self->unescape_uri($uri) Unescapes a given URI using the most efficient method available. Engines such @@ -879,4 +844,6 @@ the same terms as Perl itself. =cut +__PACKAGE__->meta->make_immutable; + 1;