From: Florian Ragwitz Date: Thu, 14 Jan 2010 04:02:47 +0000 (+0000) Subject: Merge branch 'master' into psgi X-Git-Tag: 5.89000~42 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=commitdiff_plain;h=d5c1270360c155009fa138b6f0630044304f3c86;hp=-c Merge branch 'master' into psgi master: Depend on n:c 0.12 to work on perl >= 5.11.2. Version 5.80018. canonical() is a no-op for the base uri. Fix a deprecation warning in the tests. Fix URI bug masked by HTTP::Request::AsCGI Deprecate bare imports of Catalyst::Test - either use an app name or don't run the import method. As-per r12564 Apply patch to clarify uri_for action from Octavian Rasnita on list Version 5.80017. require autoclean once only Bump version of ::Role::WithOverloading Bump dep Un stupid Correctly pass argv option into Catalyst::Engine::HTTP Changelog Adopt::NEXT warnings Back out r12493, use \Q instead Don't screw over people using --detach, Clarify comment. Conflicts: lib/Catalyst/Engine/CGI.pm lib/Catalyst/Engine/HTTP.pm t/aggregate/unit_core_script_server.t --- d5c1270360c155009fa138b6f0630044304f3c86 diff --combined Makefile.PL index d779464,750b279..d3bcff3 --- a/Makefile.PL +++ b/Makefile.PL @@@ -17,14 -17,13 +17,13 @@@ all_from 'lib/Catalyst/Runtime.pm' requires 'List::MoreUtils'; requires 'namespace::autoclean' => '0.09'; - requires 'namespace::clean'; - requires 'namespace::autoclean'; + requires 'namespace::clean' => '0.12'; requires 'B::Hooks::EndOfScope' => '0.08'; requires 'MooseX::Emulate::Class::Accessor::Fast' => '0.00903'; requires 'Class::MOP' => '0.95'; requires 'Moose' => '0.93'; - requires 'MooseX::MethodAttributes::Inheritable' => '0.17'; - requires 'MooseX::Role::WithOverloading' => '0.03'; + requires 'MooseX::MethodAttributes::Inheritable' => '0.19'; + requires 'MooseX::Role::WithOverloading' => '0.05'; requires 'Carp'; requires 'Class::C3::Adopt::NEXT' => '0.07'; requires 'CGI::Simple::Cookie'; @@@ -44,7 -43,6 +43,7 @@@ requires 'Text::SimpleTable' => '0.03' requires 'Time::HiRes'; requires 'Tree::Simple' => '1.15'; requires 'Tree::Simple::Visitor::FindByPath'; +requires 'Try::Tiny'; requires 'URI' => '1.35'; requires 'Task::Weaken'; requires 'Text::Balanced'; # core in 5.8.x but mentioned for completeness @@@ -53,8 -51,6 +52,8 @@@ requires 'MooseX::Getopt' => '0.25' requires 'MooseX::Types'; requires 'MooseX::Types::Common::Numeric'; requires 'String::RewritePrefix' => '0.004'; # Catalyst::Utils::resolve_namespace +requires 'Plack' => '0.9030'; +requires 'Plack::Middleware::ReverseProxy' => '0.04'; test_requires 'Class::Data::Inheritable'; test_requires 'Test::Exception'; diff --combined lib/Catalyst.pm index 737ccc4,f1c63fd..06130d1 --- a/lib/Catalyst.pm +++ b/lib/Catalyst.pm @@@ -30,7 -30,6 +30,7 @@@ use List::MoreUtils qw/uniq/ use attributes; use utf8; use Carp qw/croak carp shortmess/; +use Try::Tiny; BEGIN { require 5.008004; } @@@ -69,17 -68,17 +69,17 @@@ our $GO = Catalyst::Exception::G __PACKAGE__->mk_classdata($_) for qw/components arguments dispatcher engine log dispatcher_class engine_class context_class request_class response_class stats_class - setup_finished/; + setup_finished psgi_app/; __PACKAGE__->dispatcher_class('Catalyst::Dispatcher'); -__PACKAGE__->engine_class('Catalyst::Engine::CGI'); +__PACKAGE__->engine_class('Catalyst::Engine'); __PACKAGE__->request_class('Catalyst::Request'); __PACKAGE__->response_class('Catalyst::Response'); __PACKAGE__->stats_class('Catalyst::Stats'); # Remember to update this in Catalyst::Runtime as well! - our $VERSION = '5.80016'; + our $VERSION = '5.80018'; $VERSION = eval $VERSION; sub import { @@@ -1330,6 -1329,20 +1330,20 @@@ $c->uri_for >> You can also pass in a Catalyst::Action object, in which case it is passed to C<< $c->uri_for >>. + Note that although the path looks like a URI that dispatches to the wanted action, it is not a URI, but an internal path to that action. + + For example, if the action looks like: + + package MyApp::Controller::Users; + + sub lst : Path('the-list') {} + + You can use: + + $c->uri_for_action('/users/lst') + + and it will create the URI /users/the-list. + =back =cut @@@ -1848,7 -1861,7 +1862,7 @@@ sub handle_request # Always expect worst case! my $status = -1; - eval { + try { if ($class->debug) { my $secs = time - $START || 1; my $av = sprintf '%.3f', $COUNT / $secs; @@@ -1859,11 -1872,12 +1873,11 @@@ my $c = $class->prepare(@arguments); $c->dispatch; $status = $c->finalize; - }; - - if ( my $error = $@ ) { - chomp $error; - $class->log->error(qq/Caught exception in engine "$error"/); } + catch { + chomp(my $error = $_); + $class->log->error(qq/Caught exception in engine "$error"/); + }; $COUNT++; @@@ -1900,38 -1914,28 +1914,38 @@@ sub prepare $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION ); } - #XXX reuse coderef from can - # Allow engine to direct the prepare flow (for POE) - if ( $c->engine->can('prepare') ) { - $c->engine->prepare( $c, @arguments ); - } - else { - $c->prepare_request(@arguments); - $c->prepare_connection; - $c->prepare_query_parameters; - $c->prepare_headers; - $c->prepare_cookies; - $c->prepare_path; - - # Prepare the body for reading, either by prepare_body - # or the user, if they are using $c->read - $c->prepare_read; - - # Parse the body unless the user wants it on-demand - unless ( ref($c)->config->{parse_on_demand} ) { - $c->prepare_body; + try { + # Allow engine to direct the prepare flow (for POE) + if ( my $prepare = $c->engine->can('prepare') ) { + $c->engine->$prepare( $c, @arguments ); + } + else { + $c->prepare_request(@arguments); + $c->prepare_connection; + $c->prepare_query_parameters; + $c->prepare_headers; + $c->prepare_cookies; + $c->prepare_path; + + # Prepare the body for reading, either by prepare_body + # or the user, if they are using $c->read + $c->prepare_read; + + # Parse the body unless the user wants it on-demand + unless ( ref($c)->config->{parse_on_demand} ) { + $c->prepare_body; + } } } + # VERY ugly and probably shouldn't rely on ->finalize actually working + catch { + # failed prepare is always due to an invalid request, right? + $c->response->status(400); + $c->response->content_type('text/plain'); + $c->response->body('Bad Request'); + $c->finalize; + die $_; + }; my $method = $c->req->method || ''; my $path = $c->req->path; @@@ -2359,7 -2363,72 +2373,7 @@@ Sets up engine =cut sub setup_engine { - my ( $class, $engine ) = @_; - - if ($engine) { - $engine = 'Catalyst::Engine::' . $engine; - } - - if ( my $env = Catalyst::Utils::env_value( $class, 'ENGINE' ) ) { - $engine = 'Catalyst::Engine::' . $env; - } - - if ( $ENV{MOD_PERL} ) { - my $meta = Class::MOP::get_metaclass_by_name($class); - - # create the apache method - $meta->add_method('apache' => sub { shift->engine->apache }); - - my ( $software, $version ) = - $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/; - - $version =~ s/_//g; - $version =~ s/(\.[^.]+)\./$1/g; - - if ( $software eq 'mod_perl' ) { - - if ( !$engine ) { - - if ( $version >= 1.99922 ) { - $engine = 'Catalyst::Engine::Apache2::MP20'; - } - - elsif ( $version >= 1.9901 ) { - $engine = 'Catalyst::Engine::Apache2::MP19'; - } - - elsif ( $version >= 1.24 ) { - $engine = 'Catalyst::Engine::Apache::MP13'; - } - - else { - Catalyst::Exception->throw( message => - qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ ); - } - - } - - # install the correct mod_perl handler - if ( $version >= 1.9901 ) { - *handler = sub : method { - shift->handle_request(@_); - }; - } - else { - *handler = sub ($$) { shift->handle_request(@_) }; - } - - } - - elsif ( $software eq 'Zeus-Perl' ) { - $engine = 'Catalyst::Engine::Zeus'; - } - - else { - Catalyst::Exception->throw( - message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ ); - } - } + my ($class, $engine) = @_; unless ($engine) { $engine = $class->engine_class; @@@ -2399,8 -2468,8 +2413,8 @@@ ); } - # engine instance $class->engine( $engine->new ); + $class->psgi_app( $class->engine->build_psgi_app($class) ); } =head2 $c->setup_home @@@ -2889,6 -2958,8 +2903,8 @@@ numa: Dan Sully diff --combined lib/Catalyst/Engine.pm index ff7e548,7ba4167..ee4477a --- a/lib/Catalyst/Engine.pm +++ b/lib/Catalyst/Engine.pm @@@ -10,14 -10,10 +10,14 @@@ use HTML::Entities use HTTP::Body; use HTTP::Headers; use URI::QueryParam; +use Moose::Util::TypeConstraints; +use Plack::Loader; +use Plack::Middleware::Conditional; +use Plack::Middleware::ReverseProxy; use namespace::clean -except => 'meta'; -has env => (is => 'rw'); +has env => (is => 'ro', writer => '_set_env', clearer => '_clear_env'); # input position and length has read_length => (is => 'rw'); @@@ -25,20 -21,6 +25,20 @@@ 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', +); + +has _writer => ( + is => 'ro', + isa => duck_type([qw(write close)]), + writer => '_set_writer', + clearer => '_clear_writer', +); + # Amount of data to read from input on each pass our $CHUNKSIZE = 64 * 1024; @@@ -77,12 -59,6 +77,12 @@@ sub finalize_body else { $self->write( $c, $body ); } + + $self->_writer->close; + $self->_clear_writer; + $self->_clear_env; + + return; } =head2 $self->finalize_cookies($c) @@@ -304,7 -280,8 +304,8 @@@ sub finalize_error - # Trick IE + # Trick IE. Old versions of IE would display their own error page instead + # of ours if we'd give it less than 512 bytes. $c->res->{body} .= ( ' ' x 512 ); # Return 500 @@@ -317,17 -294,7 +318,17 @@@ Abstract method, allows engines to writ =cut -sub finalize_headers { } +sub finalize_headers { + my ($self, $ctx) = @_; + + my @headers; + $ctx->response->headers->scan(sub { push @headers, @_ }); + + $self->_set_writer($self->_response_cb->([ $ctx->response->status, \@headers ])); + $self->_clear_response_cb; + + return; +} =head2 $self->finalize_read($c) @@@ -423,22 -390,7 +424,22 @@@ Abstract method implemented in engines =cut -sub prepare_connection { } +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) @@@ -458,19 -410,7 +459,19 @@@ sub prepare_cookies =cut -sub prepare_headers { } +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}); + } +} =head2 $self->prepare_parameters($c) @@@ -508,47 -448,7 +509,47 @@@ abstract method, implemented by engines =cut -sub prepare_path { } +sub prepare_path { + my ($self, $ctx) = @_; + + my $env = $self->env; + + my $scheme = $ctx->request->secure ? 'https' : 'http'; + my $host = $env->{HTTP_HOST} || $env->{SERVER_NAME}; + my $port = $env->{SERVER_PORT} || 80; + my $base_path = $env->{SCRIPT_NAME} || "/"; + + # set the request URI + my $req_uri = $env->{REQUEST_URI}; + $req_uri =~ s/\?.*$//; + my $path = $req_uri; + $path =~ s{^/+}{}; + + # Using URI directly is way too slow, so we construct the URLs manually + my $uri_class = "URI::$scheme"; + + # HTTP_HOST will include the port even if it's 80/443 + $host =~ s/:(?:80|443)$//; + + if ($port !~ /^(?:80|443)$/ && $host !~ /:/) { + $host .= ":$port"; + } + + my $query = $env->{QUERY_STRING} ? '?' . $env->{QUERY_STRING} : ''; + my $uri = $scheme . '://' . $host . '/' . $path . $query; + + $ctx->request->uri( (bless \$uri, $uri_class)->canonical ); + + # set the base URI + # base must end in a slash + $base_path .= '/' unless $base_path =~ m{/$}; + + my $base_uri = $scheme . '://' . $host . $base_path; + + $ctx->request->base( bless \$base_uri, $uri_class ); + + return; +} =head2 $self->prepare_request($c) @@@ -559,11 -459,7 +560,11 @@@ process the query string and extract qu =cut sub prepare_query_parameters { - my ( $self, $c, $query_string ) = @_; + my ($self, $c) = @_; + + my $query_string = exists $self->env->{QUERY_STRING} + ? $self->env->{QUERY_STRING} + : ''; # Check for keywords (no = signs) # (yes, index() is faster than a regex :)) @@@ -625,10 -521,7 +626,10 @@@ Populate the context object from the re =cut -sub prepare_request { } +sub prepare_request { + my ($self, $ctx, %args) = @_; + $self->_set_env($args{env}); +} =head2 $self->prepare_uploads($c) @@@ -708,7 -601,7 +709,7 @@@ sub read 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. FIXME - Warn in the log here? + # said there should be. $self->finalize_read; return; } @@@ -729,10 -622,7 +730,10 @@@ there is no more data to be read =cut -sub read_chunk { } +sub read_chunk { + my ($self, $ctx) = (shift, shift); + return $self->env->{'psgi.input'}->read(@_); +} =head2 $self->read_length @@@ -749,37 -639,7 +750,37 @@@ Start the engine. Implemented by the va =cut -sub run { } +sub run { + my ($self, $app, $server, @args) = @_; + # FIXME - Do something sensible with the options we're passed + $server->run($self->build_psgi_app($app, @args)); +} + +sub build_psgi_app { + my ($self, $app, @args) = @_; + + my $psgi_app = sub { + my ($env) = @_; + + return sub { + my ($respond) = @_; + $self->_set_response_cb($respond); + $app->handle_request(env => $env); + }; + }; + + $psgi_app = Plack::Middleware::Conditional->wrap( + $psgi_app, + condition => sub { + my ($env) = @_; + return if $app->config->{ignore_frontend_proxy}; + return $env->{REMOTE_ADDR} eq '127.0.0.1' || $app->config->{using_frontend_proxy}; + }, + builder => sub { Plack::Middleware::ReverseProxy->wrap($_[0]) }, + ); + + return $psgi_app; +} =head2 $self->write($c, $buffer) @@@ -797,10 -657,31 +798,10 @@@ sub write return 0 if !defined $buffer; - my $len = length($buffer); - my $wrote = syswrite STDOUT, $buffer; - - if ( !defined $wrote && $! == EWOULDBLOCK ) { - # Unable to write on the first try, will retry in the loop below - $wrote = 0; - } - - if ( defined $wrote && $wrote < $len ) { - # We didn't write the whole buffer - while (1) { - my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote; - if ( defined $ret ) { - $wrote += $ret; - } - else { - next if $! == EWOULDBLOCK; - return; - } - - last if $wrote >= $len; - } - } + my $len = length($buffer); + $self->_writer->write($buffer); - return $wrote; + return $len; } =head2 $self->unescape_uri($uri) diff --combined lib/Catalyst/Script/FastCGI.pm index f4c3c27,60b4133..c806439 --- a/lib/Catalyst/Script/FastCGI.pm +++ b/lib/Catalyst/Script/FastCGI.pm @@@ -1,10 -1,10 +1,10 @@@ package Catalyst::Script::FastCGI; - -BEGIN { $ENV{CATALYST_ENGINE} ||= 'FastCGI' } use Moose; use MooseX::Types::Moose qw/Str Bool Int/; use namespace::autoclean; +sub _plack_engine_name { 'FCGI' } + with 'Catalyst::ScriptRole'; has listen => ( @@@ -27,7 -27,7 +27,7 @@@ has daemon => traits => [qw(Getopt)], isa => Bool, is => 'ro', - cmd_aliases => 'd', + cmd_aliases => [qw/d detach/], # Eww, detach is here as we fucked it up.. Deliberately not documented documentation => 'Daemonize (go into the background)', ); @@@ -55,14 -55,6 +55,14 @@@ has nproc => documentation => 'Specify a number of child processes', ); +sub _plack_loader_args { + my ($self) = shift; + return ( + map { $_ => $self->$_() } + qw/pidfile listen manager nproc detach keep_stderr/ + ); +} + sub _application_args { my ($self) = shift; return ( diff --combined lib/Catalyst/Script/Server.pm index 7798c55,e1f1049..003a57e --- a/lib/Catalyst/Script/Server.pm +++ b/lib/Catalyst/Script/Server.pm @@@ -1,12 -1,16 +1,12 @@@ package Catalyst::Script::Server; - -BEGIN { - $ENV{CATALYST_ENGINE} ||= 'HTTP'; - require Catalyst::Engine::HTTP; -} - use Moose; use MooseX::Types::Common::Numeric qw/PositiveInt/; use MooseX::Types::Moose qw/ArrayRef Str Bool Int RegexpRef/; use Catalyst::Utils; use namespace::autoclean; +sub _plack_engine_name { 'Standalone' } + with 'Catalyst::ScriptRole'; __PACKAGE__->meta->get_attribute('help')->cmd_aliases('?'); @@@ -180,21 -184,13 +180,22 @@@ sub run } +sub _plack_loader_args { + my ($self) = shift; + return ( + port => $self->port, + host => $self->host, + keepalive => $self->keepalive ? 100 : 1, + ); +} + sub _application_args { my ($self) = shift; return ( $self->port, $self->host, { + argv => $self->ARGV, map { $_ => $self->$_ } qw/ fork keepalive diff --combined lib/Catalyst/Test.pm index 7868e03,f987172..3962927 --- a/lib/Catalyst/Test.pm +++ b/lib/Catalyst/Test.pm @@@ -4,12 -4,10 +4,12 @@@ use strict use warnings; use Test::More (); +use Plack::Test; use Catalyst::Exception; use Catalyst::Utils; use Class::MOP; use Sub::Exporter; +use Carp; my $build_exports = sub { my ($self, $meth, $args, $defaults) = @_; @@@ -19,17 -17,15 +19,17 @@@ if ( $ENV{CATALYST_SERVER} ) { $request = sub { remote_request(@_) }; - } elsif (! $class) { - $request = sub { Catalyst::Exception->throw("Must specify a test app: use Catalyst::Test 'TestApp'") }; + } elsif (!$class) { + $request = sub { croak "Must specify a test app: use Catalyst::Test 'TestApp'"; } } else { unless (Class::MOP::is_class_loaded($class)) { Class::MOP::load_class($class); } $class->import; - $request = sub { local_request( $class, @_ ) }; + my $app = $class->psgi_app; + + $request = sub { local_request( $app, @_ ) }; } my $get = sub { $request->(@_)->content }; @@@ -107,6 -103,12 +107,12 @@@ our $default_host sub import { my ($self, $class, $opts) = @_; + Carp::carp( + qq{Importing Catalyst::Test without an application name is deprecated:\n + Instead of saying: use Catalyst::Test; + say: use Catalyst::Test (); # If you don't want to import a test app right now. + or say: use Catalyst::Test 'MyApp'; # If you do want to import a test app.\n\n}) + unless $class; $import->($self, '-all' => { class => $class }); $opts = {} unless ref $opts eq 'HASH'; $default_host = $opts->{default_host} if exists $opts->{default_host}; @@@ -222,18 -224,19 +228,18 @@@ Simulate a request using Lnew( $request, %ENV )->setup; + my $request = Catalyst::Utils::request(shift); + my %extra_env; + _customize_request($request, \%extra_env, @_); - $class->handle_request( env => \%ENV ); + my $ret; + test_psgi + app => sub { $app->({ %{ $_[0] }, %extra_env }) }, + client => sub { $ret = shift->($request) }; - my $response = $cgi->restore->response; - $response->request( $request ); - return $response; + return $ret; } my $agent; @@@ -306,16 -309,11 +312,16 @@@ sub remote_request sub _customize_request { my $request = shift; + my $extra_env = shift; my $opts = pop(@_) || {}; $opts = {} unless ref($opts) eq 'HASH'; if ( my $host = exists $opts->{host} ? $opts->{host} : $default_host ) { $request->header( 'Host' => $host ); } + + if (my $extra = $opts->{extra_env}) { + @{ $extra_env }{keys %{ $extra }} = values %{ $extra }; + } } =head2 action_ok diff --combined t/aggregate/unit_core_script_server.t index d901354,b9ad60b..2508452 --- a/t/aggregate/unit_core_script_server.t +++ b/t/aggregate/unit_core_script_server.t @@@ -89,8 -89,8 +89,10 @@@ sub testOption }; # First element of RUN_ARGS will be the script name, which we don't care about shift @TestAppToTestScripts::RUN_ARGS; + my $server = shift @TestAppToTestScripts::RUN_ARGS; + like ref($server), qr/^Plack::Server/, 'Is a Plack Server'; + # Mangle argv into the options.. + $resultarray->[-1]->{argv} = $argstring; is_deeply \@TestAppToTestScripts::RUN_ARGS, $resultarray, "is_deeply comparison " . join(' ', @$argstring); } diff --combined t/aggregate/unit_load_catalyst_test.t index 00a829d,036c3b8..399b190 --- a/t/aggregate/unit_load_catalyst_test.t +++ b/t/aggregate/unit_load_catalyst_test.t @@@ -3,9 -3,7 +3,7 @@@ use strict; use warnings; - use FindBin; - use lib "$FindBin::Bin/../lib"; - use Test::More tests => 61; + use Test::More; use FindBin qw/$Bin/; use lib "$Bin/../lib"; use Catalyst::Utils; @@@ -26,7 -24,7 +24,7 @@@ my %Meth = ### make sure we're not trying to connect to a remote host -- these are local tests local $ENV{CATALYST_SERVER}; - use_ok( $Class ); + use Catalyst::Test (); ### check available methods { ### turn of redefine warnings, we'll get new subs exported @@@ -109,7 -107,7 +107,7 @@@ # FIXME - These vhosts in tests tests should be somewhere else... -sub customize { Catalyst::Test::_customize_request(@_) } +sub customize { Catalyst::Test::_customize_request($_[0], {}, @_[1 .. $#_]) } { my $req = Catalyst::Utils::request('/dummy'); @@@ -155,3 -153,4 +153,4 @@@ lives_ok request(GET('/dummy'), []); } 'array additional param to request method ignored'; + done_testing;