[Catalyst-commits] r12561 - in
Catalyst-Runtime/5.80/branches/psgi/lib: . Catalyst
rafl at dev.catalyst.perl.org
rafl at dev.catalyst.perl.org
Sat Jan 9 17:48:31 GMT 2010
Author: rafl
Date: 2010-01-09 17:48:31 +0000 (Sat, 09 Jan 2010)
New Revision: 12561
Modified:
Catalyst-Runtime/5.80/branches/psgi/lib/Catalyst.pm
Catalyst-Runtime/5.80/branches/psgi/lib/Catalyst/Engine.pm
Catalyst-Runtime/5.80/branches/psgi/lib/Catalyst/ScriptRole.pm
Log:
Work towards supporting psgi.
Modified: Catalyst-Runtime/5.80/branches/psgi/lib/Catalyst/Engine.pm
===================================================================
--- Catalyst-Runtime/5.80/branches/psgi/lib/Catalyst/Engine.pm 2010-01-09 17:46:50 UTC (rev 12560)
+++ Catalyst-Runtime/5.80/branches/psgi/lib/Catalyst/Engine.pm 2010-01-09 17:48:31 UTC (rev 12561)
@@ -10,10 +10,11 @@
use HTTP::Body;
use HTTP::Headers;
use URI::QueryParam;
+use Moose::Util::TypeConstraints;
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');
@@ -21,6 +22,18 @@
has _prepared_write => (is => 'rw');
+has _response_cb => (
+ is => 'ro',
+ isa => 'CodeRef',
+ writer => '_set_response_cb',
+);
+
+has _writer => (
+ is => 'ro',
+ isa => duck_type([qw(write close)]),
+ writer => '_set_writer',
+);
+
# Amount of data to read from input on each pass
our $CHUNKSIZE = 64 * 1024;
@@ -293,8 +306,17 @@
=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 ]));
+
+ return;
+}
+
=head2 $self->finalize_read($c)
=cut
@@ -389,8 +411,23 @@
=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' );
+
+ return;
+}
+
=head2 $self->prepare_cookies($c)
Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
@@ -409,8 +446,20 @@
=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)
sets up parameters from query and post parameters.
@@ -447,8 +496,52 @@
=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 = $self->unescape_uri($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";
+ }
+
+ # Escape the path
+ $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
+ $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
+
+ my $query = $env->{QUERY_STRING} ? '?' . $env->{QUERY_STRING} : '';
+ my $uri = $scheme . '://' . $host . '/' . $path . $query;
+
+ $ctx->request->uri( bless \$uri, $uri_class );
+
+ # 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)
=head2 $self->prepare_query_parameters($c)
@@ -458,8 +551,12 @@
=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 :))
if ( index( $query_string, '=' ) < 0 ) {
@@ -520,7 +617,10 @@
=cut
-sub prepare_request { }
+sub prepare_request {
+ my ($self, $ctx, %args) = @_;
+ $self->_set_env($args{env});
+}
=head2 $self->prepare_uploads($c)
@@ -638,8 +738,20 @@
=cut
-sub run { }
+sub run {
+ my ($self, $app) = @_;
+ return sub {
+ my ($env) = @_;
+
+ return sub {
+ my ($respond) = @_;
+ $self->_set_response_cb($respond);
+ $app->handle_request(env => $env);
+ };
+ };
+}
+
=head2 $self->write($c, $buffer)
Writes the buffer to the client.
@@ -656,31 +768,10 @@
return 0 if !defined $buffer;
- my $len = length($buffer);
- my $wrote = syswrite STDOUT, $buffer;
+ my $len = length($buffer);
+ $self->_writer->write($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;
- }
- }
-
- return $wrote;
+ return $len;
}
=head2 $self->unescape_uri($uri)
Modified: Catalyst-Runtime/5.80/branches/psgi/lib/Catalyst/ScriptRole.pm
===================================================================
--- Catalyst-Runtime/5.80/branches/psgi/lib/Catalyst/ScriptRole.pm 2010-01-09 17:46:50 UTC (rev 12560)
+++ Catalyst-Runtime/5.80/branches/psgi/lib/Catalyst/ScriptRole.pm 2010-01-09 17:48:31 UTC (rev 12561)
@@ -1,5 +1,6 @@
package Catalyst::ScriptRole;
use Moose::Role;
+use Plack::Runner;
use MooseX::Types::Moose qw/Str Bool/;
use Pod::Usage;
use MooseX::Getopt;
@@ -59,7 +60,8 @@
my $self = shift;
my $app = $self->application_name;
Class::MOP::load_class($app);
- $app->run($self->_application_args);
+ my $psgi_app = $app->run($self->_application_args);
+ Plack::Runner->run('--app' => $psgi_app);
}
1;
Modified: Catalyst-Runtime/5.80/branches/psgi/lib/Catalyst.pm
===================================================================
--- Catalyst-Runtime/5.80/branches/psgi/lib/Catalyst.pm 2010-01-09 17:46:50 UTC (rev 12560)
+++ Catalyst-Runtime/5.80/branches/psgi/lib/Catalyst.pm 2010-01-09 17:48:31 UTC (rev 12561)
@@ -71,7 +71,7 @@
setup_finished/;
__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');
@@ -2349,73 +2349,8 @@
=cut
sub setup_engine {
- my ( $class, $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}/ );
- }
- }
-
unless ($engine) {
$engine = $class->engine_class;
}
More information about the Catalyst-commits
mailing list