From: André Walker Date: Fri, 3 Feb 2012 18:22:09 +0000 (-0200) Subject: Merge branch 'master' into gsoc_breadboard X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=commitdiff_plain;h=cefe060084f265addd60effada65a2e4e8661163;hp=1a5e7517716258d7ecfaf65a7b3a35234577b121 Merge branch 'master' into gsoc_breadboard --- diff --git a/Changes b/Changes index b17fa35..94987f0 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,45 @@ # This file documents the revision history for Perl extension Catalyst. + New features and refactoring: + - Much of the Catalyst::Engine code has been moved into Catalyst::Request + and Catalyst::Response, to be able to better support asynchronous web + servers such as Twiggy, by making the application engine more reenterant. + + This change is as a prequel to full asynchronous support inside Catalyst + for AnyEvent and IO::Async backends, which allow highly scaleable streaming + (for applications such as multi-part XML HTTPRequests, and Websockets). + + Deprecations: + - This means that the $c->engine->env method to access the PSGI environment + is now deprecated. The accessor for the PSGI env is now on Catalyst::Request + as per applications which were using Catalyst::Engine::PSGI + + Catalyst::Engine::PSGI is now considered fully deprecated. + + - The private _dump method in Catalyst::Log is now deprecated. The dumper is + not pluggable and which dumper to use should be a user choice. Using + an imported Dump() or Dumper() function is less typing than $c->log->_dump + and as this method is unused anywhere else in Catalyst, it has been scheduled + for removal as a cleanup. Calling this method will now emit a stack trace + on first call (but not on subsequent calls). + + Back compatibility fixes: + - Applications still using Catalyst::Engine::PSGI as they rely on + $c->request->env - this is now the provided (and recommended) way of + accessing the raw PSGI environment. + + Tests: + - Spurious warnings have been removed from the test suite + + Documentation: + - Fix the display of PROJECT FOUNDER and CONTRIBUTORS sections in the + documentation. These were erroneously being emitted when the Pod + was converted to HTML for search.cpan.org + + - Fix documentation for the build_psgi_app app method. Previously the + documentation advised that it provided the psgi app already wrapped + in default middleware. This is not the case - it is the raw app psgi + 5.90007 - 2011-11-22 20:35:00 New features: diff --git a/lib/Catalyst.pm b/lib/Catalyst.pm index 596e6d1..7a03177 100644 --- a/lib/Catalyst.pm +++ b/lib/Catalyst.pm @@ -45,8 +45,24 @@ has state => (is => 'rw', default => 0); has stats => (is => 'rw'); has action => (is => 'rw'); has counter => (is => 'rw', default => sub { {} }); -has request => (is => 'rw', default => sub { $_[0]->request_class->new({}) }, required => 1, lazy => 1); -has response => (is => 'rw', default => sub { $_[0]->response_class->new({}) }, required => 1, lazy => 1); +has request => ( + is => 'rw', + default => sub { + my $self = shift; + my %p = ( _log => $self->log ); + $p{_uploadtmp} = $self->_uploadtmp if $self->_has_uploadtmp; + $self->request_class->new(\%p); + }, + lazy => 1, +); +has response => ( + is => 'rw', + default => sub { + my $self = shift; + $self->response_class->new({ _log => $self->log }); + }, + lazy => 1, +); has namespace => (is => 'rw'); sub depth { scalar @{ shift->stack || [] }; } @@ -366,8 +382,12 @@ When called with no arguments it escapes the processing chain entirely. sub detach { my $c = shift; $c->dispatcher->detach( $c, @_ ) } +=head2 $c->visit( $action [, \@arguments ] ) + =head2 $c->visit( $action [, \@captures, \@arguments ] ) +=head2 $c->visit( $class, $method, [, \@arguments ] ) + =head2 $c->visit( $class, $method, [, \@captures, \@arguments ] ) Almost the same as L<< forward|/"$c->forward( $action [, \@arguments ] )" >>, @@ -396,8 +416,12 @@ transfer control to another action as if it had been reached directly from a URL sub visit { my $c = shift; $c->dispatcher->visit( $c, @_ ) } +=head2 $c->go( $action [, \@arguments ] ) + =head2 $c->go( $action [, \@captures, \@arguments ] ) +=head2 $c->go( $class, $method, [, \@arguments ] ) + =head2 $c->go( $class, $method, [, \@captures, \@arguments ] ) The relationship between C and @@ -1831,6 +1855,11 @@ etc.). =cut +has _uploadtmp => ( + is => 'ro', + predicate => '_has_uploadtmp', +); + sub prepare { my ( $class, @arguments ) = @_; @@ -1839,11 +1868,8 @@ sub prepare { # into the application. $class->context_class( ref $class || $class ) unless $class->context_class; - my $c = $class->context_class->new({}); - - # For on-demand data - $c->request->_context($c); - $c->response->_context($c); + my $uploadtmp = $class->config->{uploadtmp}; + my $c = $class->context_class->new({ $uploadtmp ? (_uploadtmp => $uploadtmp) : ()}); #surely this is not the most efficient way to do things... $c->stats($class->stats_class->new)->enable($c->use_stats); @@ -1860,8 +1886,8 @@ sub prepare { $c->prepare_request(@arguments); $c->prepare_connection; $c->prepare_query_parameters; - $c->prepare_headers; - $c->prepare_cookies; + $c->prepare_headers; # Just hooks, no longer needed - they just + $c->prepare_cookies; # cause the lazy attribute on req to build $c->prepare_path; # Prepare the body for reading, either by prepare_body @@ -1954,24 +1980,28 @@ Prepares connection. sub prepare_connection { my $c = shift; - $c->engine->prepare_connection( $c, @_ ); + # XXX - This is called on the engine (not the request) to maintain + # Engine::PSGI back compat. + $c->engine->prepare_connection($c); } =head2 $c->prepare_cookies -Prepares cookies. +Prepares cookies by ensuring that the attribute on the request +object has been built. =cut -sub prepare_cookies { my $c = shift; $c->engine->prepare_cookies( $c, @_ ) } +sub prepare_cookies { my $c = shift; $c->request->cookies } =head2 $c->prepare_headers -Prepares headers. +Prepares request headers by ensuring that the attribute on the request +object has been built. =cut -sub prepare_headers { my $c = shift; $c->engine->prepare_headers( $c, @_ ) } +sub prepare_headers { my $c = shift; $c->request->headers } =head2 $c->prepare_parameters @@ -2254,7 +2284,7 @@ $c->request. You must handle all body parsing yourself. =cut -sub read { my $c = shift; return $c->engine->read( $c, @_ ) } +sub read { my $c = shift; return $c->request->read( @_ ) } =head2 $c->run @@ -2762,10 +2792,10 @@ your output data, if known. sub write { my $c = shift; - # Finalize headers if someone manually writes output + # Finalize headers if someone manually writes output (for compat) $c->finalize_headers; - return $c->engine->write( $c, @_ ); + return $c->response->write( @_ ); } =head2 version @@ -2999,8 +3029,6 @@ Wiki: =head2 L - The test suite. -=begin stopwords - =head1 PROJECT FOUNDER sri: Sebastian Riedel @@ -3145,8 +3173,6 @@ rainboxx: Matthias Dietrich, C dd070: Dhaval Dhanani -=end stopwords - =head1 COPYRIGHT Copyright (c) 2005, the above named PROJECT FOUNDER and CONTRIBUTORS. diff --git a/lib/Catalyst/Engine.pm b/lib/Catalyst/Engine.pm index 8f88cef..a6a6f25 100644 --- a/lib/Catalyst/Engine.pm +++ b/lib/Catalyst/Engine.pm @@ -10,7 +10,6 @@ use HTML::Entities; use HTTP::Body; use HTTP::Headers; use URI::QueryParam; -use Moose::Util::TypeConstraints; use Plack::Loader; use Catalyst::EngineLoader; use Encode (); @@ -18,8 +17,11 @@ use utf8; use namespace::clean -except => 'meta'; -has env => (is => 'ro', writer => '_set_env', clearer => '_clear_env'); +# 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' ); my $WARN_ABOUT_ENV = 0; around env => sub { my ($orig, $self, @args) = @_; @@ -31,32 +33,11 @@ around env => sub { return $self->$orig; }; -# input position and length -has read_length => (is => 'rw'); -has read_position => (is => 'rw'); - -has _prepared_write => (is => 'rw'); - -has _response_cb => ( - is => 'ro', - isa => 'CodeRef', - writer => '_set_response_cb', - clearer => '_clear_response_cb', - predicate => '_has_response_cb', -); - -subtype 'Catalyst::Engine::Types::Writer', - as duck_type([qw(write close)]); - -has _writer => ( - is => 'ro', - isa => 'Catalyst::Engine::Types::Writer', - writer => '_set_writer', - clearer => '_clear_writer', -); - -# Amount of data to read from input on each pass -our $CHUNKSIZE = 64 * 1024; +# XXX - Only here for Engine::PSGI compat +sub prepare_connection { + my ($self, $ctx) = @_; + $ctx->request->prepare_connection; +} =head1 NAME @@ -94,9 +75,9 @@ sub finalize_body { $self->write( $c, $body ); } - $self->_writer->close; - $self->_clear_writer; - $self->_clear_env; + my $res = $c->response; + $res->_writer->close; + $res->_clear_writer; return; } @@ -344,37 +325,17 @@ 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 $self->_has_response_cb; - - my @headers; - $ctx->response->headers->scan(sub { push @headers, @_ }); - - $self->_set_writer($self->_response_cb->([ $ctx->response->status, \@headers ])); - $self->_clear_response_cb; - + $ctx->response->finalize_headers; return; } -=head2 $self->finalize_read($c) - -=cut - -sub finalize_read { } - =head2 $self->finalize_uploads($c) Clean up after uploads, deleting temp files. @@ -404,34 +365,7 @@ sets up the L object body using L sub prepare_body { my ( $self, $c ) = @_; - my $appclass = ref($c) || $c; - if ( my $length = $self->read_length ) { - my $request = $c->request; - 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 - $self->read_position; - if ( $remaining > 0 ) { - $self->finalize_read($c); - 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) @@ -440,10 +374,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) @@ -455,64 +390,7 @@ 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 $env = $self->env; - my $request = $ctx->request; - - $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 = $self->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) @@ -524,25 +402,7 @@ sets up parameters from query and post parameters. 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->parameters; } =head2 $self->prepare_path($c) @@ -554,7 +414,7 @@ abstract method, implemented by engines. sub prepare_path { my ($self, $ctx) = @_; - my $env = $self->env; + my $env = $ctx->request->env; my $scheme = $ctx->request->secure ? 'https' : 'http'; my $host = $env->{HTTP_HOST} || $env->{SERVER_NAME}; @@ -618,8 +478,9 @@ process the query string and extract query parameters. sub prepare_query_parameters { my ($self, $c) = @_; - my $query_string = exists $self->env->{QUERY_STRING} - ? $self->env->{QUERY_STRING} + my $env = $c->request->env; + my $query_string = exists $env->{QUERY_STRING} + ? $env->{QUERY_STRING} : ''; # Check for keywords (no = signs) @@ -656,35 +517,33 @@ sub prepare_query_parameters { $query{$param} = $value; } } - $c->request->query_parameters( \%query ); } =head2 $self->prepare_read($c) -prepare to read from the engine. +Prepare to read by initializing the Content-Length from headers. =cut sub prepare_read { my ( $self, $c ) = @_; - # Initialize the read position - $self->read_position(0); - # Initialize the amount of data we think we need to read - $self->read_length( $c->request->header('Content-Length') || 0 ); + $c->request->_read_length; } =head2 $self->prepare_request(@arguments) -Sets up the PSGI environment in the Engine. +Populate the context object from the request object. =cut sub prepare_request { my ($self, $ctx, %args) = @_; - $self->_set_env($args{env}); + $ctx->request->_set_env($args{env}); + $self->_set_env($args{env}); # Nasty back compat! + $ctx->response->_set_response_cb($args{response_cb}); } =head2 $self->prepare_uploads($c) @@ -733,13 +592,17 @@ sub prepare_uploads { } } -=head2 $self->prepare_write($c) +=head2 $self->write($c, $buffer) -Abstract method. Implemented by the engines. +Writes the buffer to the client. =cut -sub prepare_write { } +sub write { + my ( $self, $c, $buffer ) = @_; + + $c->response->write($buffer); +} =head2 $self->read($c, [$maxlength]) @@ -752,33 +615,10 @@ Maintains the read_length and read_position counters as data is read. sub read { my ( $self, $c, $maxlength ) = @_; - my $remaining = $self->read_length - $self->read_position; - $maxlength ||= $CHUNKSIZE; - - # Are we done reading? - if ( $remaining <= 0 ) { - $self->finalize_read($c); - 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. - $self->finalize_read; - return; - } - $self->read_position( $self->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) +=head2 $self->read_chunk($c, \$buffer, $length) Each engine implements read_chunk as its preferred way of reading a chunk of data. Returns the number of bytes read. A return of 0 indicates that @@ -788,18 +628,9 @@ there is no more data to be read. sub read_chunk { my ($self, $ctx) = (shift, shift); - return $self->env->{'psgi.input'}->read(@_); + 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 @@ -851,34 +682,11 @@ sub build_psgi_app { return sub { my ($respond) = @_; - $self->_set_response_cb($respond); - $app->handle_request(env => $env); + $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 ) = @_; - - unless ( $self->_prepared_write ) { - $self->prepare_write($c); - $self->_prepared_write(1); - } - - $buffer = q[] unless defined $buffer; - - my $len = length($buffer); - $self->_writer->write($buffer); - - return $len; -} - =head2 $self->unescape_uri($uri) Unescapes a given URI using the most efficient method available. Engines such diff --git a/lib/Catalyst/Engine/HTTP.pm b/lib/Catalyst/Engine/HTTP.pm index 526fec9..9b9ecd3 100644 --- a/lib/Catalyst/Engine/HTTP.pm +++ b/lib/Catalyst/Engine/HTTP.pm @@ -14,7 +14,7 @@ Please update your application's scripts with: catalyst.pl -force -scripts MyApp -to update your scripts to not do this.\n"); +to update your scripts to not do this.\n") unless $ENV{HARNESS_ACTIVE}; 1; diff --git a/lib/Catalyst/Log.pm b/lib/Catalyst/Log.pm index 543e30f..b035d89 100644 --- a/lib/Catalyst/Log.pm +++ b/lib/Catalyst/Log.pm @@ -5,6 +5,7 @@ with 'MooseX::Emulate::Class::Accessor::Fast'; use Data::Dump; use Class::MOP (); +use Carp qw/ cluck /; our %LEVELS = (); # Levels stored as bit field, ergo debug = 1, warn = 2 etc our %LEVEL_MATCH = (); # Stored as additive, thus debug = 31, warn = 30 etc @@ -77,8 +78,12 @@ sub disable { $self->level($level); } +our $HAS_DUMPED; sub _dump { my $self = shift; + unless ($HAS_DUMPED++) { + cluck("Catalyst::Log::_dump is deprecated and will be removed. Please change to using your own Dumper.\n"); + } $self->info( Data::Dump::dump(@_) ); } diff --git a/lib/Catalyst/Request.pm b/lib/Catalyst/Request.pm index 6d14c5b..9c43407 100644 --- a/lib/Catalyst/Request.pm +++ b/lib/Catalyst/Request.pm @@ -14,10 +14,43 @@ use namespace::clean -except => 'meta'; with 'MooseX::Emulate::Class::Accessor::Fast'; +has env => (is => 'ro', writer => '_set_env'); +# XXX Deprecated crap here - warn? has action => (is => 'rw'); +# XXX: Deprecated in docs ages ago (2006), deprecated with warning in 5.8000 due +# to confusion between Engines and Plugin::Authentication. Remove in 5.8100? +has user => (is => 'rw'); +sub snippets { shift->captures(@_) } + +has _read_position => ( + init_arg => undef, + is => 'ro', + writer => '_set_read_position', + default => 0, +); +has _read_length => ( + init_arg => undef, + is => 'ro', + default => sub { + my $self = shift; + $self->header('Content-Length') || 0; + }, + lazy => 1, +); + has address => (is => 'rw'); has arguments => (is => 'rw', default => sub { [] }); -has cookies => (is => 'rw', default => sub { {} }); +has cookies => (is => 'ro', builder => 'prepare_cookies', lazy => 1); + +sub prepare_cookies { + my ( $self ) = @_; + + if ( my $header = $self->header('Cookie') ) { + return { CGI::Simple::Cookie->parse($header) }; + } + {}; +} + has query_keywords => (is => 'rw'); has match => (is => 'rw'); has method => (is => 'rw'); @@ -31,18 +64,65 @@ has headers => ( is => 'rw', isa => 'HTTP::Headers', handles => [qw(content_encoding content_length content_type header referer user_agent)], - default => sub { HTTP::Headers->new() }, - required => 1, + builder => 'prepare_headers', lazy => 1, ); -has _context => ( - is => 'rw', - weak_ref => 1, - handles => ['read'], - clearer => '_clear_context', +sub prepare_headers { + my ($self) = @_; + + my $env = $self->env; + my $headers = HTTP::Headers->new(); + + for my $header (keys %{ $env }) { + next unless $header =~ /^(HTTP|CONTENT|COOKIE)/i; + (my $field = $header) =~ s/^HTTPS?_//; + $field =~ tr/_/-/; + $headers->header($field => $env->{$header}); + } + return $headers; +} + +has _log => ( + is => 'ro', + weak_ref => 1, + required => 1, ); +# Amount of data to read from input on each pass +our $CHUNKSIZE = 64 * 1024; + +sub read { + my ($self, $maxlength) = @_; + my $remaining = $self->_read_length - $self->_read_position; + $maxlength ||= $CHUNKSIZE; + + # Are we done reading? + if ( $remaining <= 0 ) { + return; + } + + my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining; + my $rc = $self->read_chunk( my $buffer, $readlen ); + if ( defined $rc ) { + if (0 == $rc) { # Nothing more to read even though Content-Length + # said there should be. + return; + } + $self->_set_read_position( $self->_read_position + $rc ); + return $buffer; + } + else { + Catalyst::Exception->throw( + message => "Unknown error reading input: $!" ); + } +} + +sub read_chunk { + my $self = shift; + return $self->env->{'psgi.input'}->read(@_); +} + has body_parameters => ( is => 'rw', required => 1, @@ -57,10 +137,9 @@ has uploads => ( ); has parameters => ( - is => 'rw', - required => 1, - lazy => 1, - default => sub { {} }, + is => 'rw', + lazy => 1, + builder => 'prepare_parameters', ); # TODO: @@ -71,17 +150,106 @@ has parameters => ( # these lazy build from there and kill all the direct hash access # in Catalyst.pm and Engine.pm? -before $_ => sub { +sub prepare_parameters { + my ( $self ) = @_; + + $self->prepare_body; + my $parameters = {}; + my $body_parameters = $self->body_parameters; + my $query_parameters = $self->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]; + } + $parameters; +} + +before body_parameters => sub { + my ($self) = @_; + $self->prepare_body; + $self->prepare_body_parameters; +}; + +has _uploadtmp => ( + is => 'ro', + predicate => '_has_uploadtmp', +); + +sub prepare_body { + my ( $self ) = @_; + + if ( my $length = $self->_read_length ) { + unless ( $self->_body ) { + my $type = $self->header('Content-Type'); + $self->_body(HTTP::Body->new( $type, $length )); + $self->_body->cleanup(1); # Make extra sure! + $self->_body->tmpdir( $self->_uploadtmp ) + if $self->_has_uploadtmp; + } + + # Check for definedness as you could read '0' + while ( defined ( my $buffer = $self->read() ) ) { + $self->prepare_body_chunk($buffer); + } + + # paranoia against wrong Content-Length header + my $remaining = $length - $self->_read_position; + if ( $remaining > 0 ) { + Catalyst::Exception->throw( + "Wrong Content-Length value: $length" ); + } + } + else { + # Defined but will cause all body code to be skipped + $self->_body(0); + } +} + +sub prepare_body_chunk { + my ( $self, $chunk ) = @_; + + $self->_body->add($chunk); +} + +sub prepare_body_parameters { + my ( $self ) = @_; + + return unless $self->_body; + + $self->{body_parameters} = $self->_body->param; # FIXME!! Recursion here. +} + +sub prepare_connection { my ($self) = @_; - my $context = $self->_context || return; - $context->prepare_body; -} for qw/parameters body_parameters/; + my $env = $self->env; + + $self->address( $env->{REMOTE_ADDR} ); + $self->hostname( $env->{REMOTE_HOST} ) + if exists $env->{REMOTE_HOST}; + $self->protocol( $env->{SERVER_PROTOCOL} ); + $self->remote_user( $env->{REMOTE_USER} ); + $self->method( $env->{REQUEST_METHOD} ); + $self->secure( $env->{'psgi.url_scheme'} eq 'https' ? 1 : 0 ); +} + +# XXX - FIXME - method is here now, move this crap... around parameters => sub { my ($orig, $self, $params) = @_; if ($params) { if ( !ref $params ) { - $self->_context->log->warn( + $self->_log->warn( "Attempt to retrieve '$params' with req->params(), " . "you probably meant to call req->param('$params')" ); @@ -109,7 +277,7 @@ has _body => ( # and provide a custom reader.. sub body { my $self = shift; - $self->_context->prepare_body(); + $self->prepare_body(); croak 'body is a reader' if scalar @_; return blessed $self->_body ? $self->_body->body : $self->_body; } @@ -126,17 +294,12 @@ has hostname => ( has _path => ( is => 'rw', predicate => '_has_path', clearer => '_clear_path' ); -# XXX: Deprecated in docs ages ago (2006), deprecated with warning in 5.8000 due -# to confusion between Engines and Plugin::Authentication. Remove in 5.8100? -has user => (is => 'rw'); - sub args { shift->arguments(@_) } sub body_params { shift->body_parameters(@_) } sub input { shift->body(@_) } sub params { shift->parameters(@_) } sub query_params { shift->query_parameters(@_) } sub path_info { shift->path(@_) } -sub snippets { shift->captures(@_) } =for stopwords param params @@ -147,8 +310,7 @@ Catalyst::Request - provides information about the current client request =head1 SYNOPSIS $req = $c->request; - $req->action; - $req->address; + $req->address eq "127.0.0.1"; $req->arguments; $req->args; $req->base; @@ -175,7 +337,7 @@ Catalyst::Request - provides information about the current client request $req->read; $req->referer; $req->secure; - $req->captures; # previously knows as snippets + $req->captures; $req->upload; $req->uploads; $req->uri; @@ -192,14 +354,6 @@ thus hiding the details of the particular engine implementation. =head1 METHODS -=head2 $req->action - -[DEPRECATED] Returns the name of the requested action. - - -Use C<< $c->action >> instead (which returns a -L object). - =head2 $req->address Returns the IP address of the client. @@ -480,6 +634,10 @@ Reads a chunk of data from the request body. This method is intended to be used in a while loop, reading $maxlength bytes on every call. $maxlength defaults to the size of the request if not specified. +=head2 $req->read_chunk(\$buff, $max) + +Reads a chunk.. + You have to set MyApp->config(parse_on_demand => 1) to use this directly. =head2 $req->referer @@ -502,11 +660,6 @@ actions or regex captures. my @captures = @{ $c->request->captures }; -=head2 $req->snippets - -C used to be called snippets. This is still available for backwards -compatibility, but is considered deprecated. - =head2 $req->upload A convenient method to access $req->uploads. @@ -688,6 +841,43 @@ Returns the value of the C environment variable. Shortcut to $req->headers->user_agent. Returns the user agent (browser) version string. +=head1 SETUP METHODS + +You should never need to call these yourself in application code, +however they are useful if extending Catalyst by applying a request role. + +=head2 $self->prepare_headers() + +Sets up the C<< $res->headers >> accessor. + +=head2 $self->prepare_body() + +Sets up the body using L + +=head2 $self->prepare_body_chunk() + +Add a chunk to the request body. + +=head2 $self->prepare_body_parameters() + +Sets up parameters from body. + +=head2 $self->prepare_cookies() + +Parse cookies from header. Sets up a L object. + +=head2 $self->prepare_connection() + +Sets up various fields in the request like the local and remote addresses, +request method, hostname requested etc. + +=head2 $self->prepare_parameters() + +Ensures that the body has been parsed, then builds the parameters, which are +combined from those in the request and those in the body. + +This method is the builder for the 'parameters' attribute. + =head2 meta Provided by Moose diff --git a/lib/Catalyst/Response.pm b/lib/Catalyst/Response.pm index 1e1e4bf..cd81857 100644 --- a/lib/Catalyst/Response.pm +++ b/lib/Catalyst/Response.pm @@ -2,9 +2,32 @@ package Catalyst::Response; use Moose; use HTTP::Headers; +use Moose::Util::TypeConstraints; +use namespace::autoclean; with 'MooseX::Emulate::Class::Accessor::Fast'; +has _response_cb => ( + is => 'ro', + isa => 'CodeRef', + writer => '_set_response_cb', + clearer => '_clear_response_cb', + predicate => '_has_response_cb', +); + +subtype 'Catalyst::Engine::Types::Writer', + as duck_type([qw(write close)]); + +has _writer => ( + is => 'ro', + isa => 'Catalyst::Engine::Types::Writer', + writer => '_set_writer', + clearer => '_clear_writer', + predicate => '_has_writer', +); + +sub DEMOLISH { $_[0]->_writer->close if $_[0]->_has_writer } + has cookies => (is => 'rw', default => sub { {} }); has body => (is => 'rw', default => undef); sub has_body { defined($_[0]->body) } @@ -20,18 +43,49 @@ has headers => ( required => 1, lazy => 1, ); -has _context => ( - is => 'rw', - weak_ref => 1, - handles => ['write'], - clearer => '_clear_context', -); sub output { shift->body(@_) } sub code { shift->status(@_) } -no Moose; +sub write { + my ( $self, $buffer ) = @_; + + # Finalize headers if someone manually writes output + $self->finalize_headers; + + $buffer = q[] unless defined $buffer; + + my $len = length($buffer); + $self->_writer->write($buffer); + + return $len; +} + +sub finalize_headers { + my ($self) = @_; + + # 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 $self->_has_response_cb; + + # If we already have a writer, we already did this, so don't do it again + return if $self->_has_writer; + + my @headers; + $self->headers->scan(sub { push @headers, @_ }); + + my $writer = $self->_response_cb->([ $self->status, \@headers ]); + $self->_set_writer($writer); + $self->_clear_response_cb; + + return; +} =head1 NAME @@ -187,15 +241,24 @@ $res->code is an alias for this, to match HTTP::Response->code. Writes $data to the output stream. -=head2 meta - -Provided by Moose - =head2 $res->print( @data ) Prints @data to the output stream, separated by $,. This lets you pass the response object to functions that want to write to an L. +=head2 $self->finalize_headers($c) + +Writes headers to response if not already written + +=head2 DEMOLISH + +Ensures that the response is flushed and closed at the end of the +request. + +=head2 meta + +Provided by Moose + =cut sub print { diff --git a/lib/Catalyst/Test.pm b/lib/Catalyst/Test.pm index 492fb31..fbc8ada 100644 --- a/lib/Catalyst/Test.pm +++ b/lib/Catalyst/Test.pm @@ -295,6 +295,11 @@ sub _local_request { # HTML head parsing based on LWP::UserAgent # + # This is because if you make a remote request with LWP, then the + # from the returned HTML document will be used + # to fill in $res->base, as documented in HTTP::Response. We need + # to support this in local test requests so that they work 'the same'. + # # This is not just horrible and possibly broken, but also really # doesn't belong here. Whoever wants this should be working on # getting it into Plack::Test, or make a middleware out of it, or diff --git a/t/aggregate/live_engine_request_body_demand.t b/t/aggregate/live_engine_request_body_demand.t index b032f63..5646769 100644 --- a/t/aggregate/live_engine_request_body_demand.t +++ b/t/aggregate/live_engine_request_body_demand.t @@ -59,7 +59,6 @@ SKIP: ok( my $response = request($request), 'Request' ); ok( $response->is_success, 'Response Successful 2xx' ); - { no strict 'refs'; ok( diff --git a/t/aggregate/live_engine_request_env.t b/t/aggregate/live_engine_request_env.t index 59a2219..6d3e3e9 100644 --- a/t/aggregate/live_engine_request_env.t +++ b/t/aggregate/live_engine_request_env.t @@ -16,15 +16,15 @@ BEGIN { $EXPECTED_ENV_VAL = "Test env value " . rand(100000); } -use Test::More tests => 7; +use Test::More; use Catalyst::Test 'TestApp'; use Catalyst::Request; use HTTP::Headers; use HTTP::Request::Common; -{ - my $response = request("http://localhost/dump/env", { +foreach my $path (qw/ env env_on_engine /) { + my $response = request("http://localhost/dump/${path}", { extra_env => { $EXPECTED_ENV_VAR => $EXPECTED_ENV_VAL }, }); @@ -35,7 +35,7 @@ use HTTP::Request::Common; my $env; ok( eval '$env = ' . $response->content, 'Unserialize Catalyst::Request' ); is ref($env), 'HASH'; - ok exists($env->{PATH_INFO}), 'Have a PATH_INFO env var'; + ok exists($env->{PATH_INFO}), 'Have a PATH_INFO env var for ' . $path; SKIP: { @@ -43,7 +43,9 @@ use HTTP::Request::Common; skip 'Using remote server', 1; } is $env->{$EXPECTED_ENV_VAR}, $EXPECTED_ENV_VAL, - 'Value we set as expected'; + 'Value we set as expected for ' . $path; } } +done_testing; + diff --git a/t/aggregate/live_engine_request_uri.t b/t/aggregate/live_engine_request_uri.t index b26e156..5618e7c 100644 --- a/t/aggregate/live_engine_request_uri.t +++ b/t/aggregate/live_engine_request_uri.t @@ -14,7 +14,8 @@ my $creq; { ok( my $response = request('http://localhost/engine/request/uri/change_path'), 'Request' ); ok( $response->is_success, 'Response Successful 2xx' ); - ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' ); + ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' ) + or diag("Exception '$@', content " . $response->content); like( $creq->uri, qr{/my/app/lives/here$}, 'URI contains new path' ); } diff --git a/t/aggregate/psgi_file.t b/t/aggregate/psgi_file.t index 7327d4a..0e07d21 100644 --- a/t/aggregate/psgi_file.t +++ b/t/aggregate/psgi_file.t @@ -6,6 +6,7 @@ use lib "$FindBin::Bin/../lib"; use File::Temp qw/ tempdir /; use TestApp; use File::Spec; +use Carp qw/croak/; my $home = tempdir( CLEANUP => 1 ); my $path = File::Spec->catfile($home, 'testapp.psgi'); @@ -19,11 +20,26 @@ use TestApp; TestApp->psgi_app; }; close($psgi); + +my ($saved_stdout, $saved_stderr); +my $stdout = !open( $saved_stdout, '>&'. STDOUT->fileno ); +my $stderr = !open( $saved_stderr, '>&'. STDERR->fileno ); +open( STDOUT, '+>', undef ) + or croak("Can't reopen stdout to /dev/null"); +open( STDERR, '+>', undef ) + or croak("Can't reopen stdout to /dev/null"); # Check we wrote out something that compiles system($^X, '-I', "$FindBin::Bin/../lib", '-c', $path) ? fail('.psgi does not compile') : pass('.psgi compiles'); +if ($stdout) { + open( STDOUT, '>&'. fileno($saved_stdout) ); +} +if ($stderr) { + open( STDERR, '>&'. fileno($saved_stderr) ); +} + # NOTE - YOU *CANNOT* do something like: #my $psgi_ref = require $path; # otherwise this test passes! diff --git a/t/aggregate/unit_core_action.t b/t/aggregate/unit_core_action.t index ca84422..4520846 100644 --- a/t/aggregate/unit_core_action.t +++ b/t/aggregate/unit_core_action.t @@ -4,6 +4,7 @@ use warnings; use Moose::Meta::Class; #use Moose::Meta::Attribute; use Catalyst::Request; +use Catalyst::Log; use_ok('Catalyst::Action'); @@ -38,7 +39,7 @@ my $anon_meta = Moose::Meta::Class->create_anon_class( request => ( reader => 'request', required => 1, - default => sub { Catalyst::Request->new(arguments => [qw/one two/]) }, + default => sub { Catalyst::Request->new(_log => Catalyst::Log->new, arguments => [qw/one two/]) }, ), ), ], diff --git a/t/aggregate/unit_core_ctx_attr.t b/t/aggregate/unit_core_ctx_attr.t index 219600f..4f21cfe 100644 --- a/t/aggregate/unit_core_ctx_attr.t +++ b/t/aggregate/unit_core_ctx_attr.t @@ -8,6 +8,7 @@ use URI; use_ok('TestApp'); my $request = Catalyst::Request->new( { + _log => Catalyst::Log->new, base => URI->new('http://127.0.0.1/foo') } ); my $dispatcher = TestApp->dispatcher; diff --git a/t/aggregate/unit_core_engine-prepare_path.t b/t/aggregate/unit_core_engine-prepare_path.t index d315396..cfeaddf 100644 --- a/t/aggregate/unit_core_engine-prepare_path.t +++ b/t/aggregate/unit_core_engine-prepare_path.t @@ -126,13 +126,12 @@ sub get_req { PATH_INFO => '/', ); - my $engine = Catalyst::Engine->new( - env => { %template, @_ }, - ); + my $engine = Catalyst::Engine->new(); my $i = TestApp->new; $i->setup_finished(0); $i->config(use_request_uri_for_path => $use_request_uri_for_path); $i->setup_finished(1); + $engine->prepare_request($i, env => { %template, @_ }, response_cb => sub {}); $engine->prepare_path($i); return $i->req; } diff --git a/t/aggregate/unit_core_uri_for.t b/t/aggregate/unit_core_uri_for.t index dad5a1c..6732024 100644 --- a/t/aggregate/unit_core_uri_for.t +++ b/t/aggregate/unit_core_uri_for.t @@ -8,6 +8,7 @@ use URI; use_ok('TestApp'); my $request = Catalyst::Request->new( { + _log => Catalyst::Log->new, base => URI->new('http://127.0.0.1/foo') } ); my $dispatcher = TestApp->dispatcher; diff --git a/t/aggregate/unit_core_uri_for_action.t b/t/aggregate/unit_core_uri_for_action.t index f7cd481..9b34229 100644 --- a/t/aggregate/unit_core_uri_for_action.t +++ b/t/aggregate/unit_core_uri_for_action.t @@ -102,6 +102,7 @@ is($dispatcher->uri_for_action($chained_action, [ 1 ]), # Tests with Context # my $request = Catalyst::Request->new( { + _log => Catalyst::Log->new, base => URI->new('http://127.0.0.1/foo') } ); diff --git a/t/aggregate/unit_core_uri_for_multibytechar.t b/t/aggregate/unit_core_uri_for_multibytechar.t index 6f5d8ae..b167818 100644 --- a/t/aggregate/unit_core_uri_for_multibytechar.t +++ b/t/aggregate/unit_core_uri_for_multibytechar.t @@ -10,6 +10,7 @@ use_ok('TestApp'); my $base = 'http://127.0.0.1'; my $request = Catalyst::Request->new({ + _log => Catalyst::Log->new, base => URI->new($base), uri => URI->new("$base/"), }); diff --git a/t/aggregate/unit_core_uri_with.t b/t/aggregate/unit_core_uri_with.t index c8a3ef0..5e86318 100644 --- a/t/aggregate/unit_core_uri_with.t +++ b/t/aggregate/unit_core_uri_with.t @@ -1,12 +1,14 @@ use strict; use warnings; -use Test::More tests => 10; +use Test::More; use URI; +use Catalyst::Log; use_ok('Catalyst::Request'); my $request = Catalyst::Request->new( { + _log => Catalyst::Log->new, uri => URI->new('http://127.0.0.1/foo/bar/baz') } ); @@ -23,6 +25,7 @@ is( ); my $request2 = Catalyst::Request->new( { + _log => Catalyst::Log->new, uri => URI->new('http://127.0.0.1/foo/bar/baz?bar=gorch') } ); is( @@ -67,3 +70,5 @@ is( 'append mode URI appends arrayref param' ); +done_testing; + diff --git a/t/author/podcoverage.t b/t/author/podcoverage.t index b43b2df..2875c7d 100644 --- a/t/author/podcoverage.t +++ b/t/author/podcoverage.t @@ -10,6 +10,9 @@ our @private = ( 'BUILD' ); foreach my $module (@modules) { local @private = (@private, 'run') if $module =~ /^Catalyst::Script::/; local @private = (@private, 'plugin') if $module =~ /^Catalyst$/; + local @private = (@private, 'snippets') if $module =~ /^Catalyst::Request$/; + local @private = (@private, 'prepare_connection') if $module =~ /^Catalyst::Engine$/; + pod_coverage_ok($module, { also_private => \@private, coverage_class => 'Pod::Coverage::TrustPod', diff --git a/t/author/spelling.t b/t/author/spelling.t index 60520bd..e96c346 100644 --- a/t/author/spelling.t +++ b/t/author/spelling.t @@ -18,6 +18,105 @@ add_stopwords(qw( filename tempname request's subdirectory ini uninstalled uppercased wiki bitmask uri url urls dir hostname proxied http https IP SSL inline INLINE plugins + Andreas + Ashton + Axel + Balint + Belka + Brocard + Caelum + Cassidy + Dagfinn + Danijel + Dhanani + Dhaval + Diment + Doran + Edvinsson + Florian + Geoff + Grundman + Hartmaier + Hawes + Ilmari + Johan + Kamholz + Kiefer + Kieren + Kitover + Kogman + Kostyuk + Kubb + Lammel + Lindstrom + MannsÃ¥ker + Marienborg + Marrandi + McWhirter + Milicevic + Miyagawa + Montes + Naughton + Oleg + Ragwitz + Ramberg + Rasnita + Reis + Riedel + Rockway + Roditi + Rodland + Ruthven + Sascha + Schutz + Sedlacek + Sheidlower + SpiceMan + Szilakszi + Tatsuhiko + Ulf + Vilain + Viljo + Wardley + Westermann + Willert + Yuval + abraxxa + abw + andyg + audreyt + bricas + chansen + dhoss + dkubb + dwc + esskar + fREW + fireartist + frew + gabb + groditi + hobbs + ilmari + jcamacho + jhannah + jon + konobi + marcus + miyagawa + mst + naughton + ningu + nothingmuch + numa + obra + phaylon + rafl + rainboxx + sri + szbalint + willert + wreis )); set_spell_cmd('aspell list -l en'); all_pod_files_spelling_ok(); diff --git a/t/lib/TestApp/Controller/Dump.pm b/t/lib/TestApp/Controller/Dump.pm index 69431b3..84ebe8d 100644 --- a/t/lib/TestApp/Controller/Dump.pm +++ b/t/lib/TestApp/Controller/Dump.pm @@ -10,6 +10,13 @@ sub default : Action { sub env : Action Relative { my ( $self, $c ) = @_; + $c->stash(env => $c->req->env); + $c->forward('TestApp::View::Dump::Env'); +} + +sub env_on_engine : Action Relative { + my ( $self, $c ) = @_; + $c->stash(env => $c->engine->env); $c->forward('TestApp::View::Dump::Env'); } diff --git a/t/lib/TestApp/View/Dump.pm b/t/lib/TestApp/View/Dump.pm index d7cc1a2..2699103 100644 --- a/t/lib/TestApp/View/Dump.pm +++ b/t/lib/TestApp/View/Dump.pm @@ -21,6 +21,7 @@ sub dump { $dumper->Quotekeys(0); $dumper->Terse(1); + local $SIG{ __WARN__ } = sub { warn unless $_[ 0 ] =~ m{dummy} }; return $dumper->Dump; } diff --git a/t/lib/TestApp/View/Dump/Env.pm b/t/lib/TestApp/View/Dump/Env.pm index d713b0e..08d938c 100644 --- a/t/lib/TestApp/View/Dump/Env.pm +++ b/t/lib/TestApp/View/Dump/Env.pm @@ -5,7 +5,7 @@ use base qw[TestApp::View::Dump]; sub process { my ( $self, $c ) = @_; - my $env = $c->engine->env; + my $env = $c->stash->{env}; return $self->SUPER::process($c, { map { ($_ => $env->{$_}) } grep { $_ ne 'psgi.input' } diff --git a/t/lib/TestApp/View/Dump/Request.pm b/t/lib/TestApp/View/Dump/Request.pm index 5655b3f..97926ec 100644 --- a/t/lib/TestApp/View/Dump/Request.pm +++ b/t/lib/TestApp/View/Dump/Request.pm @@ -5,7 +5,9 @@ use base qw[TestApp::View::Dump]; sub process { my ( $self, $c ) = @_; - return $self->SUPER::process( $c, $c->request ); + my $r = $c->request; + local $r->{env}; + return $self->SUPER::process( $c, $r ); } 1; diff --git a/t/lib/TestApp/View/Dump/Response.pm b/t/lib/TestApp/View/Dump/Response.pm index 010d01c..3f9b361 100644 --- a/t/lib/TestApp/View/Dump/Response.pm +++ b/t/lib/TestApp/View/Dump/Response.pm @@ -5,7 +5,10 @@ use base qw[TestApp::View::Dump]; sub process { my ( $self, $c ) = @_; - return $self->SUPER::process( $c, $c->response ); + my $r = $c->response; + local $r->{_writer}; + local $r->{_reponse_cb}; + return $self->SUPER::process( $c, $r ); } 1; diff --git a/t/live_component_controller_context_closure.t b/t/live_component_controller_context_closure.t index 767822d..7e111f3 100644 --- a/t/live_component_controller_context_closure.t +++ b/t/live_component_controller_context_closure.t @@ -14,7 +14,7 @@ use FindBin; use lib "$FindBin::Bin/lib"; BEGIN { $::setup_leakchecker = 1 } - +local $SIG{__WARN__} = sub { return if $_[0] =~ /Unhandled type: GLOB/; warn $_[0] }; use Catalyst::Test 'TestApp'; { diff --git a/t/psgi_file_testapp_engine_plackup_compat.t b/t/psgi_file_testapp_engine_plackup_compat.t index 9af4910..3578c6c 100644 --- a/t/psgi_file_testapp_engine_plackup_compat.t +++ b/t/psgi_file_testapp_engine_plackup_compat.t @@ -10,7 +10,7 @@ use TestApp; use HTTP::Request::Common; plan skip_all => "Catalyst::Engine::PSGI required for this test" - unless eval { require Catalyst::Engine::PSGI; 1; }; + unless eval { local $SIG{__WARN__} = sub{}; require Catalyst::Engine::PSGI; 1; }; my $warning; local $SIG{__WARN__} = sub { $warning = $_[0] };