requires 'B::Hooks::EndOfScope' => '0.08';
requires 'MooseX::Emulate::Class::Accessor::Fast' => '0.00903';
requires 'Class::MOP' => '0.95';
+requires 'Data::OptList';
requires 'Moose' => '1.03';
requires 'MooseX::MethodAttributes::Inheritable' => '0.24';
requires 'MooseX::Role::WithOverloading' => '0.05';
+requires 'MooseX::Types::LoadableClass' => '0.003';
requires 'Carp';
requires 'Class::C3::Adopt::NEXT' => '0.07';
requires 'CGI::Simple::Cookie' => '1.109';
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
requires 'MooseX::Types';
requires 'MooseX::Types::Common::Numeric';
requires 'String::RewritePrefix' => '0.004'; # Catalyst::Utils::resolve_namespace
+requires 'Plack' => '0.9935'; # Setup empty PATH_INFO if needed
+requires 'Plack::Middleware::ReverseProxy' => '0.04';
test_requires 'Class::Data::Inheritable';
test_requires 'Test::Exception';
test_requires 'Test::More' => '0.88';
+test_requires 'Data::Dump';
# aggregate tests if AGGREGATE_TESTS is set and a recent Test::Aggregate and a Test::Simple it works with is available
if ($ENV{AGGREGATE_TESTS} && can_use('Test::Simple', '0.88') && can_use('Test::Aggregate', '0.364')) {
# REFACTORING
+## PSGI
+
+### Blockers
+
+ * properly pass along server arguments
+ * Add some tests for Catalyst::Test::local_request
+
+### Nice to have
+
+ * throw out Catalyst::Test's remote_request in favour of
+ Plack::Test::ExternalServer
+ * make sure we're running under a server that support psgi.streaming - maybe
+ just load the BufferedWrite middleware, although that might break things
+ relying on ->write doing an unbuffered write
+ * throw away the restarter and allow using the restarters Plack provides
+ * remove per-request state from the engine instance
+ * be smarter about how we use PSGI - not every response needs to be delayed
+ and streaming
+
## The horrible hack for plugin setup - replacing it:
* Have a look at the Devel::REPL BEFORE_PLUGIN stuff
use Class::C3::Adopt::NEXT;
use List::MoreUtils qw/uniq/;
use attributes;
+use String::RewritePrefix;
use utf8;
use Carp qw/croak carp shortmess/;
+use Try::Tiny;
BEGIN { require 5.008004; }
__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');
# Always expect worst case!
my $status = -1;
- eval {
+ try {
if ($class->debug) {
my $secs = time - $START || 1;
my $av = sprintf '%.3f', $COUNT / $secs;
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++;
$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;
=cut
-sub run { my $c = shift; return $c->engine->run( $c, @_ ) }
+sub run { my $c = shift; return $c->engine->run( $c, $c->psgi_app, @_ ) }
=head2 $c->set_action( $action, $code, $namespace, $attrs )
=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;
}
+ else {
+ $engine = String::RewritePrefix->rewrite( { '' => 'Catalyst::Engine::', '+' => '' }, $engine );
+ }
+
+ $engine = 'Catalyst::Engine' if $engine eq 'Catalyst::Engine::HTTP';
Class::MOP::load_class($engine);
);
}
- # engine instance
+ if ($ENV{MOD_PERL}) {
+ require 'Catalyst/Engine/Loader.pm';
+ my $apache = Catalyst::Engine::Loader->auto;
+ # FIXME - Immutable
+ $class->meta->add_method(handler => sub {
+ my $r = shift;
+ my $app = $class->psgi_app;
+ $apache->call_app($r, $app);
+ });
+ }
+
$class->engine( $engine->new );
+
+ return;
+}
+
+=head2 $c->psgi_app
+
+Builds a PSGI application coderef for the catalyst application C<$c> using
+L</"$c->setup_psgi_app">, stores it internally, and returns it. On the next call
+to this method, C<setup_psgi_app> won't be invoked again, but its persisted
+return value of it will be returned.
+
+This is the top-level entrypoint for things that need a full blown Catalyst PSGI
+app. If you only need the raw PSGI application, without any middlewares, use
+L</"$c->raw_psgi_app"> instead.
+
+=cut
+
+sub psgi_app {
+ my ($app) = @_;
+
+ unless ($app->_psgi_app) {
+ my $psgi_app = $app->setup_psgi_app;
+ $app->_psgi_app($psgi_app);
+ }
+
+ return $app->_psgi_app;
+}
+
+=head2 $c->setup_psgi_app
+
+Builds a PSGI application coderef for the catalyst application C<$c>.
+
+If we're able to locate a C<${myapp}.psgi> file in the applications home
+directory, we'll use that to obtain our code reference.
+
+Otherwise the raw psgi app, without any middlewares is created using
+C<raw_psgi_app> and wrapped into L<Plack::Middleware::ReverseProxy>
+conditionally. See L</"PROXY SUPPORT">.
+
+=cut
+
+sub setup_psgi_app {
+ my ($app) = @_;
+
+ if (my $home = Path::Class::Dir->new($app->config->{home})) {
+ my $psgi_file = $home->file(
+ Catalyst::Utils::appprefix($app) . '.psgi',
+ );
+
+ return Plack::Util::load_psgi($psgi_file)
+ if -e $psgi_file;
+ }
+
+ return Plack::Middleware::Conditional->wrap(
+ $app->raw_psgi_app,
+ builder => sub { Plack::Middleware::ReverseProxy->wrap($_[0]) },
+ 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};
+ },
+ );
+}
+
+=head2 $c->raw_psgi_app
+
+Returns a PSGI application code reference for the catalyst application
+C<$c>. This is the bare application without any middlewares
+applied. C<${myapp}.psgi> is not taken into account. See
+L</"$c->setup_psgi_app">.
+
+=cut
+
+sub raw_psgi_app {
+ my ($app) = @_;
+ return $app->engine->build_psgi_app($app);
}
=head2 $c->setup_home
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 Encode ();
use utf8;
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');
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;
else {
$self->write( $c, $body );
}
+
+ $self->_writer->close;
+ $self->_clear_writer;
+ $self->_clear_env;
+
+ return;
}
=head2 $self->finalize_cookies($c)
=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)
=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)
=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)
=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 $path;
+ if (!$ctx->config->{use_request_uri_for_path}) {
+ my $path_info = $env->{PATH_INFO};
+ if ( exists $env->{REDIRECT_URL} ) {
+ $base_path = $env->{REDIRECT_URL};
+ $base_path =~ s/\Q$path_info\E$//;
+ }
+ $path = $base_path . $path_info;
+ $path =~ s{^/+}{};
+ $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
+ $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
+ }
+ else {
+ my $req_uri = $env->{REQUEST_URI};
+ $req_uri =~ s/\?.*$//;
+ $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)
=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 :))
=cut
-sub prepare_request { }
+sub prepare_request {
+ my ($self, $ctx, %args) = @_;
+ $self->_set_env($args{env});
+}
=head2 $self->prepare_uploads($c)
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;
}
=cut
-sub read_chunk { }
+sub read_chunk {
+ my ($self, $ctx) = (shift, shift);
+ return $self->env->{'psgi.input'}->read(@_);
+}
=head2 $self->read_length
The amount of input data that has already been read.
-=head2 $self->run($c)
+=head2 $self->run($app, $server)
-Start the engine. Implemented by the various engine classes.
+Start the engine. Builds a PSGI application and calls the
+run method on the server passed in..
=cut
-sub run { }
+sub run {
+ my ($self, $app, $psgi, @args) = @_;
+ # FIXME - Do something sensible with the options we're passed
+ my $server = pop @args if blessed $args[-1];
+ $server ||= Plack::Loader->auto(); # We're not being called from a script,
+ # so auto detect what backend to run on.
+ # This does *NOT* cover mod_perl.
+ $server->run($psgi);
+}
+
+=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.
+
+=cut
+
+sub build_psgi_app {
+ my ($self, $app, @args) = @_;
+
+ return sub {
+ my ($env) = @_;
+
+ return sub {
+ my ($respond) = @_;
+ $self->_set_response_cb($respond);
+ $app->handle_request(env => $env);
+ };
+ };
+}
=head2 $self->write($c, $buffer)
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)
+++ /dev/null
-package Catalyst::Engine::CGI;
-
-use Moose;
-extends 'Catalyst::Engine';
-
-has _header_buf => (is => 'rw', clearer => '_clear_header_buf', predicate => '_has_header_buf');
-
-=head1 NAME
-
-Catalyst::Engine::CGI - The CGI Engine
-
-=head1 SYNOPSIS
-
-A script using the Catalyst::Engine::CGI module might look like:
-
- #!/usr/bin/perl -w
-
- use strict;
- use lib '/path/to/MyApp/lib';
- use MyApp;
-
- MyApp->run;
-
-The application module (C<MyApp>) would use C<Catalyst>, which loads the
-appropriate engine module.
-
-=head1 DESCRIPTION
-
-This is the Catalyst engine specialized for the CGI environment.
-
-=head1 PATH DECODING
-
-Most web server environments pass the requested path to the application using environment variables,
-from which Catalyst has to reconstruct the request base (i.e. the top level path to / in the application,
-exposed as C<< $c->request->base >>) and the request path below that base.
-
-There are two methods of doing this, both of which have advantages and disadvantages. Which method is used
-is determined by the C<< $c->config(use_request_uri_for_path) >> setting (which can either be true or false).
-
-=head2 use_request_uri_for_path => 0
-
-This is the default (and the) traditional method that Catalyst has used for determining the path information.
-The path is synthesised from a combination of the C<PATH_INFO> and C<SCRIPT_NAME> environment variables.
-The allows the application to behave correctly when C<mod_rewrite> is being used to redirect requests
-into the application, as these variables are adjusted by mod_rewrite to take account for the redirect.
-
-However this method has the major disadvantage that it is impossible to correctly decode some elements
-of the path, as RFC 3875 says: "C<< Unlike a URI path, the PATH_INFO is not URL-encoded, and cannot
-contain path-segment parameters. >>" This means PATH_INFO is B<always> decoded, and therefore Catalyst
-can't distinguish / vs %2F in paths (in addition to other encoded values).
-
-=head2 use_request_uri_for_path => 1
-
-This method uses the C<REQUEST_URI> and C<SCRIPT_NAME> environment variables. As C<REQUEST_URI> is never
-decoded, this means that applications using this mode can correctly handle URIs including the %2F character
-(i.e. with C<AllowEncodedSlashes> set to C<On> in Apache).
-
-Given that this method of path resolution is provably more correct, it is recommended that you use
-this unless you have a specific need to deploy your application in a non-standard environment, and you are
-aware of the implications of not being able to handle encoded URI paths correctly.
-
-However it also means that in a number of cases when the app isn't installed directly at a path, but instead
-is having paths rewritten into it (e.g. as a .cgi/fcgi in a public_html directory, with mod_rewrite in a
-.htaccess file, or when SSI is used to rewrite pages into the app, or when sub-paths of the app are exposed
-at other URIs than that which the app is 'normally' based at with C<mod_rewrite>), the resolution of
-C<< $c->request->base >> will be incorrect.
-
-=head1 OVERLOADED METHODS
-
-This class overloads some methods from C<Catalyst::Engine>.
-
-=head2 $self->finalize_headers($c)
-
-=cut
-
-sub finalize_headers {
- my ( $self, $c ) = @_;
-
- $c->response->header( Status => $c->response->status );
-
- $self->_header_buf($c->response->headers->as_string("\015\012") . "\015\012");
-}
-
-=head2 $self->prepare_connection($c)
-
-=cut
-
-sub prepare_connection {
- my ( $self, $c ) = @_;
- local (*ENV) = $self->env || \%ENV;
-
- my $request = $c->request;
- $request->address( $ENV{REMOTE_ADDR} );
-
- PROXY_CHECK:
- {
- unless ( ref($c)->config->{using_frontend_proxy} ) {
- last PROXY_CHECK if $ENV{REMOTE_ADDR} ne '127.0.0.1';
- last PROXY_CHECK if ref($c)->config->{ignore_frontend_proxy};
- }
- last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_FOR};
-
- # If we are running as a backend server, the user will always appear
- # as 127.0.0.1. Select the most recent upstream IP (last in the list)
- my ($ip) = $ENV{HTTP_X_FORWARDED_FOR} =~ /([^,\s]+)$/;
- $request->address($ip);
- if ( defined $ENV{HTTP_X_FORWARDED_PORT} ) {
- $ENV{SERVER_PORT} = $ENV{HTTP_X_FORWARDED_PORT};
- }
- }
-
- $request->hostname( $ENV{REMOTE_HOST} ) if exists $ENV{REMOTE_HOST};
- $request->protocol( $ENV{SERVER_PROTOCOL} );
- $request->user( $ENV{REMOTE_USER} ); # XXX: Deprecated. See Catalyst::Request for removal information
- $request->remote_user( $ENV{REMOTE_USER} );
- $request->method( $ENV{REQUEST_METHOD} );
-
- if ( $ENV{HTTPS} && uc( $ENV{HTTPS} ) eq 'ON' ) {
- $request->secure(1);
- }
-
- if ( $ENV{SERVER_PORT} == 443 ) {
- $request->secure(1);
- }
- binmode(STDOUT); # Ensure we are sending bytes.
-}
-
-=head2 $self->prepare_headers($c)
-
-=cut
-
-sub prepare_headers {
- my ( $self, $c ) = @_;
- local (*ENV) = $self->env || \%ENV;
- my $headers = $c->request->headers;
- # Read headers from %ENV
- foreach my $header ( keys %ENV ) {
- next unless $header =~ /^(?:HTTP|CONTENT|COOKIE)/i;
- ( my $field = $header ) =~ s/^HTTPS?_//;
- $headers->header( $field => $ENV{$header} );
- }
-}
-
-=head2 $self->prepare_path($c)
-
-=cut
-
-# Please don't touch this method without adding tests in
-# t/aggregate/unit_core_engine_cgi-prepare_path.t
-sub prepare_path {
- my ( $self, $c ) = @_;
- local (*ENV) = $self->env || \%ENV;
-
- my $scheme = $c->request->secure ? 'https' : 'http';
- my $host = $ENV{HTTP_HOST} || $ENV{SERVER_NAME};
- my $port = $ENV{SERVER_PORT} || 80;
-
- # fix up for IIS
- if ($ENV{SERVER_SOFTWARE} && $ENV{SERVER_SOFTWARE} =~ m{IIS/[6-9]\.\d}) {
- $ENV{PATH_INFO} =~ s/^\Q$ENV{SCRIPT_NAME}\E//;
- }
-
- my $script_name = $ENV{SCRIPT_NAME};
- $script_name =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go if $script_name;
-
- my $base_path;
- if ( exists $ENV{REDIRECT_URL} ) {
- $base_path = $ENV{REDIRECT_URL};
- $base_path =~ s/\Q$ENV{PATH_INFO}\E$//;
- }
- else {
- $base_path = $script_name || '/';
- }
-
- # If we are running as a backend proxy, get the true hostname
- PROXY_CHECK:
- {
- unless ( ref($c)->config->{using_frontend_proxy} ) {
- last PROXY_CHECK if $host !~ /localhost|127.0.0.1/;
- last PROXY_CHECK if ref($c)->config->{ignore_frontend_proxy};
- }
- last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_HOST};
-
- $host = $ENV{HTTP_X_FORWARDED_HOST};
-
- # backend could be on any port, so
- # assume frontend is on the default port
- $port = $c->request->secure ? 443 : 80;
- if ( $ENV{HTTP_X_FORWARDED_PORT} ) {
- $port = $ENV{HTTP_X_FORWARDED_PORT};
- }
- }
-
- my $path_info = $ENV{PATH_INFO};
- if ($c->config->{use_request_uri_for_path}) {
- # RFC 3875: "Unlike a URI path, the PATH_INFO is not URL-encoded,
- # and cannot contain path-segment parameters." This means PATH_INFO
- # is always decoded, and the script can't distinguish / vs %2F.
- # See https://issues.apache.org/bugzilla/show_bug.cgi?id=35256
- # Here we try to resurrect the original encoded URI from REQUEST_URI.
- if (my $req_uri = $ENV{REQUEST_URI}) {
- if (defined $script_name) {
- $req_uri =~ s/^\Q$script_name\E//;
- }
- $req_uri =~ s/\?.*$//;
- $path_info = $req_uri if $req_uri;
- }
- }
-
- # set the request URI
- my $path = $base_path . ( $path_info || '' );
- $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;
-
- $c->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;
-
- $c->request->base( bless \$base_uri, $uri_class );
-}
-
-=head2 $self->prepare_query_parameters($c)
-
-=cut
-
-around prepare_query_parameters => sub {
- my $orig = shift;
- my ( $self, $c ) = @_;
- local (*ENV) = $self->env || \%ENV;
-
- if ( $ENV{QUERY_STRING} ) {
- $self->$orig( $c, $ENV{QUERY_STRING} );
- }
-};
-
-=head2 $self->prepare_request($c, (env => \%env))
-
-=cut
-
-sub prepare_request {
- my ( $self, $c, %args ) = @_;
-
- if ( $args{env} ) {
- $self->env( $args{env} );
- }
-}
-
-=head2 $self->prepare_write($c)
-
-Enable autoflush on the output handle for CGI-based engines.
-
-=cut
-
-around prepare_write => sub {
- *STDOUT->autoflush(1);
- return shift->(@_);
-};
-
-=head2 $self->write($c, $buffer)
-
-Writes the buffer to the client.
-
-=cut
-
-around write => sub {
- my $orig = shift;
- my ( $self, $c, $buffer ) = @_;
-
- # Prepend the headers if they have not yet been sent
- if ( $self->_has_header_buf ) {
- $buffer = $self->_clear_header_buf . $buffer;
- }
-
- return $self->$orig( $c, $buffer );
-};
-
-=head2 $self->read_chunk($c, $buffer, $length)
-
-=cut
-
-sub read_chunk { shift; shift; *STDIN->sysread(@_); }
-
-=head2 $self->run
-
-=cut
-
-sub run { shift; shift->handle_request( env => \%ENV ) }
-
-=head1 SEE ALSO
-
-L<Catalyst>, L<Catalyst::Engine>
-
-=head1 AUTHORS
-
-Catalyst Contributors, see Catalyst.pm
-
-=head1 COPYRIGHT
-
-This library is free software. You can redistribute it and/or modify it under
-the same terms as Perl itself.
-
-=cut
-no Moose;
-
-1;
+++ /dev/null
-package Catalyst::Engine::FastCGI;
-
-use Moose;
-extends 'Catalyst::Engine::CGI';
-
-# eval { Class::MOP::load_class("FCGI") };
-eval "use FCGI";
-die "Unable to load the FCGI module, you may need to install it:\n$@\n" if $@;
-
-=head1 NAME
-
-Catalyst::Engine::FastCGI - FastCGI Engine
-
-=head1 DESCRIPTION
-
-This is the FastCGI engine.
-
-=head1 OVERLOADED METHODS
-
-This class overloads some methods from C<Catalyst::Engine::CGI>.
-
-=head2 $self->run($c, $listen, { option => value, ... })
-
-Starts the FastCGI server. If C<$listen> is set, then it specifies a
-location to listen for FastCGI requests;
-
-=over 4
-
-=item /path
-
-listen via Unix sockets on /path
-
-=item :port
-
-listen via TCP on port on all interfaces
-
-=item hostname:port
-
-listen via TCP on port bound to hostname
-
-=back
-
-Options may also be specified;
-
-=over 4
-
-=item leave_umask
-
-Set to 1 to disable setting umask to 0 for socket open
-
-=item nointr
-
-Do not allow the listener to be interrupted by Ctrl+C
-
-=item nproc
-
-Specify a number of processes for FCGI::ProcManager
-
-=item pidfile
-
-Specify a filename for the pid file
-
-=item manager
-
-Specify a FCGI::ProcManager sub-class
-
-=item detach
-
-Detach from console
-
-=item keep_stderr
-
-Send STDERR to STDOUT instead of the webserver
-
-=back
-
-=cut
-
-sub run {
- my ( $self, $class, $listen, $options ) = @_;
-
- my $sock = 0;
- if ($listen) {
- my $old_umask = umask;
- unless ( $options->{leave_umask} ) {
- umask(0);
- }
- $sock = FCGI::OpenSocket( $listen, 100 )
- or die "failed to open FastCGI socket; $!";
- unless ( $options->{leave_umask} ) {
- umask($old_umask);
- }
- }
- elsif ( $^O ne 'MSWin32' ) {
- -S STDIN
- or die "STDIN is not a socket; specify a listen location";
- }
-
- $options ||= {};
-
- my %env;
- my $error = \*STDERR; # send STDERR to the web server
- $error = \*STDOUT # send STDERR to stdout (a logfile)
- if $options->{keep_stderr}; # (if asked to)
-
- my $request =
- FCGI::Request( \*STDIN, \*STDOUT, $error, \%env, $sock,
- ( $options->{nointr} ? 0 : &FCGI::FAIL_ACCEPT_ON_INTR ),
- );
-
- my $proc_manager;
-
- if ($listen) {
- $options->{manager} ||= "FCGI::ProcManager";
- $options->{nproc} ||= 1;
- $options->{proc_title} ||= "perl-fcgi-pm [$class]";
-
- $self->daemon_fork() if $options->{detach};
-
- if ( $options->{manager} ) {
- eval "use $options->{manager}; 1" or die $@;
-
- $proc_manager = $options->{manager}->new(
- {
- n_processes => $options->{nproc},
- pid_fname => $options->{pidfile},
- pm_title => $options->{proc_title},
- }
- );
-
- # detach *before* the ProcManager inits
- $self->daemon_detach() if $options->{detach};
-
- $proc_manager->pm_manage();
-
- # Give each child its own RNG state.
- srand;
- }
- elsif ( $options->{detach} ) {
- $self->daemon_detach();
- }
- }
-
- while ( $request->Accept >= 0 ) {
- $proc_manager && $proc_manager->pm_pre_dispatch();
-
- $self->_fix_env( \%env );
-
- $class->handle_request( env => \%env );
-
- $proc_manager && $proc_manager->pm_post_dispatch();
- }
-}
-
-=head2 $self->write($c, $buffer)
-
-=cut
-
-sub write {
- my ( $self, $c, $buffer ) = @_;
-
- unless ( $self->_prepared_write ) {
- $self->prepare_write($c);
- $self->_prepared_write(1);
- }
-
- # XXX: We can't use Engine's write() method because syswrite
- # appears to return bogus values instead of the number of bytes
- # written: http://www.fastcgi.com/om_archive/mail-archive/0128.html
-
- # Prepend the headers if they have not yet been sent
- if ( $self->_has_header_buf ) {
- $buffer = $self->_clear_header_buf . $buffer;
- }
-
- # FastCGI does not stream data properly if using 'print $handle',
- # but a syswrite appears to work properly.
- *STDOUT->syswrite($buffer);
-}
-
-=head2 $self->daemon_fork()
-
-Performs the first part of daemon initialisation. Specifically,
-forking. STDERR, etc are still connected to a terminal.
-
-=cut
-
-sub daemon_fork {
- require POSIX;
- fork && exit;
-}
-
-=head2 $self->daemon_detach( )
-
-Performs the second part of daemon initialisation. Specifically,
-disassociates from the terminal.
-
-However, this does B<not> change the current working directory to "/",
-as normal daemons do. It also does not close all open file
-descriptors (except STDIN, STDOUT and STDERR, which are re-opened from
-F</dev/null>).
-
-=cut
-
-sub daemon_detach {
- my $self = shift;
- print "FastCGI daemon started (pid $$)\n";
- open STDIN, "+</dev/null" or die $!;
- open STDOUT, ">&STDIN" or die $!;
- open STDERR, ">&STDIN" or die $!;
- POSIX::setsid();
-}
-
-=head2 $self->_fix_env( $env )
-
-Adjusts the environment variables when necessary.
-
-=cut
-
-sub _fix_env
-{
- my $self = shift;
- my $env = shift;
-
- # we are gonna add variables from current system environment %ENV to %env
- # that contains at this moment just variables taken from FastCGI request
- foreach my $k (keys(%ENV)) {
- $env->{$k} = $ENV{$k} unless defined($env->{$k});
- }
-
- return unless ( $env->{SERVER_SOFTWARE} );
-
- # If we're running under Lighttpd, swap PATH_INFO and SCRIPT_NAME
- # http://lists.scsys.co.uk/pipermail/catalyst/2006-June/008361.html
- # Thanks to Mark Blythe for this fix
- if ( $env->{SERVER_SOFTWARE} =~ /lighttpd/ ) {
- $env->{PATH_INFO} ||= delete $env->{SCRIPT_NAME};
- }
- elsif ( $env->{SERVER_SOFTWARE} =~ /^nginx/ ) {
- my $script_name = $env->{SCRIPT_NAME};
- $env->{PATH_INFO} =~ s/^$script_name//g;
- }
- # Fix the environment variables PATH_INFO and SCRIPT_NAME when running
- # under IIS
- elsif ( $env->{SERVER_SOFTWARE} =~ /IIS\/[6-9]\.[0-9]/ ) {
- my @script_name = split(m!/!, $env->{PATH_INFO});
- my @path_translated = split(m!/|\\\\?!, $env->{PATH_TRANSLATED});
- my @path_info;
-
- while ($script_name[$#script_name] eq $path_translated[$#path_translated]) {
- pop(@path_translated);
- unshift(@path_info, pop(@script_name));
- }
-
- unshift(@path_info, '', '');
-
- $env->{PATH_INFO} = join('/', @path_info);
- $env->{SCRIPT_NAME} = join('/', @script_name);
- }
-}
-
-1;
-__END__
-
-=head1 WEB SERVER CONFIGURATIONS
-
-=head2 Standalone FastCGI Server
-
-In server mode the application runs as a standalone server and accepts
-connections from a web server. The application can be on the same machine as
-the web server, on a remote machine, or even on multiple remote machines.
-Advantages of this method include running the Catalyst application as a
-different user than the web server, and the ability to set up a scalable
-server farm.
-
-To start your application in server mode, install the FCGI::ProcManager
-module and then use the included fastcgi.pl script.
-
- $ script/myapp_fastcgi.pl -l /tmp/myapp.socket -n 5
-
-Command line options for fastcgi.pl include:
-
- -d -daemon Daemonize the server.
- -p -pidfile Write a pidfile with the pid of the process manager.
- -l -listen Listen on a socket path, hostname:port, or :port.
- -n -nproc The number of processes started to handle requests.
-
-See below for the specific web server configurations for using the external
-server.
-
-=head2 Apache 1.x, 2.x
-
-Apache requires the mod_fastcgi module. The same module supports both
-Apache 1 and 2.
-
-There are three ways to run your application under FastCGI on Apache: server,
-static, and dynamic.
-
-=head3 Standalone server mode
-
- FastCgiExternalServer /tmp/myapp.fcgi -socket /tmp/myapp.socket
- Alias /myapp/ /tmp/myapp.fcgi/
-
- # Or, run at the root
- Alias / /tmp/myapp.fcgi/
-
- # Optionally, rewrite the path when accessed without a trailing slash
- RewriteRule ^/myapp$ myapp/ [R]
-
-
-The FastCgiExternalServer directive tells Apache that when serving
-/tmp/myapp to use the FastCGI application listenting on the socket
-/tmp/mapp.socket. Note that /tmp/myapp.fcgi B<MUST NOT> exist --
-it's a virtual file name. With some versions of C<mod_fastcgi> or
-C<mod_fcgid>, you can use any name you like, but some require that the
-virtual filename end in C<.fcgi>.
-
-It's likely that Apache is not configured to serve files in /tmp, so the
-Alias directive maps the url path /myapp/ to the (virtual) file that runs the
-FastCGI application. The trailing slashes are important as their use will
-correctly set the PATH_INFO environment variable used by Catalyst to
-determine the request path. If you would like to be able to access your app
-without a trailing slash (http://server/myapp), you can use the above
-RewriteRule directive.
-
-=head3 Static mode
-
-The term 'static' is misleading, but in static mode Apache uses its own
-FastCGI Process Manager to start the application processes. This happens at
-Apache startup time. In this case you do not run your application's
-fastcgi.pl script -- that is done by Apache. Apache then maps URIs to the
-FastCGI script to run your application.
-
- FastCgiServer /path/to/myapp/script/myapp_fastcgi.pl -processes 3
- Alias /myapp/ /path/to/myapp/script/myapp_fastcgi.pl/
-
-FastCgiServer tells Apache to start three processes of your application at
-startup. The Alias command maps a path to the FastCGI application. Again,
-the trailing slashes are important.
-
-=head3 Dynamic mode
-
-In FastCGI dynamic mode, Apache will run your application on demand,
-typically by requesting a file with a specific extension (e.g. .fcgi). ISPs
-often use this type of setup to provide FastCGI support to many customers.
-
-In this mode it is often enough to place or link your *_fastcgi.pl script in
-your cgi-bin directory with the extension of .fcgi. In dynamic mode Apache
-must be able to run your application as a CGI script so ExecCGI must be
-enabled for the directory.
-
- AddHandler fastcgi-script .fcgi
-
-The above tells Apache to run any .fcgi file as a FastCGI application.
-
-Here is a complete example:
-
- <VirtualHost *:80>
- ServerName www.myapp.com
- DocumentRoot /path/to/MyApp
-
- # Allow CGI script to run
- <Directory /path/to/MyApp>
- Options +ExecCGI
- </Directory>
-
- # Tell Apache this is a FastCGI application
- <Files myapp_fastcgi.pl>
- SetHandler fastcgi-script
- </Files>
- </VirtualHost>
-
-Then a request for /script/myapp_fastcgi.pl will run the
-application.
-
-For more information on using FastCGI under Apache, visit
-L<http://www.fastcgi.com/mod_fastcgi/docs/mod_fastcgi.html>
-
-=head3 Authorization header with mod_fastcgi or mod_cgi
-
-By default, mod_fastcgi/mod_cgi do not pass along the Authorization header,
-so modules like C<Catalyst::Plugin::Authentication::Credential::HTTP> will
-not work. To enable pass-through of this header, add the following
-mod_rewrite directives:
-
- RewriteCond %{HTTP:Authorization} ^(.+)
- RewriteRule ^(.*)$ $1 [E=HTTP_AUTHORIZATION:%1,PT]
-
-=head2 Lighttpd
-
-These configurations were tested with Lighttpd 1.4.7.
-
-=head3 Standalone server mode
-
- server.document-root = "/var/www/MyApp/root"
-
- fastcgi.server = (
- "" => (
- "MyApp" => (
- "socket" => "/tmp/myapp.socket",
- "check-local" => "disable"
- )
- )
- )
-
-=head3 Static mode
-
- server.document-root = "/var/www/MyApp/root"
-
- fastcgi.server = (
- "" => (
- "MyApp" => (
- "socket" => "/tmp/myapp.socket",
- "check-local" => "disable",
- "bin-path" => "/var/www/MyApp/script/myapp_fastcgi.pl",
- "min-procs" => 2,
- "max-procs" => 5,
- "idle-timeout" => 20
- )
- )
- )
-
-Note that in newer versions of lighttpd, the min-procs and idle-timeout
-values are disabled. The above example would start 5 processes.
-
-=head3 Non-root configuration
-
-You can also run your application at any non-root location with either of the
-above modes. Note the required mod_rewrite rule.
-
- url.rewrite = ( "myapp\$" => "myapp/" )
- fastcgi.server = (
- "/myapp" => (
- "MyApp" => (
- # same as above
- )
- )
- )
-
-For more information on using FastCGI under Lighttpd, visit
-L<http://www.lighttpd.net/documentation/fastcgi.html>
-
-=head2 nginx
-
-Catalyst runs under nginx via FastCGI in a similar fashion as the lighttpd
-standalone server as described above.
-
-nginx does not have its own internal FastCGI process manager, so you must run
-the FastCGI service separately.
-
-=head3 Configuration
-
-To configure nginx, you must configure the FastCGI parameters and also the
-socket your FastCGI daemon is listening on. It can be either a TCP socket
-or a Unix file socket.
-
-The server configuration block should look roughly like:
-
- server {
- listen $port;
-
- location / {
- fastcgi_param QUERY_STRING $query_string;
- fastcgi_param REQUEST_METHOD $request_method;
- fastcgi_param CONTENT_TYPE $content_type;
- fastcgi_param CONTENT_LENGTH $content_length;
-
- fastcgi_param SCRIPT_NAME /;
- fastcgi_param PATH_INFO $fastcgi_script_name;
- fastcgi_param REQUEST_URI $request_uri;
- fastcgi_param DOCUMENT_URI $document_uri;
- fastcgi_param DOCUMENT_ROOT $document_root;
- fastcgi_param SERVER_PROTOCOL $server_protocol;
-
- fastcgi_param GATEWAY_INTERFACE CGI/1.1;
- fastcgi_param SERVER_SOFTWARE nginx/$nginx_version;
-
- fastcgi_param REMOTE_ADDR $remote_addr;
- fastcgi_param REMOTE_PORT $remote_port;
- fastcgi_param SERVER_ADDR $server_addr;
- fastcgi_param SERVER_PORT $server_port;
- fastcgi_param SERVER_NAME $server_name;
-
- # Adjust the socket for your applications!
- fastcgi_pass unix:$docroot/myapp.socket;
- }
- }
-
-It is the standard convention of nginx to include the fastcgi_params in a
-separate file (usually something like C</etc/nginx/fastcgi_params>) and
-simply include that file.
-
-=head3 Non-root configuration
-
-If you properly specify the PATH_INFO and SCRIPT_NAME parameters your
-application will be accessible at any path. The SCRIPT_NAME variable is the
-prefix of your application, and PATH_INFO would be everything in addition.
-
-As an example, if your application is rooted at /myapp, you would configure:
-
- fastcgi_param SCRIPT_NAME /myapp/;
- fastcgi_param PATH_INFO $fastcgi_script_name;
-
-C<$fastcgi_script_name> would be "/myapp/path/of/the/action". Catalyst will
-process this accordingly and setup the application base as expected.
-
-This behavior is somewhat different than Apache and Lighttpd, but is still
-functional.
-
-For more information on nginx, visit:
-L<http://nginx.net>
-
-=head2 Microsoft IIS
-
-It is possible to run Catalyst under IIS with FastCGI, but only on IIS 6.0
-(Microsoft Windows 2003), IIS 7.0 (Microsoft Windows 2008 and Vista) and
-hopefully its successors.
-
-Even if it is declared that FastCGI is supported on IIS 5.1 (Windows XP) it
-does not support some features (specifically: wildcard mappings) that prevents
-running Catalyst application.
-
-Let us assume that our server has the following layout:
-
- d:\WWW\WebApp\ path to our Catalyst application
- d:\strawberry\perl\bin\perl.exe path to perl interpreter (with Catalyst installed)
- c:\windows Windows directory
-
-=head3 Setup IIS 6.0 (Windows 2003)
-
-=over 4
-
-=item Install FastCGI extension for IIS 6.0
-
-FastCGI is not a standard part of IIS 6 - you have to install it separately. For
-more info and download go to L<http://www.iis.net/extensions/FastCGI>. Choose
-approptiate version (32-bit/64-bit), installation is quite simple
-(in fact no questions, no options).
-
-=item Create a new website
-
-Open "Control Panel" > "Administrative Tools" > "Internet Information Services Manager".
-Click "Action" > "New" > "Web Site". After you finish the installation wizard
-you need to go to the new website's properties.
-
-=item Set website properties
-
-On tab "Web site" set proper values for:
-Site Description, IP Address, TCP Port, SSL Port etc.
-
-On tab "Home Directory" set the following:
-
- Local path: "d:\WWW\WebApp\root"
- Local path permission flags: check only "Read" + "Log visits"
- Execute permitions: "Scripts only"
-
-Click "Configuration" button (still on Home Directory tab) then click "Insert"
-the wildcard application mapping and in the next dialog set:
-
- Executable: "c:\windows\system32\inetsrv\fcgiext.dll"
- Uncheck: "Verify that file exists"
-
-Close all dialogs with "OK".
-
-=item Edit fcgiext.ini
-
-Put the following lines into c:\windows\system32\inetsrv\fcgiext.ini (on 64-bit
-system c:\windows\syswow64\inetsrv\fcgiext.ini):
-
- [Types]
- *:8=CatalystApp
- ;replace 8 with the identification number of the newly created website
- ;it is not so easy to get this number:
- ; - you can use utility "c:\inetpub\adminscripts\adsutil.vbs"
- ; to list websites: "cscript adsutil.vbs ENUM /P /W3SVC"
- ; to get site name: "cscript adsutil.vbs GET /W3SVC/<number>/ServerComment"
- ; to get all details: "cscript adsutil.vbs GET /W3SVC/<number>"
- ; - or look where are the logs located:
- ; c:\WINDOWS\SYSTEM32\Logfiles\W3SVC7\whatever.log
- ; means that the corresponding number is "7"
- ;if you are running just one website using FastCGI you can use '*=CatalystApp'
-
- [CatalystApp]
- ExePath=d:\strawberry\perl\bin\perl.exe
- Arguments="d:\WWW\WebApp\script\webapp_fastcgi.pl -e"
-
- ;by setting this you can instruct IIS to serve Catalyst static files
- ;directly not via FastCGI (in case of any problems try 1)
- IgnoreExistingFiles=0
-
- ;do not be fooled by Microsoft doc talking about "IgnoreExistingDirectories"
- ;that does not work and use "IgnoreDirectories" instead
- IgnoreDirectories=1
-
-=back
-
-=head3 Setup IIS 7.0 (Windows 2008 and Vista)
-
-Microsoft IIS 7.0 has built-in support for FastCGI so you do not have to install
-any addons.
-
-=over 4
-
-=item Necessary steps during IIS7 installation
-
-During IIS7 installation after you have added role "Web Server (IIS)"
-you need to check to install role feature "CGI" (do not be nervous that it is
-not FastCGI). If you already have IIS7 installed you can add "CGI" role feature
-through "Control panel" > "Programs and Features".
-
-=item Create a new website
-
-Open "Control Panel" > "Administrative Tools" > "Internet Information Services Manager"
-> "Add Web Site".
-
- site name: "CatalystSite"
- content directory: "d:\WWW\WebApp\root"
- binding: set proper IP address, port etc.
-
-=item Configure FastCGI
-
-You can configure FastCGI extension using commandline utility
-"c:\windows\system32\inetsrv\appcmd.exe"
-
-=over 4
-
-=item Configuring section "fastCgi" (it is a global setting)
-
- appcmd.exe set config -section:system.webServer/fastCgi /+"[fullPath='d:\strawberry\perl\bin\perl.exe',arguments='d:\www\WebApp\script\webapp_fastcgi.pl -e',maxInstances='4',idleTimeout='300',activityTimeout='30',requestTimeout='90',instanceMaxRequests='1000',protocol='NamedPipe',flushNamedPipe='False']" /commit:apphost
-
-=item Configuring proper handler (it is a site related setting)
-
- appcmd.exe set config "CatalystSite" -section:system.webServer/handlers /+"[name='CatalystFastCGI',path='*',verb='GET,HEAD,POST',modules='FastCgiModule',scriptProcessor='d:\strawberry\perl\bin\perl.exe|d:\www\WebApp\script\webapp_fastcgi.pl -e',resourceType='Unspecified',requireAccess='Script']" /commit:apphost
-
-Note: before launching the commands above do not forget to change site
-name and paths to values relevant for your server setup.
-
-=back
-
-=back
-
-=head1 SEE ALSO
-
-L<Catalyst>, L<FCGI>.
-
-=head1 AUTHORS
-
-Catalyst Contributors, see Catalyst.pm
-
-=head1 THANKS
-
-Bill Moseley, for documentation updates and testing.
-
-=head1 COPYRIGHT
-
-This library is free software. You can redistribute it and/or modify it under
-the same terms as Perl itself.
-
-=cut
+++ /dev/null
-package Catalyst::Engine::HTTP;
-
-use Moose;
-extends 'Catalyst::Engine::CGI';
-
-use Data::Dump qw(dump);
-use Errno 'EWOULDBLOCK';
-use HTTP::Date ();
-use HTTP::Headers;
-use HTTP::Status;
-use Socket;
-use IO::Socket::INET ();
-use IO::Select ();
-
-use constant CHUNKSIZE => 64 * 1024;
-use constant DEBUG => $ENV{CATALYST_HTTP_DEBUG} || 0;
-
-use namespace::clean -except => 'meta';
-
-has options => ( is => 'rw' );
-has _keepalive => ( is => 'rw', predicate => '_is_keepalive', clearer => '_clear_keepalive' );
-has _write_error => ( is => 'rw', predicate => '_has_write_error' );
-
-# Refactoring note - could/should Eliminate all instances of $self->{inputbuf},
-# which I haven't touched as it is used as an lvalue in a lot of places, and I guess
-# doing it differently could be expensive.. Feel free to refactor and NYTProf :)
-
-=head1 NAME
-
-Catalyst::Engine::HTTP - Catalyst HTTP Engine
-
-=head1 SYNOPSIS
-
-A script using the Catalyst::Engine::HTTP module might look like:
-
- #!/usr/bin/perl -w
-
- BEGIN { $ENV{CATALYST_ENGINE} = 'HTTP' }
-
- use strict;
- use lib '/path/to/MyApp/lib';
- use MyApp;
-
- MyApp->run;
-
-=head1 DESCRIPTION
-
-This is the Catalyst engine specialized for development and testing.
-
-=head1 METHODS
-
-=head2 $self->finalize_headers($c)
-
-=cut
-
-sub finalize_headers {
- my ( $self, $c ) = @_;
- my $protocol = $c->request->protocol;
- my $status = $c->response->status;
- my $message = status_message($status);
- my $res_headers = $c->response->headers;
-
- my @headers;
- push @headers, "$protocol $status $message";
-
- $res_headers->header( Date => HTTP::Date::time2str(time) );
- $res_headers->header( Status => $status );
-
- # Should we keep the connection open?
- my $connection = $c->request->header('Connection');
- if ( $self->options
- && $self->options->{keepalive}
- && $connection
- && $connection =~ /^keep-alive$/i
- ) {
- $res_headers->header( Connection => 'keep-alive' );
- $self->_keepalive(1);
- }
- else {
- $res_headers->header( Connection => 'close' );
- }
-
- push @headers, $res_headers->as_string("\x0D\x0A");
-
- # Buffer the headers so they are sent with the first write() call
- # This reduces the number of TCP packets we are sending
- $self->_header_buf( join("\x0D\x0A", @headers, '') );
-}
-
-=head2 $self->finalize_read($c)
-
-=cut
-
-before finalize_read => sub {
- # Never ever remove this, it would result in random length output
- # streams if STDIN eq STDOUT (like in the HTTP engine)
- *STDIN->blocking(1);
-};
-
-=head2 $self->prepare_read($c)
-
-=cut
-
-before prepare_read => sub {
- # Set the input handle to non-blocking
- *STDIN->blocking(0);
-};
-
-=head2 $self->read_chunk($c, $buffer, $length)
-
-=cut
-
-sub read_chunk {
- my $self = shift;
- my $c = shift;
-
- # If we have any remaining data in the input buffer, send it back first
- if ( $_[0] = delete $self->{inputbuf} ) {
- my $read = length( $_[0] );
- DEBUG && warn "read_chunk: Read $read bytes from previous input buffer\n";
- return $read;
- }
-
- # support for non-blocking IO
- my $rin = '';
- vec( $rin, *STDIN->fileno, 1 ) = 1;
-
- READ:
- {
- select( $rin, undef, undef, undef );
- my $rc = *STDIN->sysread(@_);
- if ( defined $rc ) {
- DEBUG && warn "read_chunk: Read $rc bytes from socket\n";
- return $rc;
- }
- else {
- next READ if $! == EWOULDBLOCK;
- return;
- }
- }
-}
-
-=head2 $self->write($c, $buffer)
-
-Writes the buffer to the client.
-
-=cut
-
-around write => sub {
- my $orig = shift;
- my ( $self, $c, $buffer ) = @_;
-
- # Avoid 'print() on closed filehandle Remote' warnings when using IE
- return unless *STDOUT->opened();
-
- # Prepend the headers if they have not yet been sent
- if ( $self->_has_header_buf ) {
- $self->_warn_on_write_error(
- $self->$orig($c, $self->_clear_header_buf)
- );
- }
-
- $self->_warn_on_write_error($self->$orig($c, $buffer));
-};
-
-sub _warn_on_write_error {
- my ($self, $ret) = @_;
- if ( !defined $ret ) {
- $self->_write_error($!);
- DEBUG && warn "write: Failed to write response ($!)\n";
- }
- else {
- DEBUG && warn "write: Wrote response ($ret bytes)\n";
- }
- return $ret;
-}
-
-=head2 run
-
-=cut
-
-# A very very simple HTTP server that initializes a CGI environment
-sub run {
- my ( $self, $class, $port, $host, $options ) = @_;
-
- $options ||= {};
-
- $self->options($options);
-
- if ($options->{background}) {
- my $child = fork;
- die "Can't fork: $!" unless defined($child);
- return $child if $child;
- }
-
- my $restart = 0;
- local $SIG{CHLD} = 'IGNORE';
-
- my $allowed = $options->{allowed} || { '127.0.0.1' => '255.255.255.255' };
- my $addr = $host ? inet_aton($host) : INADDR_ANY;
- if ( $addr eq INADDR_ANY ) {
- require Sys::Hostname;
- $host = lc Sys::Hostname::hostname();
- }
- else {
- $host = gethostbyaddr( $addr, AF_INET ) || inet_ntoa($addr);
- }
-
- # Handle requests
-
- # Setup socket
- my $daemon = IO::Socket::INET->new(
- Listen => SOMAXCONN,
- LocalAddr => inet_ntoa($addr),
- LocalPort => $port,
- Proto => 'tcp',
- ReuseAddr => 1,
- Type => SOCK_STREAM,
- )
- or die "Couldn't create daemon: $@";
-
- $port = $daemon->sockport();
-
- my $url = "http://$host";
- $url .= ":$port" unless $port == 80;
-
- print "You can connect to your server at $url\n";
-
- if ($options->{background}) {
- open STDIN, "+</dev/null" or die $!;
- open STDOUT, ">&STDIN" or die $!;
- open STDERR, ">&STDIN" or die $!;
- if ( $^O !~ /MSWin32/ ) {
- require POSIX;
- POSIX::setsid()
- or die "Can't start a new session: $!";
- }
- }
-
- if (my $pidfile = $options->{pidfile}) {
- if (! open PIDFILE, "> $pidfile") {
- warn("Cannot open: $pidfile: $!");
- }
- print PIDFILE "$$\n";
- close PIDFILE;
- }
-
- my $pid = undef;
-
- # Ignore broken pipes as an HTTP server should
- local $SIG{PIPE} = 'IGNORE';
-
- # Restart on HUP
- local $SIG{HUP} = sub {
- $restart = 1;
- warn "Restarting server on SIGHUP...\n";
- };
-
- LISTEN:
- while ( !$restart ) {
- while ( accept( Remote, $daemon ) ) {
- DEBUG && warn "New connection\n";
-
- select Remote;
-
- Remote->blocking(1);
-
- # Read until we see all headers
- $self->{inputbuf} = '';
-
- if ( !$self->_read_headers ) {
- # Error reading, give up
- close Remote;
- next LISTEN;
- }
-
- my ( $method, $uri, $protocol ) = $self->_parse_request_line;
-
- DEBUG && warn "Parsed request: $method $uri $protocol\n";
- next unless $method;
-
- unless ( uc($method) eq 'RESTART' ) {
-
- # Fork
- if ( $options->{fork} ) {
- if ( $pid = fork ) {
- DEBUG && warn "Forked child $pid\n";
- next;
- }
- }
-
- $self->_handler( $class, $port, $method, $uri, $protocol );
-
- if ( $self->_has_write_error ) {
- close Remote;
-
- if ( !defined $pid ) {
- next LISTEN;
- }
- }
-
- if ( defined $pid ) {
- # Child process, close connection and exit
- DEBUG && warn "Child process exiting\n";
- $daemon->close;
- exit;
- }
- }
- else {
- my $sockdata = $self->_socket_data( \*Remote );
- my $ipaddr = _inet_addr( $sockdata->{peeraddr} );
- my $ready = 0;
- foreach my $ip ( keys %$allowed ) {
- my $mask = $allowed->{$ip};
- $ready = ( $ipaddr & _inet_addr($mask) ) == _inet_addr($ip);
- last if $ready;
- }
- if ($ready) {
- $restart = 1;
- last;
- }
- }
- }
- continue {
- close Remote;
- }
- }
-
- $daemon->close;
-
- DEBUG && warn "Shutting down\n";
-
- if ($restart) {
- $SIG{CHLD} = 'DEFAULT';
- wait;
-
- ### if the standalone server was invoked with perl -I .. we will loose
- ### those include dirs upon re-exec. So add them to PERL5LIB, so they
- ### are available again for the exec'ed process --kane
- use Config;
- $ENV{PERL5LIB} .= join $Config{path_sep}, @INC;
-
- exec $^X, $0, @{ $options->{argv} || [] };
- }
-
- exit;
-}
-
-sub _handler {
- my ( $self, $class, $port, $method, $uri, $protocol ) = @_;
-
- local *STDIN = \*Remote;
- local *STDOUT = \*Remote;
-
- # We better be careful and just use 1.0
- $protocol = '1.0';
-
- my $sockdata = $self->_socket_data( \*Remote );
- my %copy_of_env = %ENV;
-
- my $sel = IO::Select->new;
- $sel->add( \*STDIN );
-
- REQUEST:
- while (1) {
- my ( $path, $query_string ) = split /\?/, $uri, 2;
-
- # URI is not the same as path. Remove scheme, domain name and port from it
- $path =~ s{^https?://[^/?#]+}{};
-
- # Initialize CGI environment
- local %ENV = (
- PATH_INFO => $path || '',
- QUERY_STRING => $query_string || '',
- REMOTE_ADDR => $sockdata->{peeraddr},
- REQUEST_METHOD => $method || '',
- SERVER_NAME => $sockdata->{localname},
- SERVER_PORT => $port,
- SERVER_PROTOCOL => "HTTP/$protocol",
- %copy_of_env,
- );
-
- # Parse headers
- if ( $protocol >= 1 ) {
- $self->_parse_headers;
- }
-
- # Pass flow control to Catalyst
- {
- # FIXME: don't ignore SIGCHLD while handling requests so system()
- # et al. work within actions. it might be a little risky to do that
- # this far out, but then again it's only the dev server anyway.
- local $SIG{CHLD} = 'DEFAULT';
-
- $class->handle_request( env => \%ENV );
- }
-
- DEBUG && warn "Request done\n";
-
- # Allow keepalive requests, this is a hack but we'll support it until
- # the next major release.
- if ( $self->_is_keepalive ) {
- $self->_clear_keepalive;
-
- DEBUG && warn "Reusing previous connection for keep-alive request\n";
-
- if ( $sel->can_read(1) ) {
- if ( !$self->_read_headers ) {
- # Error reading, give up
- last REQUEST;
- }
-
- ( $method, $uri, $protocol ) = $self->_parse_request_line;
-
- DEBUG && warn "Parsed request: $method $uri $protocol\n";
-
- # Force HTTP/1.0
- $protocol = '1.0';
-
- next REQUEST;
- }
-
- DEBUG && warn "No keep-alive request within 1 second\n";
- }
-
- last REQUEST;
- }
-
- DEBUG && warn "Closing connection\n";
-
- close Remote;
-}
-
-sub _read_headers {
- my $self = shift;
-
- while (1) {
- my $read = sysread Remote, my $buf, CHUNKSIZE;
-
- if ( !defined $read ) {
- next if $! == EWOULDBLOCK;
- DEBUG && warn "Error reading headers: $!\n";
- return;
- } elsif ( $read == 0 ) {
- DEBUG && warn "EOF\n";
- return;
- }
-
- DEBUG && warn "Read $read bytes\n";
- $self->{inputbuf} .= $buf;
- last if $self->{inputbuf} =~ /(\x0D\x0A?\x0D\x0A?|\x0A\x0D?\x0A\x0D?)/s;
- }
-
- return 1;
-}
-
-sub _parse_request_line {
- my $self = shift;
-
- # Parse request line
- # Leading CRLF sometimes sent by buggy IE versions
- if ( $self->{inputbuf} !~ s/^(?:\x0D\x0A)?(\w+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012// ) {
- return ();
- }
-
- my $method = $1;
- my $uri = $2;
- my $proto = $3 || 'HTTP/0.9';
-
- return ( $method, $uri, $proto );
-}
-
-sub _parse_headers {
- my $self = shift;
-
- # Copy the buffer for header parsing, and remove the header block
- # from the content buffer.
- my $buf = $self->{inputbuf};
- $self->{inputbuf} =~ s/.*?(\x0D\x0A?\x0D\x0A?|\x0A\x0D?\x0A\x0D?)//s;
-
- # Parse headers
- my $headers = HTTP::Headers->new;
- my ($key, $val);
- HEADER:
- while ( $buf =~ s/^([^\012]*)\012// ) {
- $_ = $1;
- s/\015$//;
- if ( /^([\w\-~]+)\s*:\s*(.*)/ ) {
- $headers->push_header( $key, $val ) if $key;
- ($key, $val) = ($1, $2);
- }
- elsif ( /^\s+(.*)/ ) {
- $val .= " $1";
- }
- else {
- last HEADER;
- }
- }
- $headers->push_header( $key, $val ) if $key;
-
- DEBUG && warn "Parsed headers: " . dump($headers) . "\n";
-
- # Convert headers into ENV vars
- $headers->scan( sub {
- my ( $key, $val ) = @_;
-
- $key = uc $key;
- $key = 'COOKIE' if $key eq 'COOKIES';
- $key =~ tr/-/_/;
- $key = 'HTTP_' . $key
- unless $key =~ m/\A(?:CONTENT_(?:LENGTH|TYPE)|COOKIE)\z/;
-
- if ( exists $ENV{$key} ) {
- $ENV{$key} .= ", $val";
- }
- else {
- $ENV{$key} = $val;
- }
- } );
-}
-
-sub _socket_data {
- my ( $self, $handle ) = @_;
-
- my $remote_sockaddr = getpeername($handle);
- my ( undef, $iaddr ) = $remote_sockaddr
- ? sockaddr_in($remote_sockaddr)
- : (undef, undef);
-
- my $local_sockaddr = getsockname($handle);
- my ( undef, $localiaddr ) = sockaddr_in($local_sockaddr);
-
- # This mess is necessary to keep IE from crashing the server
- my $data = {
- peeraddr => $iaddr
- ? ( inet_ntoa($iaddr) || '127.0.0.1' )
- : '127.0.0.1',
- localname => _gethostbyaddr( $localiaddr ),
- localaddr => inet_ntoa($localiaddr) || '127.0.0.1',
- };
-
- return $data;
-}
-
-{ # If you have a crappy DNS server then these can be slow, so cache 'em
- my %hostname_cache;
- sub _gethostbyaddr {
- my $ip = shift;
- $hostname_cache{$ip} ||= gethostbyaddr( $ip, AF_INET ) || 'localhost';
- }
-}
-
-sub _inet_addr { unpack "N*", inet_aton( $_[0] ) }
-
-=head2 options
-
-Options hash passed to the http engine to control things like if keepalive
-is supported.
-
-=head1 SEE ALSO
-
-L<Catalyst>, L<Catalyst::Engine>
-
-=head1 AUTHORS
-
-Catalyst Contributors, see Catalyst.pm
-
-=head1 THANKS
-
-Many parts are ripped out of C<HTTP::Server::Simple> by Jesse Vincent.
-
-=head1 COPYRIGHT
-
-This library is free software. You can redistribute it and/or modify it under
-the same terms as Perl itself.
-
-=cut
-
-1;
--- /dev/null
+package Catalyst::Engine::Loader;
+use Moose;
+use Catalyst::Exception;
+use namespace::autoclean;
+
+extends 'Plack::Loader';
+
+around guess => sub {
+ my ($orig, $self) = (shift, shift);
+ my $engine = $self->$orig(@_);
+ if ($engine eq 'Standalone') {
+ if ( $ENV{MOD_PERL} ) {
+ my ( $software, $version ) =
+ $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
+ $version =~ s/_//g;
+ $version =~ s/(\.[^.]+)\./$1/g;
+
+ if ( $software eq 'mod_perl' ) {
+ if ( $version >= 1.99922 ) {
+ $engine = 'Apache2';
+ }
+
+ elsif ( $version >= 1.9901 ) {
+ Catalyst::Exception->throw( message => 'Plack does not have a mod_perl 1.99 handler' );
+ $engine = 'Apache2::MP19';
+ }
+
+ elsif ( $version >= 1.24 ) {
+ $engine = 'Apache1';
+ }
+
+ else {
+ Catalyst::Exception->throw( message =>
+ qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
+ }
+ }
+ }
+ }
+
+ return $engine;
+};
+
+__PACKAGE__->meta->make_immutable( inline_constructor => 0 );
+
+1;
+
+__END__
+
+=head1 NAME
+
+Catalyst::Engine::Loader - The Catalyst Engine Loader
+
+=head1 SYNOPSIS
+
+See L<Catalyst>.
+
+=head1 DESCRIPTION
+
+Wrapper on L<Plack::Loader> which resets the ::Engine if you are using some
+version of mod_perl.
+
+=head1 AUTHORS
+
+Catalyst Contributors, see Catalyst.pm
+
+=head1 COPYRIGHT
+
+This library is free software. You can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
package Catalyst::Script::CGI;
use Moose;
-BEGIN { $ENV{CATALYST_ENGINE} ||= 'CGI' }
use namespace::autoclean;
+sub _plack_engine_name { 'CGI' }
+
with 'Catalyst::ScriptRole';
__PACKAGE__->meta->make_immutable;
package Catalyst::Script::FastCGI;
-
-BEGIN { $ENV{CATALYST_ENGINE} ||= 'FastCGI' }
use Moose;
use MooseX::Types::Moose qw/Str Bool Int/;
+use Data::OptList;
use namespace::autoclean;
+sub _plack_engine_name { 'FCGI' }
+
with 'Catalyst::ScriptRole';
has listen => (
traits => [qw(Getopt)],
isa => Str,
is => 'ro',
+ lazy => 1,
+ builder => '_build_proc_title',
documentation => 'Set the process title',
);
+sub _build_proc_title {
+ my ($self) = @_;
+ return sprintf 'perl-fcgi-pm [%s]', $self->application_name;
+}
+
+sub BUILD {
+ my ($self) = @_;
+ $self->proc_title;
+}
+
+sub _plack_loader_args {
+ my ($self) = shift;
+ return (
+ map { $_->[0] => $self->${ \($_->[1] ? $_->[1]->[0] : $_->[0]) } }
+ Data::OptList::mkopt([
+ qw/pidfile listen manager nproc keep_stderr proc_title/,
+ detach => [ 'daemon' ],
+ ])
+ );
+}
+
sub _application_args {
my ($self) = shift;
return (
$self->listen,
{
- nproc => $self->nproc,
- pidfile => $self->pidfile,
- manager => $self->manager,
- detach => $self->daemon,
+ nproc => $self->nproc,
+ pidfile => $self->pidfile,
+ manager => $self->manager,
+ detach => $self->daemon,
keep_stderr => $self->keeperr,
- proc_title => $self->proc_title,
+ proc_title => $self->proc_title,
}
);
}
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';
has debug => (
}
+sub _plack_loader_args {
+ my ($self) = shift;
+ return (
+ port => $self->port,
+ host => $self->host,
+ keepalive => $self->keepalive ? 100 : 1,
+ server_ready => sub {
+ my ($args) = @_;
+
+ my $name = $args->{server_software} || ref($args); # $args is $server
+ my $host = $args->{host} || 0;
+ my $proto = $args->{proto} || 'http';
+
+ print STDERR "$name: Accepting connections at $proto://$host:$args->{port}/\n";
+ },
+ );
+}
+
sub _application_args {
my ($self) = shift;
return (
use MooseX::Types::Moose qw/Str Bool/;
use Pod::Usage;
use MooseX::Getopt;
+use Catalyst::Engine::Loader;
+use MooseX::Types::LoadableClass qw/LoadableClass/;
use namespace::autoclean;
with 'MooseX::Getopt' => {
required => 1,
);
+has loader_class => (
+ isa => LoadableClass,
+ is => 'ro',
+ coerce => 1,
+ default => 'Catalyst::Engine::Loader',
+ documentation => 'The class to use to detect and load the PSGI engine',
+);
+
+has _loader => (
+ isa => 'Plack::Loader',
+ default => sub {
+ shift->loader_class->new
+ },
+ handles => {
+ load_engine => 'load',
+ autoload_engine => 'auto',
+ },
+ lazy => 1,
+);
+
sub _getopt_spec_exception {}
sub _getopt_spec_warnings {
()
}
+sub _plack_loader_args {
+ my @app_args = shift->_application_args;
+ return (port => $app_args[0]);
+}
+
sub _run_application {
my $self = shift;
my $app = $self->application_name;
Class::MOP::load_class($app);
- $app->run($self->_application_args);
+ my $server;
+ if (my $e = $self->can('_plack_engine_name') ) {
+ $server = $self->load_engine($self->$e, $self->_plack_loader_args);
+ }
+ else {
+ $server = $self->autoload_engine($self->_plack_loader_args);
+ }
+ $app->run($self->_application_args, $server);
}
1;
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) = @_;
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);
sub local_request {
my $class = shift;
- require HTTP::Request::AsCGI;
+ my $app = ref($class) eq "CODE" ? $class : $class->psgi_app;
- my $request = Catalyst::Utils::request( shift(@_) );
- _customize_request($request, @_);
- my $cgi = HTTP::Request::AsCGI->new( $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 {
+ my $psgi_app = shift;
- my $response = $cgi->restore->response;
- $response->request( $request );
+ my $resp = $psgi_app->($request);
- # HTML head parsing based on LWP::UserAgent
+ # HTML head parsing based on LWP::UserAgent
+ #
+ # 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
+ # whatever. Seriously - horrible.
- require HTML::HeadParser;
+ require HTML::HeadParser;
- my $parser = HTML::HeadParser->new();
- $parser->xml_mode(1) if $response->content_is_xhtml;
- $parser->utf8_mode(1) if $] >= 5.008 && $HTML::Parser::VERSION >= 3.40;
+ my $parser = HTML::HeadParser->new();
+ $parser->xml_mode(1) if $resp->content_is_xhtml;
+ $parser->utf8_mode(1) if $] >= 5.008 && $HTML::Parser::VERSION >= 3.40;
- $parser->parse( $response->content );
- my $h = $parser->header;
- for my $f ( $h->header_field_names ) {
- $response->init_header( $f, [ $h->header($f) ] );
- }
+ $parser->parse( $resp->content );
+ my $h = $parser->header;
+ for my $f ( $h->header_field_names ) {
+ $resp->init_header( $f, [ $h->header($f) ] );
+ }
- return $response;
+ $ret = $resp;
+ };
+
+ return $ret;
}
my $agent;
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
BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-use Test::More tests => 20*$iters;
+use Test::More;
use Catalyst::Test 'TestApp';
if ( $ENV{CAT_BENCHMARK} ) {
ok( my $response = request('http://localhost/streaming'), 'Request' );
ok( $response->is_success, 'Response Successful 2xx' );
is( $response->content_type, 'text/plain', 'Response Content-Type' );
-
+
SKIP:
{
if ( $ENV{CATALYST_SERVER} ) {
skip "Using remote server", 1;
}
-
- # XXX: Length should be undef here, but HTTP::Request::AsCGI sets it
- is( $response->content_length, 12, 'Response Content-Length' );
+
+ ok(!defined $response->content_length, 'No Content-Length for streaming responses');
+ is(length $response->content, 12, 'Response content' );
}
-
+
is( $response->content,, <<'EOF', 'Content is a stream' );
foo
bar
is( $response->content, "\0" x $size, 'Content is read from filehandle' );
}
}
+
+done_testing;
BEGIN {
$EXPECTED_ENV_VAR = "CATALYSTTEST$$"; # has to be uppercase otherwise fails on Win32
- $EXPECTED_ENV_VAL = $ENV{$EXPECTED_ENV_VAR}
- = "Test env value " . rand(100000);
+ $EXPECTED_ENV_VAL = "Test env value " . rand(100000);
}
use Test::More tests => 7;
use HTTP::Request::Common;
{
- my $env;
+ my $response = request("http://localhost/dump/env", {
+ extra_env => { $EXPECTED_ENV_VAR => $EXPECTED_ENV_VAL },
+ });
- ok( my $response = request("http://localhost/dump/env"),
- 'Request' );
+ ok( $response, 'Request' );
ok( $response->is_success, 'Response Successful 2xx' );
is( $response->content_type, 'text/plain', 'Response Content-Type' );
+
+ my $env;
ok( eval '$env = ' . $response->content, 'Unserialize Catalyst::Request' );
is ref($env), 'HASH';
- ok exists($env->{PATH}), 'Have a PATH env var';
+ ok exists($env->{PATH_INFO}), 'Have a PATH_INFO env var';
SKIP:
{
use lib "$FindBin::Bin/../lib";
use Test::More tests => 6;
-use TestApp;
-use HTTP::Request::AsCGI;
-
-=pod
-
-This test exposes a problem in the handling of PATH_INFO in C::Engine::CGI (and
-other engines) where Catalyst does not un-escape the request correctly.
-If a request is URL-encoded then Catalyst fails to decode the request
-and thus will try and match actions using the URL-encoded value.
-
-Can NOT use Catalyst::Test as it uses HTTP::Request::AsCGI which does
-correctly unescape the path (by calling $uri = $uri->canonical).
-
-This will fix the problem for the CGI engine, but is probably the
-wrong place. And also does not fix $uri->base, either.
-
-Plus, the same issue is in Engine::Apache* and other engines.
-
-Index: lib/Catalyst/Engine/CGI.pm
-===================================================================
---- lib/Catalyst/Engine/CGI.pm (revision 7821)
-+++ lib/Catalyst/Engine/CGI.pm (working copy)
-@@ -157,6 +157,8 @@
- my $query = $ENV{QUERY_STRING} ? '?' . $ENV{QUERY_STRING} : '';
- my $uri = $scheme . '://' . $host . '/' . $path . $query;
-
-+ $uri = URI->new( $uri )->canonical;
-+
- $c->request->uri( bless \$uri, $uri_class );
-
- # set the base URI
-
-=cut
+use Catalyst::Test 'TestApp';
# test that un-escaped can be feteched.
{
- my $request = Catalyst::Utils::request( 'http://localhost/args/params/one/two' );
- my $cgi = HTTP::Request::AsCGI->new( $request, %ENV )->setup;
-
- TestApp->handle_request( env => \%ENV );
-
- ok( my $response = $cgi->restore->response );
+ ok( my $response = request('http://localhost/args/params/one/two') );
ok( $response->is_success, 'Response Successful 2xx' );
is( $response->content, 'onetwo' );
}
# test that request with URL-escaped code works.
{
- my $request = Catalyst::Utils::request( 'http://localhost/args/param%73/one/two' );
- my $cgi = HTTP::Request::AsCGI->new( $request, %ENV )->setup;
-
- # Reset PATH_INFO because AsCGI calls $uri = $uri->canonical which
- # will unencode the path and hide the problem from the test.
- $ENV{PATH_INFO} = '/args/param%73/one/two';
-
-
- TestApp->handle_request( env => \%ENV );
-
- ok( my $response = $cgi->restore->response );
+ ok( my $response = request('http://localhost/args/param%73/one/two') );
ok( $response->is_success, 'Response Successful 2xx' );
is( $response->content, 'onetwo' );
}
like( $response->content, qr/^bless\( .* 'Catalyst::Request' \)$/s, 'Content is a serialized Catalyst::Request' );
ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
isa_ok( $creq, 'Catalyst::Request' );
- ok( $creq->secure, 'Forwarded port sets securet' );
+ ok( $creq->secure, 'Forwarded port sets secure' );
isa_ok( $creq->headers, 'HTTP::Headers', 'Catalyst::Request->headers' );
is( $creq->header('X-Whats-Cool'), $request->header('X-Whats-Cool'), 'Catalyst::Request->header X-Whats-Cool' );
is( $creq->header('User-Agent'), $request->header('User-Agent'), 'Catalyst::Request->header User-Agent' );
- my $host = sprintf( '%s:%d', $request->uri->host, $request->uri->port );
+ my $host = sprintf( '%s:%d', $request->header('X-Forwarded-Host'), $request->header('X-Forwarded-Port') );
is( $creq->header('Host'), $host, 'Catalyst::Request->header Host' );
SKIP:
{
my $creq;
- local $ENV{REMOTE_USER} = 'dwc';
my $request = GET(
'http://localhost/dump/request',
);
- ok( my $response = request($request), 'Request' );
+ ok( my $response = request($request, { extra_env => { REMOTE_USER => 'dwc' } }), 'Request' );
ok( $response->is_success, 'Response Successful 2xx' );
is( $response->content_type, 'text/plain', 'Response Content-Type' );
like( $response->content, qr/'Catalyst::Request'/,
use FindBin qw/$Bin/;
use lib "$Bin/../lib";
use TestApp;
-use Catalyst::Engine::CGI;
+use Catalyst::Engine;
# mod_rewrite to app root for non / based app
{
SCRIPT_NAME => '/comics/dispatch.cgi',
REQUEST_URI => '/comics/',
);
- is ''.$r->uri, 'http://www.foo.com/comics/', 'uri is correct';
- is ''.$r->base, 'http://www.foo.com/comics/', 'base is correct';
+ is ''.$r->uri, 'http://www.foo.com/comics/';
+ is ''.$r->base, 'http://www.foo.com/comics/';
}
# mod_rewrite to sub path under app root for non / based app
SCRIPT_NAME => '/~bobtfish/Gitalist/script/gitalist.cgi',
REQUEST_URI => '/~bobtfish/Gitalist/script/gitalist.cgi/%252F/%252F',
);
- is ''.$r->uri, 'http://www.foo.com/~bobtfish/Gitalist/script/gitalist.cgi/%252F/%252F', 'uri correct';
- is ''.$r->base, 'http://www.foo.com/~bobtfish/Gitalist/script/gitalist.cgi/', 'base correct';
+ is ''.$r->uri, 'http://www.foo.com/~bobtfish/Gitalist/script/gitalist.cgi/%252F/%252F';
+ is ''.$r->base, 'http://www.foo.com/~bobtfish/Gitalist/script/gitalist.cgi/';
}
# Using rewrite rules to ask for a sub-path in your app.
is ''.$r->uri, 'http://www.foo.com/oslobilder/%22foo%22', 'uri correct';
is ''.$r->base, 'http://www.foo.com/oslobilder/', 'base correct';
}
-
-# CGI hit on IIS for non / based app
-{
- my $r = get_req(0,
- SERVER_SOFTWARE => 'Microsoft-IIS/6.0',
- PATH_INFO => '/bobtfish/Gitalist/script/gitalist.cgi/static/css/blueprint/screen.css',
- SCRIPT_NAME => '/bobtfish/Gitalist/script/gitalist.cgi',
- PATH_TRANSLATED =>
-'C:\\Inetpub\\vhosts\\foo.com\\httpdocs\\bobtfish\\Gitalist\\script\\gitalist.cgi\\static\\css\\blueprint\\screen.css',
- );
- is ''.$r->uri, 'http://www.foo.com/bobtfish/Gitalist/script/gitalist.cgi/static/css/blueprint/screen.css';
- is ''.$r->base, 'http://www.foo.com/bobtfish/Gitalist/script/gitalist.cgi/';
-}
-
{
+ local $TODO = 'Another mod_rewrite case';
my $r = get_req (0,
PATH_INFO => '/auth/login',
SCRIPT_NAME => '/tx',
is $r->base, 'http://www.foo.com/', 'Base is correct';
}
+
# FIXME - Test proxy logic
# - Test query string
# - Test non standard port numbers
PATH_INFO => '/',
);
- local %ENV = (%template, @_);
-
+ my $engine = Catalyst::Engine->new(
+ env => { %template, @_ },
+ );
my $i = TestApp->new;
$i->setup_finished(0);
$i->config(use_request_uri_for_path => $use_request_uri_for_path);
$i->setup_finished(1);
- $i->engine(Catalyst::Engine::CGI->new);
- $i->engine->prepare_path($i);
+ $engine->prepare_path($i);
return $i->req;
}
Catalyst::Script::CGI->new_with_options(application_name => 'TestAppToTestScripts')->run;
} "new_with_options";
shift @TestAppToTestScripts::RUN_ARGS;
+my $server = pop @TestAppToTestScripts::RUN_ARGS;
+like ref($server), qr/^Plack::Handler/, 'Is a Plack::Handler';
is_deeply \@TestAppToTestScripts::RUN_ARGS, [], "no args";
done_testing;
} "new_with_options";
# First element of RUN_ARGS will be the script name, which we don't care about
shift @TestAppToTestScripts::RUN_ARGS;
+ my $server = pop @TestAppToTestScripts::RUN_ARGS;
+ like ref($server), qr/^Plack::Handler/, 'Is a Plack::Handler';
is_deeply \@TestAppToTestScripts::RUN_ARGS, $resultarray, "is_deeply comparison";
}
# Returns the hash expected when no flags are passed
sub opthash {
return {
- pidfile => undef,
- keep_stderr => undef,
- detach => undef,
- nproc => undef,
- manager => undef,
- proc_title => undef,
+ (map { ($_ => undef) } qw(pidfile keep_stderr detach nproc manager)),
+ proc_title => 'perl-fcgi-pm [TestAppToTestScripts]',
@_,
};
}
};
# First element of RUN_ARGS will be the script name, which we don't care about
shift @TestAppToTestScripts::RUN_ARGS;
+ my $server = pop @TestAppToTestScripts::RUN_ARGS;
+ like ref($server), qr/^Plack::Handler/, 'Is a Plack::Handler';
# Mangle argv into the options..
$resultarray->[-1]->{argv} = $argstring;
is_deeply \@TestAppToTestScripts::RUN_ARGS, $resultarray, "is_deeply comparison " . join(' ', @$argstring);
# 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');
sub process {
my ( $self, $c ) = @_;
- return $self->SUPER::process( $c, $c->engine->env );
+ my $env = $c->engine->env;
+ return $self->SUPER::process($c, {
+ map { ($_ => $env->{$_}) }
+ grep { $_ ne 'psgi.input' }
+ keys %{ $env },
+ });
+}
+
+## We override Data::Dumper here since its not reliably outputting
+## something that is roundtrip-able.
+
+sub dump {
+ my ( $self, $reference ) = @_;
+ use Data::Dump ();
+ return Data::Dump::dump($reference);
}
1;
projects / catagits/Catalyst-Runtime.git / commitdiff