- Update tests to ignore CATALYST_HOME env var.
+5.89002 2011-03-02 11:30:00 (TRIAL release)
+
+ Bug fixes:
+ - Fix a couple of test failures caused by optional dependencies such as FCGI
+ not being installed.
+
+ Refactoring:
+ - Simplified the API for getting a PSGI application code reference for a
+ Catalyst application for use in, for example, .psgi files. See
+ Catalyst::Upgrading for details.
+
+5.89001 2011-03-01 15:27:00 (TRIAL release)
+
+ Bug fixes:
+ - Fixed command-line argument passing in Catalyst::Script::FastCGI.
+
+ - Fixed Catalyst::Engine::Stomp compatibility. Applications using
+ Catalyst::Engine::Stomp are believed to continue working without
+ any changes with the new Catalyst major version.
+
+ - Fixed issues auto-loading engine with older scripts.
+
+ Known problems:
+ - Catalyst::Engine::Wx is officially unsupported and BROKEN. If you
+ are using this engine then please get in touch with us and we'll
+ be happy to help with the changes it needs to be compatible with
+ the new major version of Catalyst.
+
+ Documentation:
+ - The section of Catalyst::Upgrading describing how to upgrade to version 5.90
+ of Catalyst has been much improved.
+
5.80032 2011-02-23 01:10:00
Bug fixes:
- Fix undef warning in Catalyst::Engine::FastCGI when writing an empty
body (e.g. doing a redirect)
+5.89000 2011-01-24 09:28:45 (TRIAL release)
+
+ This is a development release from psgi branch of Catalyst-Runtime.
+
+ Removed features:
+
+ - All of the Catalyst::Engine::* namespace is now gone. Instead we only have
+ one Catalyst::Engine class speaking the PSGI protocol natively. Everything
+ the various Catalyst::Engine:: classes did before is now supposed to happen
+ through PSGI handlers such as Plack::Handler::FCGI,
+ Plack::Handler::HTTP::Server::PSGI, Plack::Handler::Apache2, and so
+ on. However, deployment can still work the same as it did before. The
+ catalyst scripts still exist and continue to work.
+
+ If you find anything that either doesn't work anymore as it did before or
+ anything that could be done before with the various Catalyst::Engine::
+ classes, but can't be done anymore with the single PSGI Catalyst::Engine
+ class, please tell us *now*.
+
5.80030 2011-01-04 13:13:02
New features:
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.09';
+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::Getopt' => '0.30';
requires 'MooseX::Types';
requires 'MooseX::Types::Common::Numeric';
+requires 'MooseX::Daemonize' => '0.13';
requires 'String::RewritePrefix' => '0.004'; # Catalyst::Utils::resolve_namespace
+requires 'Plack' => '0.9974'; # IIS6 fix middleware
+requires 'Plack::Middleware::ReverseProxy' => '0.04';
+requires 'Plack::Test::ExternalServer';
test_requires 'Class::Data::Inheritable';
test_requires 'Test::Exception';
test_requires 'Test::More' => '0.88';
+test_requires 'Data::Dump';
+test_requires 'HTTP::Request::Common';
# 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')) {
Test::NoTabs
Test::Pod
Test::Pod::Coverage
- Pod::Coverage
+ Pod::Coverage::TrustPod
));
if ($Module::Install::AUTHOR) {
# REFACTORING
+## PSGI
+
+### Blockers
+
+ * Test all the options work on all of the scripts
+ * Fix nginx middlewares so that they are generic, or can somehow
+ be used by people with their own .psgi files
+ * Fix a sane / nicer way to do custom engines.
+
+#### Script survey
+
+##### myapp_web_fastcgi.pl
+
+Looks to me like we are mapping --deamon to --detach but I think the modern Plack FCGI handler prefers --deamonize
+
+Although --pidfile is supported --pid seems to be preferred, and if we are bothering to map, why not map for the future?
+
+##### myapp_web_server.pl
+
+--pidfile handling is shiit. MooseX::Daemonize will blow up really nastilly if not installed..
+
+ --background handling also shit.
+
+### Nice to have
+
+ * <@rafl> i've been thinking of maybe providing
+ MyApp->apply_default_middlewares($psgi_app)
+ * Capture arguments that the plack engine component was run with somewhere,
+ to more easily support custom args from scripts (e.g. Gitalist's
+ --git_dir)
+ * 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 Catalyst::Controller;
use Data::OptList;
use Devel::InnerPackage ();
-use File::stat;
use Module::Pluggable::Object ();
use Text::SimpleTable ();
use Path::Class::Dir ();
use Class::C3::Adopt::NEXT;
use List::MoreUtils qw/uniq/;
use attributes;
+use String::RewritePrefix;
+use Catalyst::EngineLoader;
use utf8;
use Carp qw/croak carp shortmess/;
+use Try::Tiny;
+use Plack::Middleware::Conditional;
+use Plack::Middleware::ReverseProxy;
+use Plack::Middleware::IIS6ScriptNameFix;
+use Plack::Middleware::LighttpdScriptNameFix;
BEGIN { require 5.008004; }
#maybe we should just make them attributes with a default?
__PACKAGE__->mk_classdata($_)
for qw/components arguments dispatcher engine log dispatcher_class
- engine_class context_class request_class response_class stats_class
- setup_finished/;
+ engine_loader context_class request_class response_class stats_class
+ setup_finished _psgi_app loading_psgi_file/;
__PACKAGE__->dispatcher_class('Catalyst::Dispatcher');
-__PACKAGE__->engine_class('Catalyst::Engine::CGI');
__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.80033';
+our $VERSION = '5.89002';
sub import {
my ( $class, @arguments ) = @_;
$class->setup_log( delete $flags->{log} );
$class->setup_plugins( delete $flags->{plugins} );
$class->setup_dispatcher( delete $flags->{dispatcher} );
- $class->setup_engine( delete $flags->{engine} );
+ if (my $engine = delete $flags->{engine}) {
+ $class->log->warn("Specifying the engine in ->setup is no longer supported, XXX FIXME");
+ }
+ $class->setup_engine();
$class->setup_stats( delete $flags->{stats} );
for my $flag ( sort keys %{$flags} ) {
# get the length from a filehandle
if ( blessed( $response->body ) && $response->body->can('read') || ref( $response->body ) eq 'GLOB' )
{
- my $stat = stat $response->body;
- if ( $stat && $stat->size > 0 ) {
- $response->content_length( $stat->size );
+ my $size = -s $response->body;
+ if ( $size ) {
+ $response->content_length( $size );
}
else {
$c->log->warn('Serving filehandle without a content-length');
# 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 $app = shift;
+ $app->engine_loader->needs_psgi_engine_compat_hack ?
+ $app->engine->run($app, @_) :
+ $app->engine->run( $app, $app->_finalized_psgi_app, @_ );
+}
=head2 $c->set_action( $action, $code, $namespace, $attrs )
=cut
+sub engine_class {
+ my $class = shift;
+ $class->engine_loader->catalyst_engine_class(@_);
+}
+
sub setup_engine {
- my ( $class, $engine ) = @_;
+ my ($class, $requested_engine) = @_;
+
+ $class->engine_loader(
+ Catalyst::EngineLoader->new({
+ application_name => $class,
+ (defined $requested_engine
+ ? (requested_engine => $requested_engine) : ()),
+ }),
+ );
+
+ # Don't really setup_engine -- see _setup_psgi_app for explanation.
+ return if $class->loading_psgi_file;
+
+ my $engine = $class->engine_class;
+ Class::MOP::load_class($engine);
- if ($engine) {
- $engine = 'Catalyst::Engine::' . $engine;
+ if ($ENV{MOD_PERL}) {
+ my $apache = $class->engine_loader->auto;
+ # FIXME - Immutable
+ $class->meta->add_method(handler => sub {
+ my $r = shift;
+ my $psgi_app = $class->psgi_app;
+ $apache->call_app($r, $psgi_app);
+ });
}
- if ( my $env = Catalyst::Utils::env_value( $class, 'ENGINE' ) ) {
- $engine = 'Catalyst::Engine::' . $env;
+ $class->engine( $engine->new );
+
+ return;
+}
+
+sub _finalized_psgi_app {
+ my ($app) = @_;
+
+ unless ($app->_psgi_app) {
+ my $psgi_app = $app->_setup_psgi_app;
+ $app->_psgi_app($psgi_app);
}
- if ( $ENV{MOD_PERL} ) {
- my $meta = Class::MOP::get_metaclass_by_name($class);
+ return $app->_psgi_app;
+}
- # create the apache method
- $meta->add_method('apache' => sub { shift->engine->apache });
+sub _setup_psgi_app {
+ my ($app) = @_;
- my ( $software, $version ) =
- $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
+ for my $home (Path::Class::Dir->new($app->config->{home})) {
+ my $psgi_file = $home->file(
+ Catalyst::Utils::appprefix($app) . '.psgi',
+ );
- $version =~ s/_//g;
- $version =~ s/(\.[^.]+)\./$1/g;
+ next unless -e $psgi_file;
- if ( $software eq 'mod_perl' ) {
+ # If $psgi_file calls ->setup_engine, it's doing so to load
+ # Catalyst::Engine::PSGI. But if it does that, we're only going to
+ # throw away the loaded PSGI-app and load the 5.9 Catalyst::Engine
+ # anyway. So set a flag (ick) that tells setup_engine not to populate
+ # $c->engine or do any other things we might regret.
- if ( !$engine ) {
+ $app->loading_psgi_file(1);
+ my $psgi_app = Plack::Util::load_psgi($psgi_file);
+ $app->loading_psgi_file(0);
- if ( $version >= 1.99922 ) {
- $engine = 'Catalyst::Engine::Apache2::MP20';
- }
+ return $psgi_app
+ unless $app->engine_loader->needs_psgi_engine_compat_hack;
- elsif ( $version >= 1.9901 ) {
- $engine = 'Catalyst::Engine::Apache2::MP19';
- }
+ warn <<"EOW";
+Found a legacy Catalyst::Engine::PSGI .psgi file at ${psgi_file}.
- elsif ( $version >= 1.24 ) {
- $engine = 'Catalyst::Engine::Apache::MP13';
- }
+Its content has been ignored. Please consult the Catalyst::Upgrading
+documentation on how to upgrade from Catalyst::Engine::PSGI.
+EOW
+ }
- else {
- Catalyst::Exception->throw( message =>
- qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
- }
+ return $app->apply_default_middlewares($app->psgi_app);
+}
- }
+=head2 $c->apply_default_middlewares
- # install the correct mod_perl handler
- if ( $version >= 1.9901 ) {
- *handler = sub : method {
- shift->handle_request(@_);
- };
- }
- else {
- *handler = sub ($$) { shift->handle_request(@_) };
- }
+Adds the following L<Plack> middlewares to your application, since they are
+useful and commonly needed:
- }
+L<Plack::Middleware::ReverseProxy>, (conditionally added based on the status
+of your $ENV{REMOTE_ADDR}, and can be forced on with C<using_frontend_proxy>
+or forced off with C<ignore_frontend_proxy>), L<Plack::Middleware::LighttpdScriptNameFix>
+(if you are using Lighttpd), L<Plack::Middleware::IIS6ScriptNameFix> (always
+applied since this middleware is smart enough to conditionally apply itself).
- elsif ( $software eq 'Zeus-Perl' ) {
- $engine = 'Catalyst::Engine::Zeus';
- }
+Additionally if we detect we are using Nginx, we add a bit of custom middleware
+to solve some problems with the way that server handles $ENV{PATH_INFO} and
+$ENV{SCRIPT_NAME}
- else {
- Catalyst::Exception->throw(
- message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
- }
- }
+=cut
- unless ($engine) {
- $engine = $class->engine_class;
- }
- Class::MOP::load_class($engine);
+sub apply_default_middlewares {
+ my ($app, $psgi_app) = @_;
- # check for old engines that are no longer compatible
- my $old_engine;
- if ( $engine->isa('Catalyst::Engine::Apache')
- && !Catalyst::Engine::Apache->VERSION )
- {
- $old_engine = 1;
- }
+ $psgi_app = Plack::Middleware::Conditional->wrap(
+ $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};
+ },
+ );
- elsif ( $engine->isa('Catalyst::Engine::Server::Base')
- && Catalyst::Engine::Server->VERSION le '0.02' )
- {
- $old_engine = 1;
- }
+ my $server_matches = sub {
+ my ($re) = @_;
+ return sub {
+ my ($env) = @_;
+ my $server = $env->{SERVER_SOFTWARE};
+ return unless $server;
+ return $server =~ $re ? 1 : 0;
+ };
+ };
- elsif ($engine->isa('Catalyst::Engine::HTTP::POE')
- && $engine->VERSION eq '0.01' )
- {
- $old_engine = 1;
- }
+ # If we're running under Lighttpd, swap PATH_INFO and SCRIPT_NAME
+ # http://lists.scsys.co.uk/pipermail/catalyst/2006-June/008361.html
+ $psgi_app = Plack::Middleware::LighttpdScriptNameFix->wrap($psgi_app);
+
+ $psgi_app = Plack::Middleware::Conditional->wrap(
+ $psgi_app,
+ condition => $server_matches->(qr/^nginx/),
+ builder => sub {
+ my ($to_wrap) = @_;
+ return sub {
+ my ($env) = @_;
+ my $script_name = $env->{SCRIPT_NAME};
+ $env->{PATH_INFO} =~ s/^$script_name//g;
+ return $to_wrap->($env);
+ };
+ },
+ );
- elsif ($engine->isa('Catalyst::Engine::Zeus')
- && $engine->VERSION eq '0.01' )
- {
- $old_engine = 1;
- }
+ # we're applying this unconditionally as the middleware itself already makes
+ # sure it doesn't fuck things up if it's not running under one of the right
+ # IIS versions
+ $psgi_app = Plack::Middleware::IIS6ScriptNameFix->wrap($psgi_app);
- if ($old_engine) {
- Catalyst::Exception->throw( message =>
- qq/Engine "$engine" is not supported by this version of Catalyst/
- );
- }
+ return $psgi_app;
+}
- # engine instance
- $class->engine( $engine->new );
+=head2 $c->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.
+
+This is what you want to be using to retrieve the PSGI application code
+reference of your Catalyst application for use in F<.psgi> files.
+
+=cut
+
+sub 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 Catalyst::EngineLoader;
use Encode ();
use utf8;
use namespace::clean -except => 'meta';
-has env => (is => 'rw');
+has env => (is => 'ro', writer => '_set_env', clearer => '_clear_env');
+
+my $WARN_ABOUT_ENV = 0;
+around env => sub {
+ my ($orig, $self, @args) = @_;
+ if(@args) {
+ warn "env as a writer is deprecated, you probably need to upgrade Catalyst::Engine::PSGI"
+ unless $WARN_ABOUT_ENV++;
+ return $self->_set_env(@args);
+ }
+ return $self->$orig;
+};
# 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',
+ predicate => '_has_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) = @_;
+
+ # This is a less-than-pretty hack to avoid breaking the old
+ # Catalyst::Engine::PSGI. 5.9 Catalyst::Engine sets a response_cb and
+ # expects us to pass headers to it here, whereas Catalyst::Enngine::PSGI
+ # just pulls the headers out of $ctx->response in its run method and never
+ # sets response_cb. So take the lack of a response_cb as a sign that we
+ # don't need to set the headers.
+
+ return unless $self->_has_response_cb;
+
+ my @headers;
+ $ctx->response->headers->scan(sub { push @headers, @_ });
+
+ $self->_set_writer($self->_response_cb->([ $ctx->response->status, \@headers ]));
+ $self->_clear_response_cb;
+
+ 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. Builds a PSGI application and calls the
+run method on the server passed in, which then causes the
+engine to loop, handling requests..
+
+=cut
+
+sub run {
+ my ($self, $app, $psgi, @args) = @_;
+ # @args left here rather than just a $options, $server for back compat with the
+ # old style scripts which send a few args, then a hashref
+
+ # They should never actually be used in the normal case as the Plack engine is
+ # passed in got all the 'standard' args via the loader in the script already.
+
+ # FIXME - we should stash the options in an attribute so that custom args
+ # like Gitalist's --git_dir are possible to get from the app without stupid tricks.
+ my $server = pop @args if (scalar @args && blessed $args[-1]);
+ my $options = pop @args if (scalar @args && ref($args[-1]) eq 'HASH');
+ # Back compat hack for applications with old (non Catalyst::Script) scripts to work in FCGI.
+ if (scalar @args && !ref($args[0])) {
+ if (my $listen = shift @args) {
+ $options->{listen} ||= [$listen];
+ }
+ }
+ if (! $server ) {
+ $server = Catalyst::EngineLoader->new(application_name => ref($self))->auto(%$options);
+ # We're not being called from a script, so auto detect what backend to
+ # run on. This should never happen, as mod_perl never calls ->run,
+ # instead the $app->handle method is called per request.
+ $app->log->warn("Not supplied a Plack engine, falling back to engine auto-loader (are your scripts ancient?)")
+ }
+ $server->run($psgi, $options);
+}
+
+=head2 build_psgi_app ($app, @args)
-Start the engine. Implemented by the various engine classes.
+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 run { }
+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)
$self->_prepared_write(1);
}
- return 0 if !defined $buffer;
+ $buffer = q[] unless 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 ) {
- my $headers = $self->_clear_header_buf;
-
- $buffer = defined $buffer
- ? $headers . $buffer : $headers;
- }
-
- 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 ) = @_;
-
- # ->write will be called once with the body, even in a redirect (and
- # in that case, the body is undef)
- $buffer = '' if !defined $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 ) || $ip;
- }
-}
-
-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::EngineLoader;
+use Moose;
+use Catalyst::Exception;
+use Catalyst::Utils;
+use namespace::autoclean;
+
+extends 'Plack::Loader';
+
+has application_name => (
+ isa => 'Str',
+ is => 'ro',
+ required => 1,
+);
+
+has requested_engine => (
+ is => 'ro',
+ isa => 'Str',
+ predicate => 'has_requested_engine',
+);
+
+sub needs_psgi_engine_compat_hack {
+ my ($self) = @_;
+ return $self->has_requested_engine
+ && $self->requested_engine eq 'PSGI';
+}
+
+has catalyst_engine_class => (
+ isa => 'Str',
+ is => 'rw',
+ lazy => 1,
+ builder => '_guess_catalyst_engine_class',
+);
+
+sub _guess_catalyst_engine_class {
+ my $self = shift;
+ my $old_engine = $self->has_requested_engine
+ ? $self->requested_engine
+ : Catalyst::Utils::env_value($self->application_name, 'ENGINE');
+ if (!defined $old_engine) {
+ return 'Catalyst::Engine';
+ }
+ elsif ($old_engine eq 'PSGI') {
+ ## If we are running under plackup let the Catalyst::Engine::PSGI
+ ## continue to run, but warn.
+ warn <<"EOW";
+You are running Catalyst::Engine::PSGI, which is considered a legacy engine for
+this version of Catalyst. We will continue running and use your existing psgi
+file, but it is recommended to perform the trivial upgrade process, which will
+leave you with less code and a forward path.
+
+Please review Catalyst::Upgrading
+EOW
+ return 'Catalyst::Engine::' . $old_engine;
+ }
+ elsif ($old_engine =~ /^(CGI|FastCGI|HTTP|Apache.*)$/) {
+ return 'Catalyst::Engine';
+ }
+ else {
+ return 'Catalyst::Engine::' . $old_engine;
+ }
+}
+
+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}/ );
+ }
+ }
+ }
+ }
+
+ my $old_engine = Catalyst::Utils::env_value($self->application_name, 'ENGINE');
+ if (!defined $old_engine) { # Not overridden
+ }
+ elsif ($old_engine =~ /^(PSGI|CGI|Apache.*)$/) {
+ # Trust autodetect
+ }
+ elsif ($old_engine eq 'HTTP') {
+ $engine = 'Standalone';
+ }
+ elsif ($old_engine eq 'FastCGI') {
+ $engine = 'FCGI';
+ }
+ elsif ($old_engine eq "HTTP::Prefork") { # Too bad if you're customising, we don't handle options
+ # write yourself a script to collect and pass in the options
+ $engine = "Starman";
+ }
+ elsif ($old_engine eq "HTTP::POE") {
+ Catalyst::Exception->throw("HTTP::POE engine no longer works, recommend you use Twiggy instead");
+ }
+ elsif ($old_engine eq "Zeus") {
+ Catalyst::Exception->throw("Zeus engine no longer works");
+ }
+ else {
+ warn("You asked for an unrecognised engine '$old_engine' which is no longer supported, this has been ignored.\n");
+ }
+
+ return $engine;
+};
+
+# Force constructor inlining
+__PACKAGE__->meta->make_immutable( replace_constructor => 1 );
+
+1;
+
+__END__
+
+=head1 NAME
+
+Catalyst::EngineLoader - 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.
+
+=begin Pod::Coverage
+
+needs_psgi_engine_compat_hack
+
+=end Pod::Coverage
+
+=cut
--- /dev/null
+=pod
+
+=head1 Catalyst and PSGI
+
+Catalyst used to contain a whole set of C<< Catalyst::Engine::XXXX >> classes to
+adapt to various different web servers, and environments (e.g. CGI, FastCGI, mod_perl)
+etc.
+
+This has been changed so that all of that work is done by Catalyst just implementing
+the L<PSGI> specification, and using L<Plack>'s adaptors to implement that functionality.
+
+This means that we can share common code, and fixes for specific web servers.
+
+=head1 I already have an application
+
+If you already have a Catalyst application, then this means very little, and you should be
+able to upgrade to the latest release with little or no trouble (See notes in L<Catalyst::Upgrading>
+for specifics about your web server deployment).
+
+=head1 Writing your own PSGI file.
+
+=head2 What is a .psgi file
+
+A C<< .psgi >> file lets you manually controll how your application code reference is built.
+
+Catalyst normally takes care of this for you, but it's possible to do it manually by
+creating a C<myapp.psgi> file in the root of your application.
+
+The simplest C<.psgi> file for an application called C<TestApp> would be:
+
+ use strict;
+ use warnings;
+ use TestApp;
+
+ my $app = sub { TestApp->psgi_app(@_) };
+
+It should be noted that Catalyst may apply a number of middleware components for
+you automatically, and these B<will not> be applied if you manually create
+a psgi file yourself. Details of these middlewares can be found below.
+
+Additional information about psgi files can be found at:
+L<http://search.cpan.org/dist/Plack/lib/Plack.pm#.psgi_files>
+
+=head2 Why would I want to make a .psgi file?
+
+Writing your own .psgi file allows you to use the alternate L<plackup> command
+to start your application, and allows you to add classes and extensions
+that implement L<Plack::Middleware>, such as L<Plack::Middleware::ErrorDocument>,
+or L<Plack::Middleware::AccessLog>.
+
+=head2 What is in the .psgi Catalyst generates by default?
+
+Catalyst generates an application which, if the C<< using_frontend_proxy >>
+setting is on, is wrapped in L<Plack::Middleware::ReverseProxy>, and contains some
+engine specific fixes for uniform behaviour, as contained in:
+
+=over
+
+=item L<Plack::Middleware::LighttpdScriptNameFix> - FIXME, we don't use that really.
+
+=item L<Plack::Middleware::IIS6ScriptNameFix>
+
+=item nginx - FIXME??
+
+=back
+
+If you override the default by providing your own C<< .psgi >> file, then
+none of these things will be done automatically for you by the PSGI
+application returned when you call C<< MyApp->psgi_app >>, and if you need
+any of this functionality, you'll need to implement this in your C<< .psgi >>
+file yourself.
+
+=head1 SEE ALSO
+
+L<Catalyst::Upgrading>, L<Plack>, L<PSGI::FAQ>, L<PSGI>.
+
+=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
Make sure you get it from there to ensure you have the latest version.
-=head2 5.81000
+=head2 5.91000
=over
support for pluggable dispatcher builders (so that attributes can be
replaced).
-=item MyApp should not ISA Catalyst::Controller
-
-=over
-
-=item *
-
-Update Test suite to not assume MyApp ISA Controller
-
-=item *
-
-After that set up attr handlers that will output helpful error messages when
-you do it as well as how to fix it.
-
=back
-=back
-
-=head2 5.82000
+=head2 5.92000
=over
=back
-=head2 5.90000
+=head2 6.00000
=over
=item update pod coverage tests to detect stubbed pod, ensure real coverage
-=item Add support for configuration profiles to be selected at startup time
-through switches / ENV
-
=back
use Catalyst::Exception;
use File::Copy ();
-use IO::File qw( SEEK_SET );
+use IO::File ();
use File::Spec::Unix;
use namespace::clean -except => 'meta';
binmode( $handle, $layer );
- $handle->seek(0, SEEK_SET);
+ $handle->seek(0, IO::File::SEEK_SET);
while ( $handle->sysread( my $buffer, 8192 ) ) {
$content .= $buffer;
}
- $handle->seek(0, SEEK_SET);
+ $handle->seek(0, IO::File::SEEK_SET);
return $content;
}
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;
+}
+
+# Munge the 'listen' arg so that Plack::Handler::FCGI will accept it.
+sub _listen {
+ my ($self) = @_;
+
+ if (defined (my $listen = $self->listen)) {
+ return [ $listen ];
+ } else {
+ return undef;
+ }
+}
+
+sub _plack_loader_args {
+ my ($self) = shift;
+
+ my $opts = Data::OptList::mkopt([
+ qw/pidfile manager nproc proc_title/,
+ detach => [ 'daemon' ],
+ keep_stderr => [ 'keeperr' ],
+ listen => [ '_listen' ],
+ ]);
+
+ my %args = map { $_->[0] => $self->${ \($_->[1] ? $_->[1]->[0] : $_->[0]) } } @$opts;
+
+ # Plack::Handler::FCGI thinks manager => undef means "use no manager".
+ delete $args{'manager'} unless defined $args{'manager'};
+
+ return %args;
+}
+
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/;
documentation => 'Specify a different listening port (to the default port 3000)',
);
+use Moose::Util::TypeConstraints;
+class_type 'MooseX::Daemonize::Pid::File';
+subtype 'MyStr', as Str, where { 1 }; # FIXME - Fuck ugly!
+coerce 'MooseX::Daemonize::Pid::File', from 'MyStr', via {
+ Class::MOP::load_class("MooseX::Daemonize::Pid::File");
+ MooseX::Daemonize::Pid::File->new( file => $_ );
+};
+MooseX::Getopt::OptionTypeMap->add_option_type_to_map(
+ 'MooseX::Daemonize::Pid::File' => '=s',
+);
has pidfile => (
traits => [qw(Getopt)],
cmd_aliases => 'pid',
- isa => Str,
+ isa => 'MooseX::Daemonize::Pid::File',
is => 'ro',
documentation => 'Specify a pidfile',
+ coerce => 1,
+ predicate => '_has_pidfile',
);
+sub BUILD {
+ my $self = shift;
+
+ if ($self->background) {
+ # FIXME - This is evil. Should we just add MX::Daemonize to the deps?
+ Class::MOP::load_class('MooseX::Daemonize::Core');
+ MooseX::Daemonize::Core->meta->apply($self);
+ }
+}
+
has keepalive => (
traits => [qw(Getopt)],
cmd_aliases => 'k',
predicate => '_has_follow_symlinks',
);
+sub _plack_engine_name {
+ my $self = shift;
+ return $self->fork ? 'Starman' : $self->keepalive ? 'Starman' : 'Standalone';
+}
+
sub _restarter_args {
my $self = shift;
if ( $self->restart ) {
die "Cannot run in the background and also watch for changed files.\n"
if $self->background;
+ die "Cannot write out a pid file and fork for the restarter.\n"
+ if $self->_has_pidfile;
# If we load this here, then in the case of a restarter, it does not
# need to be reloaded for each restart.
$restarter->run_and_watch;
}
else {
+ if ($self->background) {
+ $self->daemon_fork;
+
+ return 1 unless $self->is_daemon;
+
+ Class::MOP::load_class($self->application_name);
+
+ $self->daemon_detach;
+ }
+
+ $self->pidfile->write
+ if $self->_has_pidfile;
+
$self->_run_application;
}
}
+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::EngineLoader;
+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::EngineLoader',
+ documentation => 'The class to use to detect and load the PSGI engine',
+);
+
+has _loader => (
+ isa => 'Plack::Loader',
+ default => sub {
+ my $self = shift;
+ $self->loader_class->new(application_name => $self->application_name);
+ },
+ handles => {
+ load_engine => 'load',
+ autoload_engine => 'auto',
+ },
+ lazy => 1,
+);
+
sub _getopt_spec_exception {}
sub _getopt_spec_warnings {
()
}
+sub _plack_loader_args {
+ my $self = shift;
+ my @app_args = $self->_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 namespace::autoclean;
sub run {
- my ($self, $class, $scriptclass) = @_;
+ my ($self, $class, $scriptclass, %args) = @_;
my $classtoload = "${class}::Script::$scriptclass";
lib->import(File::Spec->catdir($FindBin::Bin, '..', 'lib'));
$classtoload = "Catalyst::Script::$scriptclass";
Class::MOP::load_class($classtoload);
}
- $classtoload->new_with_options( application_name => $class )->run;
+ $classtoload->new_with_options( application_name => $class, %args )->run;
}
__PACKAGE__->meta->make_immutable;
use warnings;
use Test::More ();
+use Plack::Test;
use Catalyst::Exception;
use Catalyst::Utils;
use Class::MOP;
use Sub::Exporter;
+use Carp 'croak', 'carp';
-my $build_exports = sub {
- my ($self, $meth, $args, $defaults) = @_;
+sub _build_request_export {
+ my ($self, $args) = @_;
+
+ return sub { _remote_request(@_) }
+ if $args->{remote};
- my $request;
my $class = $args->{class};
- if ( $ENV{CATALYST_SERVER} ) {
- $request = sub { remote_request(@_) };
- } elsif (! $class) {
- $request = sub { Catalyst::Exception->throw("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, @_ ) };
- }
+ # Here we should be failing right away, but for some stupid backcompat thing
+ # I don't quite remember we fail lazily here. Needs a proper deprecation and
+ # then removal.
+ return sub { croak "Must specify a test app: use Catalyst::Test 'TestApp'" }
+ unless $class;
+
+ Class::MOP::load_class($class) unless Class::MOP::is_class_loaded($class);
+ $class->import;
+
+ return sub { _local_request( $class, @_ ) };
+}
+
+sub _build_get_export {
+ my ($self, $args) = @_;
+ my $request = $args->{request};
- my $get = sub { $request->(@_)->content };
+ return sub { $request->(@_)->content };
+}
+sub _build_ctx_request_export {
+ my ($self, $args) = @_;
+ my ($class, $request) = @{ $args }{qw(class request)};
- my $ctx_request = sub {
+ return sub {
my $me = ref $self || $self;
- ### throw an exception if ctx_request is being used against a remote
- ### server
+ # fail if ctx_request is being used against a remote server
Catalyst::Exception->throw("$me only works with local requests, not remote")
if $ENV{CATALYST_SERVER};
- ### check explicitly for the class here, or the Cat->meta call will blow
- ### up in our face
+ # check explicitly for the class here, or the Cat->meta call will blow
+ # up in our face
Catalyst::Exception->throw("Must specify a test app: use Catalyst::Test 'TestApp'") unless $class;
- ### place holder for $c after the request finishes; reset every time
- ### requests are done.
+ # place holder for $c after the request finishes; reset every time
+ # requests are done.
my $ctx_closed_over;
- ### hook into 'dispatch' -- the function gets called after all plugins
- ### have done their work, and it's an easy place to capture $c.
-
+ # hook into 'dispatch' -- the function gets called after all plugins
+ # have done their work, and it's an easy place to capture $c.
my $meta = Class::MOP::get_metaclass_by_name($class);
$meta->make_mutable;
$meta->add_after_method_modifier( "dispatch", sub {
});
$meta->make_immutable( replace_constructor => 1 );
Class::C3::reinitialize(); # Fixes RT#46459, I've failed to write a test for how/why, but it does.
- ### do the request; C::T::request will know about the class name, and
- ### we've already stopped it from doing remote requests above.
- my $res = $request->( @_ );
+
+ # do the request; C::T::request will know about the class name, and
+ # we've already stopped it from doing remote requests above.
+ my $res = $args->{request}->( @_ );
# Make sure not to leave a reference $ctx hanging around.
# This means that the context will go out of scope as soon as the
my $ctx = $ctx_closed_over;
undef $ctx_closed_over;
- ### return both values
return ( $res, $ctx );
};
+}
+
+my $build_exports = sub {
+ my ($self, $meth, $args, $defaults) = @_;
+ my $class = $args->{class};
+
+ my $request = $self->_build_request_export({
+ class => $class,
+ remote => $ENV{CATALYST_SERVER},
+ });
+
+ my $get = $self->_build_get_export({ request => $request });
+
+ my $ctx_request = $self->_build_ctx_request_export({
+ class => $class,
+ request => $request,
+ });
return {
request => $request,
my $res = request('foo/bar?test=1');
my $virtual_res = request('foo/bar?test=1', {host => 'virtualhost.com'});
-=head1 FUNCTIONS
-
=head2 ($res, $c) = ctx_request( ... );
Works exactly like L<request|/"$res = request( ... );">, except it also returns the Catalyst context object,
C<$c>. Note that this only works for local requests.
-=head2 $res = Catalyst::Test::local_request( $AppClass, $url );
-
-Simulate a request using L<HTTP::Request::AsCGI>.
-
=cut
-sub local_request {
- my $class = shift;
-
- require HTTP::Request::AsCGI;
+sub _request {
+ my $args = shift;
- my $request = Catalyst::Utils::request( shift(@_) );
- _customize_request($request, @_);
- my $cgi = HTTP::Request::AsCGI->new( $request, %ENV )->setup;
+ my $request = Catalyst::Utils::request(shift);
- $class->handle_request( env => \%ENV );
+ my %extra_env;
+ _customize_request($request, \%extra_env, @_);
+ $args->{mangle_request}->($request) if $args->{mangle_request};
- my $response = $cgi->restore->response;
- $response->request( $request );
+ my $ret;
+ test_psgi
+ %{ $args },
+ app => sub { $args->{app}->({ %{ $_[0] }, %extra_env }) },
+ client => sub {
+ my ($psgi_app) = @_;
+ my $resp = $psgi_app->($request);
+ $args->{mangle_response}->($resp) if $args->{mangle_response};
+ $ret = $resp;
+ };
- # HTML head parsing based on LWP::UserAgent
-
- 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;
-
- $parser->parse( $response->content );
- my $h = $parser->header;
- for my $f ( $h->header_field_names ) {
- $response->init_header( $f, [ $h->header($f) ] );
- }
-
- return $response;
+ return $ret;
}
-my $agent;
-
-=head2 $res = Catalyst::Test::remote_request( $url );
-
-Do an actual remote request using LWP.
-
-=cut
-
-sub remote_request {
+sub _local_request {
+ my $class = shift;
- require LWP::UserAgent;
+ return _request({
+ app => ref($class) eq "CODE" ? $class : $class->_finalized_psgi_app,
+ mangle_response => sub {
+ my ($resp) = @_;
- my $request = Catalyst::Utils::request( shift(@_) );
- my $server = URI->new( $ENV{CATALYST_SERVER} );
+ # 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.
- _customize_request($request, @_);
+ require HTML::HeadParser;
- if ( $server->path =~ m|^(.+)?/$| ) {
- my $path = $1;
- $server->path("$path") if $path; # need to be quoted
- }
+ 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;
- # the request path needs to be sanitised if $server is using a
- # non-root path due to potential overlap between request path and
- # response path.
- if ($server->path) {
- # If request path is '/', we have to add a trailing slash to the
- # final request URI
- my $add_trailing = $request->uri->path eq '/';
-
- my @sp = split '/', $server->path;
- my @rp = split '/', $request->uri->path;
- shift @sp;shift @rp; # leading /
- if (@rp) {
- foreach my $sp (@sp) {
- $sp eq $rp[0] ? shift @rp : last
+ $parser->parse( $resp->content );
+ my $h = $parser->header;
+ for my $f ( $h->header_field_names ) {
+ $resp->init_header( $f, [ $h->header($f) ] );
}
- }
- $request->uri->path(join '/', @rp);
+ },
+ }, @_);
+}
- if ( $add_trailing ) {
- $request->uri->path( $request->uri->path . '/' );
- }
- }
+my $agent;
- $request->uri->scheme( $server->scheme );
- $request->uri->host( $server->host );
- $request->uri->port( $server->port );
- $request->uri->path( $server->path . $request->uri->path );
+sub _remote_request {
+ require LWP::UserAgent;
+ local $Plack::Test::Impl = 'ExternalServer';
unless ($agent) {
-
$agent = LWP::UserAgent->new(
keep_alive => 1,
max_redirect => 0,
$agent->env_proxy;
}
- return $agent->request($request);
+
+ my $server = URI->new($ENV{CATALYST_SERVER});
+ if ( $server->path =~ m|^(.+)?/$| ) {
+ my $path = $1;
+ $server->path("$path") if $path; # need to be quoted
+ }
+
+ return _request({
+ ua => $agent,
+ uri => $server,
+ mangle_request => sub {
+ my ($request) = @_;
+
+ # the request path needs to be sanitised if $server is using a
+ # non-root path due to potential overlap between request path and
+ # response path.
+ if ($server->path) {
+ # If request path is '/', we have to add a trailing slash to the
+ # final request URI
+ my $add_trailing = ($request->uri->path eq '/' || $request->uri->path eq '') ? 1 : 0;
+
+ my @sp = split '/', $server->path;
+ my @rp = split '/', $request->uri->path;
+ shift @sp; shift @rp; # leading /
+ if (@rp) {
+ foreach my $sp (@sp) {
+ $sp eq $rp[0] ? shift @rp : last
+ }
+ }
+ $request->uri->path(join '/', @rp);
+
+ if ( $add_trailing ) {
+ $request->uri->path( $request->uri->path . '/' );
+ }
+ }
+ },
+ }, @_);
+}
+
+for my $name (qw(local_request remote_request)) {
+ my $fun = sub {
+ carp <<"EOW";
+Calling Catalyst::Test::${name}() directly is deprecated.
+
+Please import Catalyst::Test into your namespace and use the provided request()
+function instead.
+EOW
+ return __PACKAGE__->can("_${name}")->(@_);
+ };
+
+ no strict 'refs';
+ *$name = $fun;
}
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($url [, $test_name ])
This library is free software. You can redistribute it and/or modify it under
the same terms as Perl itself.
+=begin Pod::Coverage
+
+local_request
+
+remote_request
+
+=end Pod::Coverage
+
=cut
1;
Catalyst::Upgrading - Instructions for upgrading to the latest Catalyst
+=head1 Upgrading to Catalyst 5.90
+
+The major change is that L<Plack> now replaces most of the subclasses of
+L<Catalyst::Engine>. If you are using one of the standard subclasses of
+L<Catalyst::Engine> this should be a straightforward upgrade for you. It was
+a design goal for this release to be as backwardly compatible as possible.
+However since L<Plack> is different from L<Catalyst::Engine> it would be
+possible that edge case differences would exist. Therefore we recommend care
+be taken with this upgrade and that testing should be greater than would be
+the case with a minor point update.
+
+It is highly recommended that you become familar with the L<Plack> ecosystem
+and documentation. Being able to take advantage of L<Plack> development and
+middleware is a major bonus to this upgrade. Documentation about how to
+take advantage of L<Plack::Middleware> by writing your own C<< .psgi >> file
+is contained in L<Catalyst::PSGI>.
+
+If you have created a custom subclass of L<Catalyst:Engine> you will need to
+convert it to be a subclass of L<Plack::Handler>.
+
+If you are using the L<Plack> engine, L<Catalyst::Engine::PSGI>, this new
+release supercedes that code.
+
+If you are using a subclass of L<Catalyst::Engine> that is aimed at nonstandard
+or internal / testing uses, such as L<Catalyst::Engine::Embeddable> you should
+still be able to continue using that engine.
+
+Advice for specific subclasses of L<Catalyst::Engine> follows:
+
+=head2 Upgrading the FastCGI Engine
+
+No upgrade needed if your myapp_fastcgi.pl script is already upgraded
+enough to use L<Catalyst::Script::FastCGI>.
+
+=head2 Upgrading the mod_perl / Apache Engines
+
+The engines that are build upon the various iterations of mod_perl,
+L<Catalyst::Engine::Apache::MP13> and
+L<Catalyst::Engine::Apache2::MP20> should be seemless upgrades and will
+work using using L<Plack::Handler::Apache1> or L<Plack::Handler::Apache2>
+as required.
+
+L<Catalyst::Engine::Apache2::MP19>, is however no longer supported, as Plack
+does not support mod_perl version 1.99
+
+=head2 Upgrading the HTTP Engine
+
+The default development server that comes with the L<Catalyst> distribution
+should continue to work as expected with no changes as long as your C<myapp_server>
+script is upgraded to use L<Catalyst::Script::HTTP>.
+
+=head2 Upgrading the CGI Engine
+
+If you were using L<Catalyst::Engine::CGI> there is no upgrade needed if your
+myapp_cgi.pl script is already upgraded enough to use L<Catalyst::Script::CGI>.
+
+=head2 Upgrading the Preforking Engine
+
+If you were using L<Catalyst::Engine::HTTP::Prefork> then L<Starman>
+is automatically loaded.
+
+If you were customising your server script to pass opttions to the prefork engine,
+then this is no longer supported. The recommended route to implement this functionality
+is to write a simple .psgi file for your application, then use the L<plackup> untility.
+
+=head2 Upgrading the PSGI Engine
+
+If you were using L<Catalyst::Engine::PSGI> this new release supercedes this
+engine in supporting L<Plack>. By default the Engine is now always L<Plack>.
+As a result, you can stop depending on L<Catalyst::Engine::PSGI> in your
+C<Makefile.PL>.
+
+Applications that were using L<Catalyst::Engine::PSGI>
+previously should entirely continue to work in this release with no changes.
+
+However, if you have an C<app.psgi> script, then you no longer
+need to specify the PSGI engine. Instead, the L<Catalyst> application class
+now has a new method C<psgi_app> which returns a L<PSGI> compatible coderef
+which you can wrap in middleware of your choice.
+
+Catalyst will use the .psgi for your application if it is located in the C<home>
+directory of the application
+
+For example, if you were using L<Catalyst::Engine::PSGI> in the past, you will
+have written (or generated) a C<script/myapp.psgi> file similar to this one:
+
+ use Plack::Builder;
+ use MyCatalytApp;
+
+ MyCatalystApp->setup_engine('PSGI');
+
+ builder {
+ enable ... # enable your desired middleware
+ sub { MyCatalystApp->run(@_) };
+ };
+
+Instead, you now say:
+
+ use Plack::Builder;
+ use MyCatalystApp;
+
+ builder {
+ enable ... #enable your desired middleware
+ MyCatalystApp->psgi_app;
+ };
+
+In the simplest case:
+
+ MyCatalystApp->setup_engine('PSGI');
+ my $app = sub { MyCatalystApp->run(@_) }
+
+becomes
+
+ MyCatalystApp->setup_engine('PSGI');
+ my $app = MyCatalystApp->psgi_app(@_);
+
+B<NOT>:
+
+ my $app = sub { MyCatalystApp->psgi_app(@_) };
+ # If you make ^^ this mistake, your app won't work, and will confuse the hell out of you!
+
+You can now rename C<< script/myapp.psgi >> to C<< myapp.psgi >>, and the built-in
+Catalyst scripts, and your test suite will start using your .psgi file.
+
+B<NOTE:> If you rename your .psgi file without these modifications, then any tests run via
+L<Catalyst::Test> will not be compatible with the new release, and will result in
+the development server starting, rather than the expected test running.
+
+=head2 Engines which are known broken
+
+The following engines B<DO NOT> work as of Catalyst version 5.90. The core
+team is extremely happy to work with the developers and/or users of these
+engines to help them port to the new Plack/Engine system, however applications
+which are currently using these engines B<WILL NOT> run without modification
+to the engine code.
+
+=over
+
+=item Catalyst::Engine::Wx
+
+=item Catalyst::Engine::Zeus
+
+=item Catalyst::Engine::JobQueue::POE
+
+=item Catalyst::Engine::XMPP2
+
+=item Catalyst::Engine::SCGI
+
+=back
+
+=head2 Engines with unknown status
+
+The following engines have untested or unknown compatibility. Reports are
+highly welcomed:
+
+=over
+
+=item Catalyst::Engine::Mojo
+
+=item Catalyst::Engine::Server (Marked as Deprecated)
+
+=item Catalyst::Engine::HTTP::POE (Marked as Deprecated)
+
+=back
+
+=head2 Using middleware
+
+XXX Should this be here or elsewhere?
+
+=head2 Making an app.psgi file
+
+=head2 Running with plackup?
+
+=head2 Tests in 5.89
+
+Tests should generally work the same in Catalyst 5.89, however there are some differences.
+
+Previously, if using L<Catalyst::Test> and doing local requests (against a local server),
+if the application threw an exception then this exception propagated into the test.
+
+This behaviour has been removed, and now a 500 response will be returned to the test.
+This change unifies behaviour, to make local test requests behave similarly to remote
+requests.
+
=head1 Upgrading to Catalyst 5.80
Most applications and plugins should run unaltered on Catalyst 5.80.
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+use TestApp;
+use Catalyst::Test ();
+
+{
+ like do {
+ my $warning;
+ local $SIG{__WARN__} = sub { $warning = $_[0] };
+ isa_ok Catalyst::Test::local_request('TestApp', '/'), 'HTTP::Response';
+ $warning;
+ }, qr/deprecated/, 'local_request is deprecated';
+}
+
+done_testing;
'forward_to_uri_check request');
ok( $response->is_success, 'forward_to_uri_check successful');
- is( $response->content, '/action/forward/foo/bar',
+ is( $response->content, 'action/forward/foo/bar',
'forward_to_uri_check correct namespace');
}
TestApp::Controller::Root->index
TestApp::Controller::Root->end
];
-
+
my $expected = join( ", ", @expected );
ok( my $response = request('http://localhost/'), 'root index' );
is( $response->header('X-Catalyst-Executed'),
$expected, 'Executed actions' );
is( $response->content, 'root index', 'root index ok' );
-
+
ok( $response = request('http://localhost'), 'root index no slash' );
is( $response->content, 'root index', 'root index no slash ok' );
}
-
+
# test first-level controller index
{
my @expected = qw[
TestApp::Controller::Index->index
TestApp::Controller::Root->end
];
-
+
my $expected = join( ", ", @expected );
-
+
ok( my $response = request('http://localhost/index/'), 'first-level controller index' );
is( $response->header('X-Catalyst-Executed'),
$expected, 'Executed actions' );
is( $response->content, 'Index index', 'first-level controller index ok' );
-
+
ok( $response = request('http://localhost/index'), 'first-level controller index no slash' );
is( $response->header('X-Catalyst-Executed'),
$expected, 'Executed actions' );
- is( $response->content, 'Index index', 'first-level controller index no slash ok' );
- }
-
+ is( $response->content, 'Index index', 'first-level controller index no slash ok' );
+ }
+
# test second-level controller index
{
my @expected = qw[
TestApp::Controller::Action::Index->index
TestApp::Controller::Root->end
];
-
+
my $expected = join( ", ", @expected );
-
+
ok( my $response = request('http://localhost/action/index/'), 'second-level controller index' );
is( $response->header('X-Catalyst-Executed'),
$expected, 'Executed actions' );
is( $response->content, 'Action-Index index', 'second-level controller index ok' );
-
+
ok( $response = request('http://localhost/action/index'), 'second-level controller index no slash' );
is( $response->header('X-Catalyst-Executed'),
$expected, 'Executed actions' );
- is( $response->content, 'Action-Index index', 'second-level controller index no slash ok' );
+ is( $response->content, 'Action-Index index', 'second-level controller index no slash ok' );
}
-
+
# test controller default when index is present
{
my @expected = qw[
TestApp::Controller::Action::Index->default
TestApp::Controller::Root->end
];
-
+
my $expected = join( ", ", @expected );
-
+
ok( my $response = request('http://localhost/action/index/foo'), 'default with index' );
is( $response->header('X-Catalyst-Executed'),
$expected, 'Executed actions' );
'TestApp::Controller::Action::Regexp',
'Test Class'
);
- my $location = $response->header('location');
- $location =~ s/localhost(:\d+)?/localhost/;
is(
- $location,
- $url,
+ $response->header('location'),
+ $response->request->uri,
'Redirect URI is the same as the request URI'
);
}
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 strict;
use warnings;
+no warnings 'once';
use FindBin;
use lib "$FindBin::Bin/../lib";
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+use File::Temp qw/ tempdir /;
+use TestApp;
+use File::Spec;
+
+my $home = tempdir( CLEANUP => 1 );
+my $path = File::Spec->catfile($home, 'testapp.psgi');
+open(my $psgi, '>', $path)
+ or die;
+print $psgi q{
+use strict;
+use warnings;
+use TestApp;
+
+TestApp->psgi_app;
+};
+close($psgi);
+# Check we wrote out something that compiles
+system($^X, '-I', "$FindBin::Bin/../lib", '-c', $path)
+ ? fail('.psgi does not compile')
+ : pass('.psgi compiles');
+
+# NOTE - YOU *CANNOT* do something like:
+#my $psgi_ref = require $path;
+# otherwise this test passes!
+# I don't exactly know why that is yet, however, to be safe for future, that
+# is why this test writes out it's own .psgi file in a temp directory - so that that
+# path has never been require'd before, and will never be require'd again..
+
+local TestApp->config->{home} = $home;
+
+my $failed = 0;
+eval {
+ # Catch infinite recursion (or anything else)
+ local $SIG{__WARN__} = sub { warn(@_); $failed = 1; die; };
+ TestApp->_finalized_psgi_app;
+};
+ok(!$@, 'No exception')
+ or diag $@;
+ok(!$failed, 'TestApp->_finalized_psgi_app works');
+
+done_testing;
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/';
-}
-
{
my $r = get_req (0,
PATH_INFO => '/auth/login',
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;
}
use Test::More;
-eval "use FCGI";
-plan skip_all => 'FCGI required' if $@;
-
-plan tests => 2;
-
-require Catalyst::Engine::FastCGI;
+use Catalyst;
my %env = (
'SCRIPT_NAME' => '/koo/blurb',
'HTTP_HOST' => '127.0.0.1:83'
);
-Catalyst::Engine::FastCGI->_fix_env(\%env);
+sub fix_env {
+ my (%input_env) = @_;
+
+ my $mangled_env;
+ my $app = Catalyst->apply_default_middlewares(sub {
+ my ($env) = @_;
+ $mangled_env = $env;
+ return [ 200, ['Content-Type' => 'text/plain'], [''] ];
+ });
+
+ $app->({ %input_env, 'psgi.url_scheme' => 'http' });
+ return %{ $mangled_env };
+}
+
+my %fixed_env = fix_env(%env);
-is($env{PATH_INFO}, '//blurb', 'check PATH_INFO');
-is($env{SCRIPT_NAME}, '/koo', 'check SCRIPT_NAME');
+is($fixed_env{PATH_INFO}, '//blurb', 'check PATH_INFO');
+is($fixed_env{SCRIPT_NAME}, '/koo', 'check SCRIPT_NAME');
+done_testing;
use Test::More;
-eval "use FCGI";
-plan skip_all => 'FCGI required' if $@;
-
-plan tests => 2;
-
-require Catalyst::Engine::FastCGI;
+use Catalyst ();
my %env = (
'SCRIPT_NAME' => '/bar',
'HTTP_HOST' => 'localhost:8000',
);
-Catalyst::Engine::FastCGI->_fix_env(\%env);
+sub fix_env {
+ my (%input_env) = @_;
+
+ my $mangled_env;
+ my $app = Catalyst->apply_default_middlewares(sub {
+ my ($env) = @_;
+ $mangled_env = $env;
+ return [ 200, ['Content-Type' => 'text/plain'], [''] ];
+ });
+
+ $app->({ %input_env, 'psgi.url_scheme' => 'http' });
+ return %{ $mangled_env };
+}
+
+my %fixed_env = fix_env(%env);
-is($env{PATH_INFO}, '/bar', 'check PATH_INFO');
-ok(!exists($env{SCRIPT_NAME}), 'check SCRIPT_NAME');
+is($fixed_env{PATH_INFO}, '/bar', 'check PATH_INFO');
+ok(!exists($fixed_env{SCRIPT_NAME}) || !length($fixed_env{SCRIPT_NAME}),
+ 'check SCRIPT_NAME');
+done_testing;
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;
use Catalyst::Script::FastCGI;
-my $testopts;
+local our $fake_handler = \42;
+
+{
+ package TestFastCGIScript;
+ use Moose;
+ use namespace::autoclean;
+
+ extends 'Catalyst::Script::FastCGI';
+
+ # Avoid loading the real plack engine, as that will load FCGI and fail if
+ # it's not there. We don't really need a full engine anyway as the overriden
+ # MyApp->run will just capture its arguments and return without delegating
+ # to the engine to run things.
+ override load_engine => sub { $fake_handler };
+
+ __PACKAGE__->meta->make_immutable;
+}
+
+sub testOption {
+ my ($argstring, $resultarray) = @_;
+
+ local @ARGV = @$argstring;
+ local @TestAppToTestScripts::RUN_ARGS;
+ lives_ok {
+ TestFastCGIScript->new_with_options(application_name => 'TestAppToTestScripts')->run;
+ } "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;
+ is $server, $fake_handler, 'Loaded Plack handler gets passed to the app';
+ is_deeply \@TestAppToTestScripts::RUN_ARGS, $resultarray, "is_deeply comparison";
+}
+
+# Returns the hash expected when no flags are passed
+sub opthash {
+ return {
+ (map { ($_ => undef) } qw(pidfile keep_stderr detach nproc manager)),
+ proc_title => 'perl-fcgi-pm [TestAppToTestScripts]',
+ @_,
+ };
+}
+
# Test default (no opts/args behaviour)
testOption( [ qw// ], [undef, opthash()] );
testOption( [ qw/--proc_title foo/ ], [undef, opthash(proc_title => 'foo')] );
done_testing;
-
-sub testOption {
- my ($argstring, $resultarray) = @_;
-
- local @ARGV = @$argstring;
- local @TestAppToTestScripts::RUN_ARGS;
- lives_ok {
- Catalyst::Script::FastCGI->new_with_options(application_name => 'TestAppToTestScripts')->run;
- } "new_with_options";
- # First element of RUN_ARGS will be the script name, which we don't care about
- shift @TestAppToTestScripts::RUN_ARGS;
- 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,
- @_,
- };
-}
testOption( [ qw/--keepalive/ ], ['3000', undef, opthash(keepalive => 1)] );
# symlinks -follow_symlinks --sym --follow_symlinks
-testOption( [ qw/--follow_symlinks/ ], ['3000', undef, opthash(follow_symlinks => 1)] );
+#
testOption( [ qw/--sym/ ], ['3000', undef, opthash(follow_symlinks => 1)] );
+testOption( [ qw/--follow_symlinks/ ], ['3000', undef, opthash(follow_symlinks => 1)] );
# background -background --bg --background
testOption( [ qw/--background/ ], ['3000', undef, opthash(background => 1)] );
testOption( [ qw/--bg/ ], ['3000', undef, opthash(background => 1)] );
+
# restart -r -restart --restart -R --restart
testRestart( ['-r'], restartopthash() );
{
};
# 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';
+
+ my @run_args = @TestAppToTestScripts::RUN_ARGS;
+ $run_args[-1]->{pidfile} = $run_args[-1]->{pidfile}->file->stringify
+ if $run_args[-1]->{pidfile};
+
+
# Mangle argv into the options..
$resultarray->[-1]->{argv} = $argstring;
- is_deeply \@TestAppToTestScripts::RUN_ARGS, $resultarray, "is_deeply comparison " . join(' ', @$argstring);
+ is_deeply \@run_args, $resultarray, "is_deeply comparison " . join(' ', @$argstring);
}
sub testRestart {
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+use Catalyst::EngineLoader;
+
+my $cases = {
+ FastCGI => {
+ expected_catalyst_engine_class => 'Catalyst::Engine',
+ ENV => { CATALYST_ENGINE => 'FastCGI' },
+ },
+ CGI => {
+ expected_catalyst_engine_class => 'Catalyst::Engine',
+ ENV => { CATALYST_ENGINE => 'CGI' },
+ },
+ Apache1 => {
+ expected_catalyst_engine_class => 'Catalyst::Engine',
+ ENV => { CATALYST_ENGINE => 'Apache1' },
+ },
+};
+
+foreach my $name (keys %$cases) {
+ local %ENV = %{ $cases->{$name}->{ENV} };
+ my $loader = Catalyst::EngineLoader->new(application_name => "TestApp");
+ if (my $expected = $cases->{$name}->{expected_catalyst_engine_class}) {
+ is $loader->catalyst_engine_class, $expected, $name . " catalyst_engine_class";
+ }
+}
+
+done_testing;
# 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');
use File::Path;
use FindBin;
-use IPC::Open3;
-use IO::Socket;
+use Test::TCP;
+use Try::Tiny;
+use Plack::Builder;
use Catalyst::Devel 1.0;
use File::Copy::Recursive;
rmtree '../t/tmp/TestApp/t' or die;
# spawn the standalone HTTP server
-my $port = 30000 + int rand(1 + 10000);
-my @cmd = ($^X, "-I$FindBin::Bin/../../lib",
- "$FindBin::Bin/../../t/tmp/TestApp/script/testapp_server.pl", '--port', $port );
-my $pid = open3( undef, my $server, undef, @cmd)
- or die "Unable to spawn standalone HTTP server: $!";
-
-# wait for it to start
-print "Waiting for server to start...\n";
-my $timeout = 30;
-my $count = 0;
-while ( check_port( 'localhost', $port ) != 1 ) {
- sleep 1;
- die("Server did not start within $timeout seconds: " . join(' ', @cmd))
- if $count++ > $timeout;
+my $port = empty_port;
+
+my $pid = fork;
+if ($pid) {
+ # parent.
+ print "Waiting for server to start...\n";
+ wait_port_timeout($port, 30);
+} elsif ($pid == 0) {
+ # child process
+ unshift @INC, "$tmpdir/TestApp/lib", "$FindBin::Bin/../../lib";
+ require TestApp;
+
+ my $psgi_app = TestApp->apply_default_middlewares(TestApp->psgi_app);
+ Plack::Loader->auto(port => $port)->run(builder {
+ mount '/test_prefix' => $psgi_app;
+ mount '/' => sub {
+ return [501, ['Content-Type' => 'text/plain'], ['broken tests']];
+ };
+ });
+
+ exit 0;
+} else {
+ die "fork failed: $!";
}
# run the testsuite against the HTTP server
-$ENV{CATALYST_SERVER} = "http://localhost:$port";
+$ENV{CATALYST_SERVER} = "http://localhost:$port/test_prefix";
chdir '..';
# shut it down
kill 'INT', $pid;
-close $server;
# clean up
rmtree "$FindBin::Bin/../../t/tmp" if -d "$FindBin::Bin/../../t/tmp";
is( $return, 0, 'live tests' );
-sub check_port {
- my ( $host, $port ) = @_;
-
- my $remote = IO::Socket::INET->new(
- Proto => "tcp",
- PeerAddr => $host,
- PeerPort => $port
- );
- if ($remote) {
- close $remote;
- return 1;
- }
- else {
- return 0;
+sub wait_port_timeout {
+ my ($port, $timeout) = @_;
+
+ # wait_port waits for 10 seconds
+ for (1 .. int($timeout / 10)) { # meh, good enough.
+ try { wait_port $port; 1 } and return;
}
+
+ die "Server did not start within $timeout seconds";
}
sub prove {
our @private = ( 'BUILD' );
foreach my $module (@modules) {
local @private = (@private, 'run') if $module =~ /^Catalyst::Script::/;
- pod_coverage_ok($module, { also_private => \@private });
+ pod_coverage_ok($module, {
+ also_private => \@private,
+ coverage_class => 'Pod::Coverage::TrustPod',
+ });
}
done_testing;
use Test::More tests => 1;
use Catalyst ();
-use Catalyst::Engine::HTTP;
eval {
require TestAppUnknownError;
};
sub uri_check : Private {
my ( $self, $c ) = @_;
- $c->res->body( $c->uri_for('foo/bar')->path );
+ $c->res->body( $c->uri_for('foo/bar')->rel($c->req->base)->path );
}
1;
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;
+use strict;
+use warnings;
+
use FindBin;
use lib "$FindBin::Bin/lib";
use Catalyst::Test 'TestApp', {default_host => 'default.com'};
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+use FindBin qw/$Bin/;
+use lib "$Bin/lib";
+
+use Test::More;
+
+use File::Spec;
+use File::Temp qw/ tempdir /;
+
+my $temp;
+BEGIN {
+ $temp = tempdir( CLEANUP => 1 );
+
+ $ENV{CATALYST_HOME} = $temp;
+ open(my $psgi, '>', File::Spec->catdir($temp, 'testapp.psgi')) or die;
+ print $psgi q{
+ use strict;
+ use TestApp;
+
+ $main::have_loaded_psgi = 1;
+ my $app = TestApp->psgi_app;
+ };
+ close($psgi);
+}
+use Catalyst::Test qw/ TestApp /;
+
+ok request('/');
+ok $main::have_loaded_psgi;
+
+done_testing;
+
--- /dev/null
+use strict;
+use warnings;
+use FindBin qw/$Bin/;
+use lib "$Bin/lib";
+
+use Test::More;
+use Test::Exception;
+use Plack::Test;
+use TestApp;
+use HTTP::Request::Common;
+
+my $warning;
+local $SIG{__WARN__} = sub { $warning = $_[0] };
+
+TestApp->setup_engine('PSGI');
+my $app = sub { TestApp->run(@_) };
+
+like $warning, qr/You are running Catalyst\:\:Engine\:\:PSGI/,
+ 'got deprecation alert warning';
+
+test_psgi $app, sub {
+ my $cb = shift;
+ lives_ok {
+ my $TIMEOUT_IN_SECONDS = 5;
+ local $SIG{ALRM} = sub { die "alarm\n" };
+ alarm($TIMEOUT_IN_SECONDS);
+
+ my $res = $cb->(GET "/");
+ is $res->content, "root index", 'got expected content';
+ like $warning, qr/env as a writer/, 'got deprecation alert warning';
+
+ alarm(0);
+ 1
+ } q{app didn't die or timeout};
+};
+
+done_testing;
+
--- /dev/null
+use strict;
+use warnings;
+no warnings 'once';
+use FindBin qw/$Bin/;
+use lib "$Bin/lib";
+
+use Test::More;
+
+use File::Spec;
+use File::Temp qw/ tempdir /;
+
+my $temp;
+BEGIN {
+ $temp = tempdir( CLEANUP => 1 );
+
+ $ENV{CATALYST_HOME} = $temp;
+ open(my $psgi, '>', File::Spec->catdir($temp, 'testapp.psgi')) or die;
+ print $psgi q{
+ use strict;
+ use TestApp;
+
+ $main::have_loaded_psgi = 1;
+ TestApp->setup_engine('PSGI');
+ my $app = sub { TestApp->run(@_) };
+ };
+ close($psgi);
+}
+use Catalyst::Test qw/ TestApp /;
+
+ok !$main::have_loaded_psgi, 'legacy psgi file got ignored';
+
+like do {
+ my $warning;
+ local $SIG{__WARN__} = sub { $warning = $_[0] };
+ ok request('/');
+ $warning;
+}, qr/ignored/, 'legacy psgi files raise a warning';
+
+done_testing;
+
projects / catagits/Catalyst-Runtime.git / commitdiff