2308 lines
62 KiB
Perl
2308 lines
62 KiB
Perl
# Licensed to the Apache Software Foundation (ASF) under one or more
|
|
# contributor license agreements. See the NOTICE file distributed with
|
|
# this work for additional information regarding copyright ownership.
|
|
# The ASF licenses this file to You under the Apache License, Version 2.0
|
|
# (the "License"); you may not use this file except in compliance with
|
|
# the License. You may obtain a copy of the License at
|
|
#
|
|
# http://www.apache.org/licenses/LICENSE-2.0
|
|
#
|
|
# Unless required by applicable law or agreed to in writing, software
|
|
# distributed under the License is distributed on an "AS IS" BASIS,
|
|
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
# See the License for the specific language governing permissions and
|
|
# limitations under the License.
|
|
#
|
|
package Apache::TestConfig;
|
|
|
|
use strict;
|
|
use warnings FATAL => 'all';
|
|
|
|
use constant WIN32 => $^O eq 'MSWin32';
|
|
use constant OSX => $^O eq 'darwin';
|
|
use constant CYGWIN => $^O eq 'cygwin';
|
|
use constant NETWARE => $^O eq 'NetWare';
|
|
use constant SOLARIS => $^O eq 'solaris';
|
|
use constant AIX => $^O eq 'aix';
|
|
use constant WINFU => WIN32 || NETWARE;
|
|
use constant COLOR => ($ENV{APACHE_TEST_COLOR} && -t STDOUT) ? 1 : 0;
|
|
|
|
use constant DEFAULT_PORT => 8529;
|
|
|
|
use constant IS_MOD_PERL_2 =>
|
|
eval { require mod_perl2 } || 0;
|
|
|
|
use constant IS_MOD_PERL_2_BUILD => IS_MOD_PERL_2 &&
|
|
eval { require Apache2::Build && Apache2::Build::IS_MOD_PERL_BUILD() };
|
|
|
|
use constant IS_APACHE_TEST_BUILD =>
|
|
grep { -e "$_/lib/Apache/TestConfig.pm" }
|
|
qw(Apache-Test . .. ../Apache-Test);
|
|
|
|
use lib ();
|
|
use File::Copy ();
|
|
use File::Find qw(finddepth);
|
|
use File::Basename qw(dirname);
|
|
use File::Path ();
|
|
use File::Spec::Functions qw(catfile abs2rel splitdir canonpath
|
|
catdir file_name_is_absolute devnull);
|
|
use Cwd qw(fastcwd);
|
|
use Socket ();
|
|
use Symbol ();
|
|
|
|
use Apache::TestConfigPerl ();
|
|
use Apache::TestConfigParse ();
|
|
use Apache::TestTrace;
|
|
use Apache::TestServer ();
|
|
use Apache::TestRun ();
|
|
|
|
use vars qw(%Usage);
|
|
|
|
%Usage = (
|
|
top_dir => 'top-level directory (default is $PWD)',
|
|
t_dir => 'the t/ test directory (default is $top_dir/t)',
|
|
t_conf => 'the conf/ test directory (default is $t_dir/conf)',
|
|
t_logs => 'the logs/ test directory (default is $t_dir/logs)',
|
|
t_state => 'the state/ test directory (default is $t_dir/state)',
|
|
t_pid_file => 'location of the pid file (default is $t_logs/httpd.pid)',
|
|
t_conf_file => 'test httpd.conf file (default is $t_conf/httpd.conf)',
|
|
src_dir => 'source directory to look for mod_foos.so',
|
|
serverroot => 'ServerRoot (default is $t_dir)',
|
|
documentroot => 'DocumentRoot (default is $ServerRoot/htdocs',
|
|
port => 'Port [port_number|select] (default ' . DEFAULT_PORT . ')',
|
|
servername => 'ServerName (default is localhost)',
|
|
user => 'User to run test server as (default is $USER)',
|
|
group => 'Group to run test server as (default is $GROUP)',
|
|
bindir => 'Apache bin/ dir (default is apxs -q BINDIR)',
|
|
sbindir => 'Apache sbin/ dir (default is apxs -q SBINDIR)',
|
|
httpd => 'server to use for testing (default is $bindir/httpd)',
|
|
target => 'name of server binary (default is apxs -q TARGET)',
|
|
apxs => 'location of apxs (default is from Apache2::BuildConfig)',
|
|
startup_timeout => 'seconds to wait for the server to start (default is 60)',
|
|
httpd_conf => 'inherit config from this file (default is apxs derived)',
|
|
httpd_conf_extra => 'inherit additional config from this file',
|
|
minclients => 'minimum number of concurrent clients (default is 1)',
|
|
maxclients => 'maximum number of concurrent clients (default is minclients+1)',
|
|
threadsperchild => 'number of threads per child when using threaded MPMs (default is 10)',
|
|
limitrequestline => 'global LimitRequestLine setting (default is 128)',
|
|
perlpod => 'location of perl pod documents (for testing downloads)',
|
|
proxyssl_url => 'url for testing ProxyPass / https (default is localhost)',
|
|
sslca => 'location of SSL CA (default is $t_conf/ssl/ca)',
|
|
sslcaorg => 'SSL CA organization to use for tests (default is asf)',
|
|
sslproto => 'SSL/TLS protocol version(s) to test',
|
|
libmodperl => 'path to mod_perl\'s .so (full or relative to LIBEXECDIR)',
|
|
defines => 'values to add as -D defines (for example, "VAR1 VAR2")',
|
|
(map { $_ . '_module_name', "$_ module name"} qw(cgi ssl thread access auth php)),
|
|
);
|
|
|
|
my %filepath_conf_opts = map { $_ => 1 }
|
|
qw(top_dir t_dir t_conf t_logs t_state t_pid_file t_conf_file src_dir serverroot
|
|
documentroot bindir sbindir httpd apxs httpd_conf httpd_conf_extra
|
|
perlpod sslca libmodperl);
|
|
|
|
sub conf_opt_is_a_filepath {
|
|
my $opt = shift;
|
|
$opt && exists $filepath_conf_opts{$opt};
|
|
}
|
|
|
|
sub usage {
|
|
for my $hash (\%Usage) {
|
|
for (sort keys %$hash){
|
|
printf " -%-18s %s\n", $_, $hash->{$_};
|
|
}
|
|
}
|
|
}
|
|
|
|
sub filter_args {
|
|
my($args, $wanted_args) = @_;
|
|
my(@pass, %keep);
|
|
|
|
my @filter = @$args;
|
|
|
|
if (ref($filter[0])) {
|
|
push @pass, shift @filter;
|
|
}
|
|
|
|
while (@filter) {
|
|
my $key = shift @filter;
|
|
# optinal - or -- prefix
|
|
if (defined $key && $key =~ /^-?-?(.+)/ && exists $wanted_args->{$1}) {
|
|
if (@filter) {
|
|
$keep{$1} = shift @filter;
|
|
}
|
|
else {
|
|
die "key $1 requires a matching value";
|
|
}
|
|
}
|
|
else {
|
|
push @pass, $key;
|
|
}
|
|
}
|
|
|
|
return (\@pass, \%keep);
|
|
}
|
|
|
|
my %passenv = map { $_,1 } qw{
|
|
APACHE_TEST_APXS
|
|
APACHE_TEST_HTTPD
|
|
APACHE_TEST_GROUP
|
|
APACHE_TEST_USER
|
|
APACHE_TEST_PORT
|
|
};
|
|
|
|
sub passenv {
|
|
\%passenv;
|
|
}
|
|
|
|
sub passenv_makestr {
|
|
my @vars;
|
|
|
|
for (sort keys %passenv) {
|
|
push @vars, "$_=\$($_)";
|
|
}
|
|
|
|
"@vars";
|
|
}
|
|
|
|
sub server { shift->{server} }
|
|
|
|
sub modperl_build_config {
|
|
|
|
my $self = shift;
|
|
|
|
my $server = ref $self ? $self->server : new_test_server();
|
|
|
|
# we can't do this if we're using httpd 1.3.X
|
|
# even if mod_perl2 is installed on the box
|
|
# similarly, we shouldn't be loading mp2 if we're not
|
|
# absolutely certain we're in a 2.X environment yet
|
|
# (such as mod_perl's own build or runtime environment)
|
|
if (($server->{rev} && $server->{rev} == 2) ||
|
|
IS_MOD_PERL_2_BUILD || $ENV{MOD_PERL_API_VERSION}) {
|
|
eval {
|
|
require Apache2::Build;
|
|
} or return;
|
|
|
|
return Apache2::Build->build_config;
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
sub new_test_server {
|
|
my($self, $args) = @_;
|
|
Apache::TestServer->new($args || $self)
|
|
}
|
|
|
|
# setup httpd-independent components
|
|
# for httpd-specific call $self->httpd_config()
|
|
sub new {
|
|
my $class = shift;
|
|
|
|
my $args;
|
|
|
|
$args = shift if $_[0] and ref $_[0];
|
|
|
|
$args = $args ? {%$args} : {@_}; #copy
|
|
|
|
#see Apache::TestMM::{filter_args,generate_script}
|
|
#we do this so 'perl Makefile.PL' can be passed options such as apxs
|
|
#without forcing regeneration of configuration and recompilation of c-modules
|
|
#as 't/TEST apxs /path/to/apache/bin/apxs' would do
|
|
while (my($key, $val) = each %Apache::TestConfig::Argv) {
|
|
$args->{$key} = $val;
|
|
}
|
|
|
|
my $top_dir = fastcwd;
|
|
$top_dir = pop_dir($top_dir, 't');
|
|
# untaint as we are going to use it a lot later on in -T sensitive
|
|
# operations (.e.g @INC)
|
|
$top_dir = $1 if $top_dir =~ /(.*)/;
|
|
|
|
# make sure that t/conf/apache_test_config.pm is found
|
|
# (unfortunately sometimes we get thrown into / by Apache so we
|
|
# can't just rely on $top_dir
|
|
lib->import($top_dir);
|
|
|
|
my $thaw = {};
|
|
#thaw current config
|
|
for (qw(conf t/conf)) {
|
|
last if eval {
|
|
require "$_/apache_test_config.pm";
|
|
$thaw = 'apache_test_config'->new;
|
|
delete $thaw->{save};
|
|
#incase class that generated the config was
|
|
#something else, which we can't be sure how to load
|
|
bless $thaw, 'Apache::TestConfig';
|
|
};
|
|
}
|
|
|
|
if ($args->{thaw} and ref($thaw) ne 'HASH') {
|
|
#dont generate any new config
|
|
$thaw->{vars}->{$_} = $args->{$_} for keys %$args;
|
|
$thaw->{server} = $thaw->new_test_server;
|
|
$thaw->add_inc;
|
|
return $thaw;
|
|
}
|
|
|
|
#regenerating config, so forget old
|
|
if ($args->{save}) {
|
|
for (qw(vhosts inherit_config modules inc cmodules)) {
|
|
delete $thaw->{$_} if exists $thaw->{$_};
|
|
}
|
|
}
|
|
|
|
my $self = bless {
|
|
clean => {},
|
|
vhosts => {},
|
|
inherit_config => {},
|
|
modules => {},
|
|
inc => [],
|
|
%$thaw,
|
|
mpm => "",
|
|
httpd_defines => {},
|
|
vars => $args,
|
|
postamble => [],
|
|
preamble => [],
|
|
postamble_hooks => [],
|
|
preamble_hooks => [],
|
|
}, ref($class) || $class;
|
|
|
|
my $vars = $self->{vars}; #things that can be overridden
|
|
|
|
for (qw(save verbose)) {
|
|
next unless exists $args->{$_};
|
|
$self->{$_} = delete $args->{$_};
|
|
}
|
|
|
|
$vars->{top_dir} ||= $top_dir;
|
|
|
|
$self->add_inc;
|
|
|
|
#help to find libmodperl.so
|
|
unless ($vars->{src_dir}) {
|
|
my $src_dir = catfile $vars->{top_dir}, qw(.. src modules perl);
|
|
|
|
if (-d $src_dir) {
|
|
$vars->{src_dir} = $src_dir;
|
|
} else {
|
|
$src_dir = catfile $vars->{top_dir}, qw(src modules perl);
|
|
$vars->{src_dir} = $src_dir if -d $src_dir;
|
|
}
|
|
}
|
|
|
|
$vars->{t_dir} ||= catfile $vars->{top_dir}, 't';
|
|
$vars->{serverroot} ||= $vars->{t_dir};
|
|
$vars->{documentroot} ||= catfile $vars->{serverroot}, 'htdocs';
|
|
$vars->{perlpod} ||= $self->find_in_inc('pods') ||
|
|
$self->find_in_inc('pod');
|
|
$vars->{perl} ||= $^X;
|
|
$vars->{t_conf} ||= catfile $vars->{serverroot}, 'conf';
|
|
$vars->{sslca} ||= catfile $vars->{t_conf}, 'ssl', 'ca';
|
|
$vars->{sslcaorg} ||= 'asf';
|
|
|
|
if (!defined($vars->{sslproto}) and eval { require Apache::TestSSLCA; 1; }) {
|
|
$vars->{sslproto} = Apache::TestSSLCA::sslproto();
|
|
}
|
|
else {
|
|
$vars->{sslproto} ||= 'all';
|
|
}
|
|
|
|
$vars->{t_logs} ||= catfile $vars->{serverroot}, 'logs';
|
|
$vars->{t_state} ||= catfile $vars->{serverroot}, 'state';
|
|
$vars->{t_conf_file} ||= catfile $vars->{t_conf}, 'httpd.conf';
|
|
$vars->{t_pid_file} ||= catfile $vars->{t_logs}, 'httpd.pid';
|
|
|
|
if (WINFU) {
|
|
for (keys %$vars) {
|
|
$vars->{$_} =~ s|\\|\/|g if defined $vars->{$_};
|
|
}
|
|
}
|
|
|
|
$vars->{scheme} ||= 'http';
|
|
$vars->{servername} ||= $self->default_servername;
|
|
$vars->{port} = $self->select_first_port;
|
|
$vars->{remote_addr} ||= $self->our_remote_addr;
|
|
|
|
$vars->{user} ||= $self->default_user;
|
|
$vars->{group} ||= $self->default_group;
|
|
$vars->{serveradmin} ||= $self->default_serveradmin;
|
|
|
|
$vars->{threadsperchild} ||= 10;
|
|
$vars->{minclients} ||= 1;
|
|
$vars->{maxclients_preset} = $vars->{maxclients} || 0;
|
|
# if maxclients wasn't explicitly passed try to
|
|
# prevent 'server reached MaxClients setting' errors
|
|
$vars->{maxclients} ||= $vars->{minclients} + 1;
|
|
|
|
# if a preset maxclients valus is smaller than minclients,
|
|
# maxclients overrides minclients
|
|
if ($vars->{maxclients_preset} &&
|
|
$vars->{maxclients_preset} < $vars->{minclients}) {
|
|
$vars->{minclients} = $vars->{maxclients_preset};
|
|
}
|
|
if ($vars->{minclients} < 2) {
|
|
$vars->{maxspare} = 2;
|
|
} else {
|
|
$vars->{maxspare} = $vars->{minclients};
|
|
}
|
|
if ($vars->{maxclients} < $vars->{maxspare} + 1) {
|
|
$vars->{maxclients} = $vars->{maxspare} + 1;
|
|
}
|
|
|
|
# for threaded mpms MinClients and MaxClients must be a
|
|
# multiple of ThreadsPerChild
|
|
{
|
|
use integer;
|
|
$vars->{minclientsthreadedmpm} = ($vars->{minclients} + $vars->{threadsperchild} - 1) /
|
|
$vars->{threadsperchild} * $vars->{threadsperchild};
|
|
$vars->{maxclientsthreadedmpm} = ($vars->{maxclients} + $vars->{threadsperchild} - 1) /
|
|
$vars->{threadsperchild} * $vars->{threadsperchild};
|
|
$vars->{maxsparethreadedmpm} = ($vars->{maxspare} + $vars->{threadsperchild} - 1) /
|
|
$vars->{threadsperchild} * $vars->{threadsperchild};
|
|
$vars->{startserversthreadedmpm} = $vars->{minclientsthreadedmpm} / $vars->{threadsperchild};
|
|
}
|
|
if ($vars->{maxsparethreadedmpm} < 2 * $vars->{threadsperchild}) {
|
|
$vars->{maxsparethreadedmpm} = 2 * $vars->{threadsperchild};
|
|
}
|
|
if ($vars->{maxclientsthreadedmpm} < $vars->{maxsparethreadedmpm} + $vars->{threadsperchild}) {
|
|
$vars->{maxclientsthreadedmpm} = $vars->{maxsparethreadedmpm} + $vars->{threadsperchild};
|
|
}
|
|
|
|
$vars->{limitrequestline} ||= 128;
|
|
$vars->{limitrequestlinex2} = 2 * $vars->{limitrequestline};
|
|
|
|
$vars->{proxy} ||= 'off';
|
|
$vars->{proxyssl_url} ||= '';
|
|
$vars->{defines} ||= '';
|
|
|
|
$self->{hostport} = $self->hostport;
|
|
$self->{server} = $self->new_test_server;
|
|
|
|
return $self;
|
|
|
|
}
|
|
|
|
# figure out where httpd is and run extra config hooks which require
|
|
# knowledge of where httpd is
|
|
sub httpd_config {
|
|
my $self = shift;
|
|
|
|
$self->configure_apxs;
|
|
$self->configure_httpd;
|
|
|
|
my $vars = $self->{vars};
|
|
unless ($vars->{httpd} or $vars->{apxs}) {
|
|
|
|
# mod_perl 2.0 build (almost) always knows the right httpd
|
|
|
|
# location (and optionally apxs). if we get here we can't
|
|
# continue because the interactive config can't work with
|
|
# mod_perl 2.0 build (by design)
|
|
if (IS_MOD_PERL_2_BUILD){
|
|
my $mp2_build = $self->modperl_build_config();
|
|
# if mod_perl 2 was built against the httpd source it
|
|
# doesn't know where to find apxs/httpd, so in this case
|
|
# fall back to interactive config
|
|
unless ($mp2_build->{MP_APXS}) {
|
|
die "mod_perl 2 was built against Apache sources, we " .
|
|
"don't know where httpd/apxs executables are, therefore " .
|
|
"skipping the test suite execution"
|
|
}
|
|
|
|
# not sure what else could go wrong but we can't continue
|
|
die "something is wrong, mod_perl 2.0 build should have " .
|
|
"supplied all the needed information to run the tests. " .
|
|
"Please post lib/Apache2/BuildConfig.pm along with the " .
|
|
"bug report";
|
|
}
|
|
|
|
$self->clean(1);
|
|
|
|
error "You must explicitly specify -httpd and/or -apxs options, " .
|
|
"or set \$ENV{APACHE_TEST_HTTPD} and \$ENV{APACHE_TEST_APXS}, " .
|
|
"or set your \$PATH to include the httpd and apxs binaries.";
|
|
Apache::TestRun::exit_perl(1);
|
|
|
|
}
|
|
else {
|
|
debug "Using httpd: $vars->{httpd}";
|
|
}
|
|
|
|
$self->inherit_config; #see TestConfigParse.pm
|
|
$self->configure_httpd_eapi; #must come after inherit_config
|
|
|
|
$self->default_module(cgi => [qw(mod_cgi mod_cgid)]);
|
|
$self->default_module(thread => [qw(worker threaded)]);
|
|
$self->default_module(ssl => [qw(mod_ssl)]);
|
|
$self->default_module(access => [qw(mod_access mod_authz_host)]);
|
|
$self->default_module(auth => [qw(mod_auth mod_auth_basic)]);
|
|
$self->default_module(php => [qw(sapi_apache2 mod_php4 mod_php5)]);
|
|
|
|
$self->{server}->post_config;
|
|
|
|
return $self;
|
|
}
|
|
|
|
sub default_module {
|
|
my($self, $name, $choices) = @_;
|
|
|
|
my $mname = $name . '_module_name';
|
|
|
|
unless ($self->{vars}->{$mname}) {
|
|
($self->{vars}->{$mname}) = grep {
|
|
$self->{modules}->{"$_.c"};
|
|
} @$choices;
|
|
|
|
$self->{vars}->{$mname} ||= $choices->[0];
|
|
}
|
|
|
|
$self->{vars}->{$name . '_module'} =
|
|
$self->{vars}->{$mname} . '.c'
|
|
}
|
|
|
|
sub configure_apxs {
|
|
my $self = shift;
|
|
|
|
$self->{APXS} = $self->default_apxs;
|
|
|
|
return unless $self->{APXS};
|
|
|
|
$self->{APXS} =~ s{/}{\\}g if WIN32;
|
|
|
|
my $vars = $self->{vars};
|
|
|
|
$vars->{bindir} ||= $self->apxs('BINDIR', 1);
|
|
$vars->{sbindir} ||= $self->apxs('SBINDIR');
|
|
$vars->{target} ||= $self->apxs('TARGET');
|
|
$vars->{conf_dir} ||= $self->apxs('SYSCONFDIR');
|
|
|
|
if ($vars->{conf_dir}) {
|
|
$vars->{httpd_conf} ||= catfile $vars->{conf_dir}, 'httpd.conf';
|
|
}
|
|
}
|
|
|
|
sub configure_httpd {
|
|
my $self = shift;
|
|
my $vars = $self->{vars};
|
|
|
|
debug "configuring httpd";
|
|
|
|
$vars->{target} ||= (WIN32 ? 'Apache.EXE' : 'httpd');
|
|
|
|
unless ($vars->{httpd}) {
|
|
#sbindir should be bin/ with the default layout
|
|
#but its eaiser to workaround apxs than fix apxs
|
|
for my $dir (map { $vars->{$_} } qw(sbindir bindir)) {
|
|
next unless defined $dir;
|
|
my $httpd = catfile $dir, $vars->{target};
|
|
next unless -x $httpd;
|
|
$vars->{httpd} = $httpd;
|
|
last;
|
|
}
|
|
|
|
$vars->{httpd} ||= $self->default_httpd;
|
|
}
|
|
|
|
if ($vars->{httpd}) {
|
|
my @chunks = splitdir $vars->{httpd};
|
|
#handle both $prefix/bin/httpd and $prefix/Apache.exe
|
|
for (1,2) {
|
|
pop @chunks;
|
|
last unless @chunks;
|
|
$self->{httpd_basedir} = catfile @chunks;
|
|
last if -d "$self->{httpd_basedir}/bin";
|
|
}
|
|
}
|
|
|
|
#cleanup httpd droppings
|
|
my $sem = catfile $vars->{t_logs}, 'apache_runtime_status.sem';
|
|
unless (-e $sem) {
|
|
$self->clean_add_file($sem);
|
|
}
|
|
}
|
|
|
|
sub configure_httpd_eapi {
|
|
my $self = shift;
|
|
my $vars = $self->{vars};
|
|
|
|
#deal with EAPI_MM_CORE_PATH if defined.
|
|
if (defined($self->{httpd_defines}->{EAPI_MM_CORE_PATH})) {
|
|
my $path = $self->{httpd_defines}->{EAPI_MM_CORE_PATH};
|
|
|
|
#ensure the directory exists
|
|
my @chunks = splitdir $path;
|
|
pop @chunks; #the file component of the path
|
|
$path = catdir @chunks;
|
|
unless (file_name_is_absolute $path) {
|
|
$path = catdir $vars->{serverroot}, $path;
|
|
}
|
|
$self->gendir($path);
|
|
}
|
|
}
|
|
|
|
sub configure_proxy {
|
|
my $self = shift;
|
|
my $vars = $self->{vars};
|
|
|
|
#if we proxy to ourselves, must bump the maxclients
|
|
if ($vars->{proxy} =~ /^on$/i) {
|
|
unless ($vars->{maxclients_preset}) {
|
|
$vars->{minclients}++;
|
|
$vars->{maxclients}++;
|
|
$vars->{maxspare}++;
|
|
$vars->{startserversthreadedmpm} ++;
|
|
$vars->{minclientsthreadedmpm} += $vars->{threadsperchild};
|
|
$vars->{maxclientsthreadedmpm} += $vars->{threadsperchild};
|
|
$vars->{maxsparethreadedmpm} += $vars->{threadsperchild};
|
|
#In addition allow for some backend processes
|
|
#in keep-alive state. For threaded MPMs we
|
|
#already should be fine.
|
|
$vars->{maxclients} += 3;
|
|
}
|
|
$vars->{proxy} = $self->{vhosts}->{'mod_proxy'}->{hostport};
|
|
return $vars->{proxy};
|
|
}
|
|
|
|
return undef;
|
|
}
|
|
|
|
# adds the config to the head of the group instead of the tail
|
|
# XXX: would be even better to add to a different sub-group
|
|
# (e.g. preamble_first) of only those that want to be first and then,
|
|
# make sure that they are dumped to the config file first in the same
|
|
# group (e.g. preamble)
|
|
sub add_config_first {
|
|
my $self = shift;
|
|
my $where = shift;
|
|
unshift @{ $self->{$where} }, $self->massage_config_args(@_);
|
|
}
|
|
|
|
sub add_config_last {
|
|
my $self = shift;
|
|
my $where = shift;
|
|
push @{ $self->{$where} }, $self->massage_config_args(@_);
|
|
}
|
|
|
|
sub massage_config_args {
|
|
my $self = shift;
|
|
my($directive, $arg, $data) = @_;
|
|
my $args = "";
|
|
|
|
if ($data) {
|
|
$args = "<$directive $arg>\n";
|
|
if (ref($data) eq 'HASH') {
|
|
while (my($k,$v) = each %$data) {
|
|
$args .= " $k $v\n";
|
|
}
|
|
}
|
|
elsif (ref($data) eq 'ARRAY') {
|
|
# balanced (key=>val) list
|
|
my $pairs = @$data / 2;
|
|
for my $i (0..($pairs-1)) {
|
|
$args .= sprintf " %s %s\n", $data->[$i*2], $data->[$i*2+1];
|
|
}
|
|
}
|
|
else {
|
|
$data=~s/\n(?!\z)/\n /g;
|
|
$args .= " $data";
|
|
}
|
|
$args .= "</$directive>\n";
|
|
}
|
|
elsif (ref($directive) eq 'ARRAY') {
|
|
$args = join "\n", @$directive;
|
|
}
|
|
else {
|
|
$args = join " ", grep length($_), $directive,
|
|
(ref($arg) && (ref($arg) eq 'ARRAY') ? "@$arg" : $arg || "");
|
|
}
|
|
|
|
return $args;
|
|
}
|
|
|
|
sub postamble_first {
|
|
shift->add_config_first(postamble => @_);
|
|
}
|
|
|
|
sub postamble {
|
|
shift->add_config_last(postamble => @_);
|
|
}
|
|
|
|
sub preamble_first {
|
|
shift->add_config_first(preamble => @_);
|
|
}
|
|
|
|
sub preamble {
|
|
shift->add_config_last(preamble => @_);
|
|
}
|
|
|
|
sub postamble_register {
|
|
push @{ shift->{postamble_hooks} }, @_;
|
|
}
|
|
|
|
sub preamble_register {
|
|
push @{ shift->{preamble_hooks} }, @_;
|
|
}
|
|
|
|
sub add_config_hooks_run {
|
|
my($self, $where, $out) = @_;
|
|
|
|
for (@{ $self->{"${where}_hooks"} }) {
|
|
if ((ref($_) and ref($_) eq 'CODE') or $self->can($_)) {
|
|
$self->$_();
|
|
}
|
|
else {
|
|
error "cannot run configure hook: `$_'";
|
|
}
|
|
}
|
|
|
|
for (@{ $self->{$where} }) {
|
|
$self->replace;
|
|
s/\n?$/\n/;
|
|
print $out "$_";
|
|
}
|
|
}
|
|
|
|
sub postamble_run {
|
|
shift->add_config_hooks_run(postamble => @_);
|
|
}
|
|
|
|
sub preamble_run {
|
|
shift->add_config_hooks_run(preamble => @_);
|
|
}
|
|
|
|
sub default_group {
|
|
return if WINFU;
|
|
|
|
my $gid = $);
|
|
|
|
#use only first value if $) contains more than one
|
|
$gid =~ s/^(\d+).*$/$1/;
|
|
|
|
my $group = $ENV{APACHE_TEST_GROUP} || (getgrgid($gid) || "#$gid");
|
|
|
|
if ($group eq 'root') {
|
|
# similar to default_user, we want to avoid perms problems,
|
|
# when the server is started with group 'root'. When running
|
|
# under group root it may fail to create dirs and files,
|
|
# writable only by user
|
|
my $user = default_user();
|
|
my $gid = $user ? (getpwnam($user))[3] : '';
|
|
$group = (getgrgid($gid) || "#$gid") if $gid;
|
|
}
|
|
|
|
$group;
|
|
}
|
|
|
|
sub default_user {
|
|
return if WINFU;
|
|
|
|
my $uid = $>;
|
|
|
|
my $user = $ENV{APACHE_TEST_USER} || (getpwuid($uid) || "#$uid");
|
|
|
|
if ($user eq 'root') {
|
|
my $other = (getpwnam('nobody'))[0];
|
|
if ($other) {
|
|
$user = $other;
|
|
}
|
|
else {
|
|
die "cannot run tests as User root";
|
|
#XXX: prompt for another username
|
|
}
|
|
}
|
|
|
|
return $user;
|
|
}
|
|
|
|
sub default_serveradmin {
|
|
my $vars = shift->{vars};
|
|
join '@', ($vars->{user} || 'unknown'), $vars->{servername};
|
|
}
|
|
|
|
sub default_apxs {
|
|
my $self = shift;
|
|
|
|
return $self->{vars}->{apxs} if $self->{vars}->{apxs};
|
|
|
|
if (my $build_config = $self->modperl_build_config()) {
|
|
return $build_config->{MP_APXS};
|
|
}
|
|
|
|
if ($ENV{APACHE_TEST_APXS}) {
|
|
return $ENV{APACHE_TEST_APXS};
|
|
}
|
|
|
|
# look in PATH as a last resort
|
|
if (my $apxs = which('apxs')) {
|
|
return $apxs;
|
|
} elsif ($apxs = which('apxs2')) {
|
|
return $apxs;
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
sub default_httpd {
|
|
my $self = shift;
|
|
|
|
my $vars = $self->{vars};
|
|
|
|
if (my $build_config = $self->modperl_build_config()) {
|
|
if (my $p = $build_config->{MP_AP_PREFIX}) {
|
|
for my $bindir (qw(bin sbin)) {
|
|
my $httpd = catfile $p, $bindir, $vars->{target};
|
|
return $httpd if -e $httpd;
|
|
# The executable on Win32 in Apache/2.2 is httpd.exe,
|
|
# so try that if Apache.exe doesn't exist
|
|
if (WIN32) {
|
|
$httpd = catfile $p, $bindir, 'httpd.EXE';
|
|
if (-e $httpd) {
|
|
$vars->{target} = 'httpd.EXE';
|
|
return $httpd;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
if ($ENV{APACHE_TEST_HTTPD}) {
|
|
return $ENV{APACHE_TEST_HTTPD};
|
|
}
|
|
|
|
# look in PATH as a last resort
|
|
if (my $httpd = which('httpd')) {
|
|
return $httpd;
|
|
} elsif ($httpd = which('httpd2')) {
|
|
return $httpd;
|
|
} elsif ($httpd = which('apache')) {
|
|
return $httpd;
|
|
} elsif ($httpd = which('apache2')) {
|
|
return $httpd;
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
my $localhost;
|
|
|
|
sub default_localhost {
|
|
my $localhost_addr = pack('C4', 127, 0, 0, 1);
|
|
gethostbyaddr($localhost_addr, Socket::AF_INET()) || 'localhost';
|
|
}
|
|
|
|
sub default_servername {
|
|
my $self = shift;
|
|
$localhost ||= $self->default_localhost;
|
|
die "Can't figure out the default localhost's server name"
|
|
unless $localhost;
|
|
}
|
|
|
|
# memoize the selected value (so we make sure that the same port is used
|
|
# via select). The problem is that select_first_port() is called 3 times after
|
|
# -clean, and it's possible that a lower port will get released
|
|
# between calls, leading to various places in the test suite getting a
|
|
# different base port selection.
|
|
#
|
|
# XXX: There is still a problem if two t/TEST's configure at the same
|
|
# time, so they both see the same port free, but only the first one to
|
|
# bind() will actually get the port. So there is a need in another
|
|
# check and reconfiguration just before the server starts.
|
|
#
|
|
my $port_memoized;
|
|
sub select_first_port {
|
|
my $self = shift;
|
|
|
|
my $port ||= $port_memoized || $ENV{APACHE_TEST_PORT}
|
|
|| $self->{vars}{port} || DEFAULT_PORT;
|
|
|
|
# memoize
|
|
$port_memoized = $port;
|
|
|
|
return $port unless $port eq 'select';
|
|
|
|
# port select mode: try to find another available port, take into
|
|
# account that each instance of the test suite may use more than
|
|
# one port for virtual hosts, therefore try to check ports in big
|
|
# steps (20?).
|
|
my $step = 20;
|
|
my $tries = 20;
|
|
$port = DEFAULT_PORT;
|
|
until (Apache::TestServer->port_available($port)) {
|
|
unless (--$tries) {
|
|
error "no ports available";
|
|
error "tried ports @{[DEFAULT_PORT]} - $port in $step increments";
|
|
return 0;
|
|
}
|
|
$port += $step;
|
|
}
|
|
|
|
info "the default base port is used, using base port $port instead"
|
|
unless $port == DEFAULT_PORT;
|
|
|
|
# memoize
|
|
$port_memoized = $port;
|
|
|
|
return $port;
|
|
}
|
|
|
|
my $remote_addr;
|
|
|
|
sub our_remote_addr {
|
|
my $self = shift;
|
|
my $name = $self->default_servername;
|
|
my $iaddr = (gethostbyname($name))[-1];
|
|
unless (defined $iaddr) {
|
|
error "Can't resolve host: '$name' (check /etc/hosts)";
|
|
exit 1;
|
|
}
|
|
$remote_addr ||= Socket::inet_ntoa($iaddr);
|
|
}
|
|
|
|
sub default_loopback {
|
|
'127.0.0.1';
|
|
}
|
|
|
|
sub port {
|
|
my($self, $module) = @_;
|
|
|
|
unless ($module) {
|
|
my $vars = $self->{vars};
|
|
return $self->select_first_port() unless $vars->{scheme} eq 'https';
|
|
$module = $vars->{ssl_module_name};
|
|
}
|
|
return $self->{vhosts}->{$module}->{port};
|
|
}
|
|
|
|
sub hostport {
|
|
my $self = shift;
|
|
my $vars = shift || $self->{vars};
|
|
my $module = shift || '';
|
|
|
|
my $name = $vars->{servername};
|
|
|
|
join ':', $name , $self->port($module || '');
|
|
}
|
|
|
|
#look for mod_foo.so
|
|
sub find_apache_module {
|
|
my($self, $module) = @_;
|
|
|
|
die "find_apache_module: module name argument is required"
|
|
unless $module;
|
|
|
|
my $vars = $self->{vars};
|
|
my $sroot = $vars->{serverroot};
|
|
|
|
my @trys = grep { $_ }
|
|
($vars->{src_dir},
|
|
$self->apxs('LIBEXECDIR'),
|
|
catfile($sroot, 'modules'),
|
|
catfile($sroot, 'libexec'));
|
|
|
|
for (@trys) {
|
|
my $file = catfile $_, $module;
|
|
if (-e $file) {
|
|
debug "found $module => $file";
|
|
return $file;
|
|
}
|
|
}
|
|
|
|
# if the module wasn't found try to lookup in the list of modules
|
|
# inherited from the system-wide httpd.conf
|
|
my $name = $module;
|
|
$name =~ s/\.s[ol]$/.c/; #mod_info.so => mod_info.c
|
|
$name =~ s/^lib/mod_/; #libphp4.so => mod_php4.c
|
|
return $self->{modules}->{$name} if $self->{modules}->{$name};
|
|
|
|
}
|
|
|
|
#generate files and directories
|
|
|
|
my %warn_style = (
|
|
html => sub { "<!-- @_ -->" },
|
|
c => sub { "/* @_ */" },
|
|
php => sub { "<?php /* \n@_ \n*/ ?>" },
|
|
default => sub { join '', grep {s/^/\# /gm} @_ },
|
|
);
|
|
|
|
my %file_ext = (
|
|
map({$_ => 'html'} qw(htm html)),
|
|
map({$_ => 'c' } qw(c h)),
|
|
map({$_ => 'php' } qw(php)),
|
|
);
|
|
|
|
# return the passed file's extension or '' if there is no one
|
|
# note: that '/foo/bar.conf.in' returns an extension: 'conf.in';
|
|
# note: a hidden file .foo will be recognized as an extension 'foo'
|
|
sub filename_ext {
|
|
my ($self, $filename) = @_;
|
|
my $ext = (File::Basename::fileparse($filename, '\..*'))[2] || '';
|
|
$ext =~ s/^\.(.*)/lc $1/e;
|
|
$ext;
|
|
}
|
|
|
|
sub warn_style_sub_ref {
|
|
my ($self, $filename) = @_;
|
|
my $ext = $self->filename_ext($filename);
|
|
return $warn_style{ $file_ext{$ext} || 'default' };
|
|
}
|
|
|
|
sub genwarning {
|
|
my($self, $filename, $from_filename) = @_;
|
|
return unless $filename;
|
|
my $time = scalar localtime;
|
|
my $warning = "WARNING: this file is generated";
|
|
$warning .= " (from $from_filename)" if defined $from_filename;
|
|
$warning .= ", do not edit\n";
|
|
$warning .= "generated on $time\n";
|
|
$warning .= calls_trace();
|
|
return $self->warn_style_sub_ref($filename)->($warning);
|
|
}
|
|
|
|
sub calls_trace {
|
|
my $frame = 1;
|
|
my $trace = '';
|
|
|
|
while (1) {
|
|
my($package, $filename, $line) = caller($frame);
|
|
last unless $filename;
|
|
$trace .= sprintf "%02d: %s:%d\n", $frame, $filename, $line;
|
|
$frame++;
|
|
}
|
|
|
|
return $trace;
|
|
}
|
|
|
|
sub clean_add_file {
|
|
my($self, $file) = @_;
|
|
|
|
$self->{clean}->{files}->{ rel2abs($file) } = 1;
|
|
}
|
|
|
|
sub clean_add_path {
|
|
my($self, $path) = @_;
|
|
|
|
$path = rel2abs($path);
|
|
|
|
# remember which dirs were created and should be cleaned up
|
|
while (1) {
|
|
$self->{clean}->{dirs}->{$path} = 1;
|
|
$path = dirname $path;
|
|
last if -e $path;
|
|
}
|
|
}
|
|
|
|
sub genfile_trace {
|
|
my($self, $file, $from_file) = @_;
|
|
my $name = abs2rel $file, $self->{vars}->{t_dir};
|
|
my $msg = "generating $name";
|
|
$msg .= " from $from_file" if defined $from_file;
|
|
debug $msg;
|
|
}
|
|
|
|
sub genfile_warning {
|
|
my($self, $file, $from_file, $fh) = @_;
|
|
|
|
if (my $msg = $self->genwarning($file, $from_file)) {
|
|
print $fh $msg, "\n";
|
|
}
|
|
}
|
|
|
|
# $from_file == undef if there was no templates used
|
|
sub genfile {
|
|
my($self, $file, $from_file, $nowarning) = @_;
|
|
|
|
# create the parent dir if it doesn't exist yet
|
|
my $dir = dirname $file;
|
|
$self->makepath($dir);
|
|
|
|
$self->genfile_trace($file, $from_file);
|
|
|
|
my $fh = Symbol::gensym();
|
|
open $fh, ">$file" or die "open $file: $!";
|
|
|
|
$self->genfile_warning($file, $from_file, $fh) unless $nowarning;
|
|
|
|
$self->clean_add_file($file);
|
|
|
|
return $fh;
|
|
}
|
|
|
|
# gen + write file
|
|
sub writefile {
|
|
my($self, $file, $content, $nowarning) = @_;
|
|
|
|
my $fh = $self->genfile($file, undef, $nowarning);
|
|
|
|
print $fh $content if $content;
|
|
|
|
close $fh;
|
|
}
|
|
|
|
sub perlscript_header {
|
|
|
|
require FindBin;
|
|
|
|
my @dirs = ();
|
|
|
|
# mp2 needs its modper-2.0/lib before blib was created
|
|
if (IS_MOD_PERL_2_BUILD || $ENV{APACHE_TEST_LIVE_DEV}) {
|
|
# the live 'lib/' dir of the distro
|
|
# (e.g. modperl-2.0/ModPerl-Registry/lib)
|
|
my $dir = canonpath catdir $FindBin::Bin, "lib";
|
|
push @dirs, $dir if -d $dir;
|
|
|
|
# the live dir of the top dir if any (e.g. modperl-2.0/lib)
|
|
if (-e catfile($FindBin::Bin, "..", "Makefile.PL")) {
|
|
my $dir = canonpath catdir $FindBin::Bin, "..", "lib";
|
|
push @dirs, $dir if -d $dir;
|
|
}
|
|
}
|
|
|
|
for (qw(. ..)) {
|
|
my $dir = canonpath catdir $FindBin::Bin, $_ , "Apache-Test", "lib";
|
|
if (-d $dir) {
|
|
push @dirs, $dir;
|
|
last;
|
|
}
|
|
}
|
|
|
|
{
|
|
my $dir = canonpath catdir $FindBin::Bin, "t", "lib";
|
|
push @dirs, $dir if -d $dir;
|
|
}
|
|
|
|
push @dirs, canonpath $FindBin::Bin;
|
|
|
|
my $dirs = join("\n ", '', @dirs) . "\n";;
|
|
|
|
return <<"EOF";
|
|
|
|
use strict;
|
|
use warnings FATAL => 'all';
|
|
|
|
use lib qw($dirs);
|
|
|
|
EOF
|
|
}
|
|
|
|
# gen + write executable perl script file
|
|
sub write_perlscript {
|
|
my($self, $file, $content) = @_;
|
|
|
|
my $fh = $self->genfile($file, undef, 1);
|
|
|
|
my $shebang = make_shebang();
|
|
print $fh $shebang;
|
|
|
|
$self->genfile_warning($file, undef, $fh);
|
|
|
|
print $fh $content if $content;
|
|
|
|
close $fh;
|
|
chmod 0755, $file;
|
|
}
|
|
|
|
sub make_shebang {
|
|
# if perlpath is longer than 62 chars, some shells on certain
|
|
# platforms won't be able to run the shebang line, so when seeing
|
|
# a long perlpath use the eval workaround.
|
|
# see: http://en.wikipedia.org/wiki/Shebang
|
|
# http://homepages.cwi.nl/~aeb/std/shebang/
|
|
my $shebang = length $Config{perlpath} < 62
|
|
? "#!$Config{perlpath}\n"
|
|
: <<EOI;
|
|
$Config{'startperl'}
|
|
eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
|
|
if \$running_under_some_shell;
|
|
EOI
|
|
|
|
return $shebang;
|
|
}
|
|
|
|
sub cpfile {
|
|
my($self, $from, $to) = @_;
|
|
File::Copy::copy($from, $to);
|
|
$self->clean_add_file($to);
|
|
}
|
|
|
|
sub symlink {
|
|
my($self, $from, $to) = @_;
|
|
CORE::symlink($from, $to);
|
|
$self->clean_add_file($to);
|
|
}
|
|
|
|
sub gendir {
|
|
my($self, $dir) = @_;
|
|
$self->makepath($dir);
|
|
}
|
|
|
|
# returns a list of dirs successfully created
|
|
sub makepath {
|
|
my($self, $path) = @_;
|
|
|
|
return if !defined($path) || -e $path;
|
|
|
|
$self->clean_add_path($path);
|
|
|
|
return File::Path::mkpath($path, 0, 0755);
|
|
}
|
|
|
|
sub open_cmd {
|
|
my($self, $cmd) = @_;
|
|
# untaint some %ENV fields
|
|
local @ENV{ qw(IFS CDPATH ENV BASH_ENV) };
|
|
local $ENV{PATH} = untaint_path($ENV{PATH});
|
|
|
|
# launder for -T
|
|
$cmd = $1 if $cmd =~ /(.*)/;
|
|
|
|
my $handle = Symbol::gensym();
|
|
open $handle, "$cmd|" or die "$cmd failed: $!";
|
|
|
|
return $handle;
|
|
}
|
|
|
|
sub clean {
|
|
my $self = shift;
|
|
$self->{clean_level} = shift || 2; #2 == really clean, 1 == reconfigure
|
|
|
|
$self->new_test_server->clean;
|
|
$self->cmodules_clean;
|
|
$self->sslca_clean;
|
|
|
|
for (sort keys %{ $self->{clean}->{files} }) {
|
|
if (-e $_) {
|
|
debug "unlink $_";
|
|
unlink $_;
|
|
}
|
|
else {
|
|
debug "unlink $_: $!";
|
|
}
|
|
}
|
|
|
|
# if /foo comes before /foo/bar, /foo will never be removed
|
|
# hence ensure that sub-dirs are always treated before a parent dir
|
|
for (reverse sort keys %{ $self->{clean}->{dirs} }) {
|
|
if (-d $_) {
|
|
my $dh = Symbol::gensym();
|
|
opendir($dh, $_);
|
|
my $notempty = grep { ! /^\.{1,2}$/ } readdir $dh;
|
|
closedir $dh;
|
|
next if $notempty;
|
|
debug "rmdir $_";
|
|
rmdir $_;
|
|
}
|
|
}
|
|
}
|
|
|
|
my %special_tokens = (
|
|
nextavailableport => sub { shift->server->select_next_port }
|
|
);
|
|
|
|
sub replace {
|
|
my $self = shift;
|
|
my $file = $Apache::TestConfig::File
|
|
? "in file $Apache::TestConfig::File" : '';
|
|
|
|
s[@(\w+)@]
|
|
[ my $key = lc $1;
|
|
if (my $callback = $special_tokens{$key}) {
|
|
$self->$callback;
|
|
}
|
|
elsif (exists $self->{vars}->{$key}) {
|
|
$self->{vars}->{$key};
|
|
}
|
|
else {
|
|
die "invalid token: \@$1\@ $file\n";
|
|
}
|
|
]ge;
|
|
}
|
|
|
|
#need to configure the vhost port for redirects and $ENV{SERVER_PORT}
|
|
#to have the correct values
|
|
my %servername_config = (
|
|
0 => sub {
|
|
my($name, $port) = @_;
|
|
[ServerName => ''], [Port => 0];
|
|
},
|
|
1 => sub {
|
|
my($name, $port) = @_;
|
|
[ServerName => $name], [Port => $port];
|
|
},
|
|
2 => sub {
|
|
my($name, $port) = @_;
|
|
[ServerName => "$name:$port"];
|
|
},
|
|
);
|
|
|
|
sub servername_config {
|
|
my $self = shift;
|
|
$self->server->version_of(\%servername_config)->(@_);
|
|
}
|
|
|
|
sub parse_vhost {
|
|
my($self, $line) = @_;
|
|
|
|
my($indent, $module, $namebased);
|
|
if ($line =~ /^(\s*)<VirtualHost\s+(?:_default_:|([^:]+):(?!:))?(.*?)\s*>\s*$/) {
|
|
$indent = $1 || "";
|
|
$namebased = $2 || "";
|
|
$module = $3;
|
|
}
|
|
else {
|
|
return undef;
|
|
}
|
|
|
|
my $vars = $self->{vars};
|
|
my $mods = $self->{modules};
|
|
my $have_module = "$module.c";
|
|
my $ssl_module = $vars->{ssl_module};
|
|
|
|
#if module ends with _ssl and it is not the module that implements ssl,
|
|
#then assume this module is a vhost with SSLEngine On (or similar)
|
|
#see mod_echo in extra.conf.in for example
|
|
if ($module =~ /^(mod_\w+)_ssl$/ and $have_module ne $ssl_module) {
|
|
$have_module = "$1.c"; #e.g. s/mod_echo_ssl.c/mod_echo.c/
|
|
return undef unless $mods->{$ssl_module};
|
|
}
|
|
|
|
#don't allocate a port if this module is not configured
|
|
#assumes the configuration is inside an <IfModule $have_module>
|
|
if ($module =~ /^mod_/ and not $mods->{$have_module}) {
|
|
return undef;
|
|
}
|
|
|
|
#allocate a port and configure this module into $self->{vhosts}
|
|
my $port = $self->new_vhost($module, $namebased);
|
|
|
|
#extra config that should go *inside* the <VirtualHost ...>
|
|
my @in_config = $self->servername_config($namebased
|
|
? $namebased
|
|
: $vars->{servername},
|
|
$port);
|
|
|
|
my @out_config = ();
|
|
if ($self->{vhosts}->{$module}->{namebased} < 2) {
|
|
#extra config that should go *outside* the <VirtualHost ...>
|
|
@out_config = ([Listen => '0.0.0.0:' . $port]);
|
|
|
|
if ($self->{vhosts}->{$module}->{namebased}) {
|
|
push @out_config => ["<IfVersion < 2.3.11>\n".
|
|
"${indent}${indent}NameVirtualHost"
|
|
=> "*:$port\n${indent}</IfVersion>"];
|
|
}
|
|
}
|
|
|
|
$self->{vars}->{$module . '_port'} = $port;
|
|
|
|
#there are two ways of building a vhost
|
|
#first is when we parse test .pm and .c files
|
|
#second is when we scan *.conf.in
|
|
my $form_postamble = sub {
|
|
my $indent = shift;
|
|
for my $pair (@_) {
|
|
$self->postamble("$indent@$pair");
|
|
}
|
|
};
|
|
|
|
my $form_string = sub {
|
|
my $indent = shift;
|
|
join "\n", map { "$indent@$_\n" } @_;
|
|
};
|
|
|
|
my $double_indent = $indent ? $indent x 2 : ' ' x 4;
|
|
return {
|
|
port => $port,
|
|
#used when parsing .pm and .c test modules
|
|
in_postamble => sub { $form_postamble->($double_indent, @in_config) },
|
|
out_postamble => sub { $form_postamble->($indent, @out_config) },
|
|
#used when parsing *.conf.in files
|
|
in_string => $form_string->($double_indent, @in_config),
|
|
out_string => $form_string->($indent, @out_config),
|
|
line => "$indent<VirtualHost " . ($namebased ? '*' : '_default_') .
|
|
":$port>",
|
|
};
|
|
}
|
|
|
|
sub find_and_load_module {
|
|
my ($self, $name) = @_;
|
|
my $mod_path = $self->find_apache_module($name) or return;
|
|
my ($sym) = $name =~ m/mod_(\w+)\./;
|
|
|
|
if ($mod_path && -e $mod_path) {
|
|
$self->preamble(IfModule => "!mod_$sym.c",
|
|
qq{LoadModule ${sym}_module "$mod_path"\n});
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
sub replace_vhost_modules {
|
|
my $self = shift;
|
|
|
|
if (my $cfg = $self->parse_vhost($_)) {
|
|
$_ = '';
|
|
for my $key (qw(out_string line in_string)) {
|
|
next unless $cfg->{$key};
|
|
$_ .= "$cfg->{$key}\n";
|
|
}
|
|
}
|
|
}
|
|
|
|
sub replace_vars {
|
|
my($self, $in, $out) = @_;
|
|
|
|
local $_;
|
|
while (<$in>) {
|
|
$self->replace;
|
|
$self->replace_vhost_modules;
|
|
print $out $_;
|
|
}
|
|
}
|
|
|
|
sub index_html_template {
|
|
my $self = shift;
|
|
return "welcome to $self->{server}->{name}\n";
|
|
}
|
|
|
|
sub generate_index_html {
|
|
my $self = shift;
|
|
my $dir = $self->{vars}->{documentroot};
|
|
$self->gendir($dir);
|
|
my $file = catfile $dir, 'index.html';
|
|
return if -e $file;
|
|
my $fh = $self->genfile($file);
|
|
print $fh $self->index_html_template;
|
|
}
|
|
|
|
sub types_config_template {
|
|
return <<EOF;
|
|
text/html html htm
|
|
image/gif gif
|
|
image/jpeg jpeg jpg jpe
|
|
image/png png
|
|
text/plain asc txt
|
|
EOF
|
|
}
|
|
|
|
sub generate_types_config {
|
|
my $self = shift;
|
|
|
|
# handle the case when mod_mime is built as a shared object
|
|
# but wasn't included in the system-wide httpd.conf
|
|
$self->find_and_load_module('mod_mime.so');
|
|
|
|
unless ($self->{inherit_config}->{TypesConfig}) {
|
|
my $types = catfile $self->{vars}->{t_conf}, 'mime.types';
|
|
unless (-e $types) {
|
|
my $fh = $self->genfile($types);
|
|
print $fh $self->types_config_template;
|
|
close $fh;
|
|
}
|
|
$self->postamble(<<EOI);
|
|
<IfModule mod_mime.c>
|
|
TypesConfig "$types"
|
|
</IfModule>
|
|
EOI
|
|
}
|
|
}
|
|
|
|
# various dup bugs in older perl and perlio in perl < 5.8.4 need a
|
|
# workaround to explicitly rewind the dupped DATA fh before using it
|
|
my $DATA_pos = tell DATA;
|
|
sub httpd_conf_template {
|
|
my($self, $try) = @_;
|
|
|
|
my $in = Symbol::gensym();
|
|
if (open $in, $try) {
|
|
return $in;
|
|
}
|
|
else {
|
|
my $dup = Symbol::gensym();
|
|
open $dup, "<&DATA" or die "Can't dup DATA: $!";
|
|
seek $dup, $DATA_pos, 0; # rewind to the beginning
|
|
return $dup; # so we don't close DATA
|
|
}
|
|
}
|
|
|
|
#certain variables may not be available until certain config files
|
|
#are generated. for example, we don't know the ssl port until ssl.conf.in
|
|
#is parsed. ssl port is needed for proxyssl testing
|
|
|
|
sub check_vars {
|
|
my $self = shift;
|
|
my $vars = $self->{vars};
|
|
|
|
unless ($vars->{proxyssl_url}) {
|
|
my $ssl = $self->{vhosts}->{ $vars->{ssl_module_name} };
|
|
if ($ssl) {
|
|
$vars->{proxyssl_url} ||= $ssl->{hostport};
|
|
}
|
|
|
|
if ($vars->{proxyssl_url}) {
|
|
unless ($vars->{maxclients_preset}) {
|
|
$vars->{minclients}++;
|
|
$vars->{maxclients}++;
|
|
$vars->{maxspare}++;
|
|
$vars->{startserversthreadedmpm} ++;
|
|
$vars->{minclientsthreadedmpm} += $vars->{threadsperchild};
|
|
$vars->{maxclientsthreadedmpm} += $vars->{threadsperchild};
|
|
$vars->{maxsparethreadedmpm} += $vars->{threadsperchild};
|
|
#In addition allow for some backend processes
|
|
#in keep-alive state. For threaded MPMs we
|
|
#already should be fine.
|
|
$vars->{maxclients} += 3;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
sub extra_conf_files_needing_update {
|
|
my $self = shift;
|
|
|
|
my @need_update = ();
|
|
finddepth(sub {
|
|
return unless /\.in$/;
|
|
(my $generated = $File::Find::name) =~ s/\.in$//;
|
|
push @need_update, $generated
|
|
unless -e $generated && -M $generated < -M $File::Find::name;
|
|
}, $self->{vars}->{t_conf});
|
|
|
|
return @need_update;
|
|
}
|
|
|
|
sub generate_extra_conf {
|
|
my $self = shift;
|
|
|
|
my(@extra_conf, @conf_in, @conf_files);
|
|
|
|
finddepth(sub {
|
|
return unless /\.in$/;
|
|
push @conf_in, catdir $File::Find::dir, $_;
|
|
}, $self->{vars}->{t_conf});
|
|
|
|
#make ssl port always be 8530 when available
|
|
for my $file (@conf_in) {
|
|
if (basename($file) =~ /^ssl/) {
|
|
unshift @conf_files, $file;
|
|
}
|
|
else {
|
|
push @conf_files, $file;
|
|
}
|
|
}
|
|
|
|
for my $file (@conf_files) {
|
|
(my $generated = $file) =~ s/\.in$//;
|
|
debug "Will 'Include' $generated config file";
|
|
push @extra_conf, $generated;
|
|
}
|
|
|
|
# regenerate .conf files
|
|
for my $file (@conf_files) {
|
|
local $Apache::TestConfig::File = $file;
|
|
|
|
my $in = Symbol::gensym();
|
|
open($in, $file) or next;
|
|
|
|
(my $generated = $file) =~ s/\.in$//;
|
|
my $out = $self->genfile($generated, $file);
|
|
$self->replace_vars($in, $out);
|
|
|
|
close $in;
|
|
close $out;
|
|
|
|
$self->check_vars;
|
|
}
|
|
|
|
#we changed order to give ssl the first port after DEFAULT_PORT
|
|
#but we want extra.conf Included first so vhosts inherit base config
|
|
#such as LimitRequest*
|
|
return [ sort @extra_conf ];
|
|
}
|
|
|
|
sub sslca_can {
|
|
my($self, $check) = @_;
|
|
|
|
my $vars = $self->{vars};
|
|
return 0 unless $self->{modules}->{ $vars->{ssl_module} };
|
|
return 0 unless -d "$vars->{t_conf}/ssl";
|
|
|
|
require Apache::TestSSLCA;
|
|
|
|
if ($check) {
|
|
my $openssl = Apache::TestSSLCA::openssl();
|
|
if (which($openssl)) {
|
|
return 1;
|
|
}
|
|
|
|
error "cannot locate '$openssl' program required to generate SSL CA";
|
|
exit(1);
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
sub sslca_generate {
|
|
my $self = shift;
|
|
|
|
my $ca = $self->{vars}->{sslca};
|
|
return if $ca and -d $ca; #t/conf/ssl/ca
|
|
|
|
return unless $self->sslca_can(1);
|
|
|
|
Apache::TestSSLCA::generate($self);
|
|
}
|
|
|
|
sub sslca_clean {
|
|
my $self = shift;
|
|
|
|
# XXX: httpd config is required, for now just skip ssl clean if
|
|
# there is none. should probably add some flag which will tell us
|
|
# when httpd_config was already run
|
|
return unless $self->{vars}->{httpd} && $self->{vars}->{ssl_module};
|
|
|
|
return unless $self->sslca_can;
|
|
|
|
Apache::TestSSLCA::clean($self);
|
|
}
|
|
|
|
#XXX: just a quick hack to support t/TEST -ssl
|
|
#outside of httpd-test/perl-framework
|
|
sub generate_ssl_conf {
|
|
my $self = shift;
|
|
my $vars = $self->{vars};
|
|
my $conf = "$vars->{t_conf}/ssl";
|
|
my $httpd_test_ssl = "../httpd-test/perl-framework/t/conf/ssl";
|
|
my $ssl_conf = "$vars->{top_dir}/$httpd_test_ssl";
|
|
|
|
if (-d $ssl_conf and not -d $conf) {
|
|
$self->gendir($conf);
|
|
for (qw(ssl.conf.in)) {
|
|
$self->cpfile("$ssl_conf/$_", "$conf/$_");
|
|
}
|
|
for (qw(certs keys crl)) {
|
|
$self->symlink("$ssl_conf/$_", "$conf/$_");
|
|
}
|
|
}
|
|
}
|
|
|
|
sub find_in_inc {
|
|
my($self, $dir) = @_;
|
|
for my $path (@INC) {
|
|
my $location = "$path/$dir";
|
|
return $location if -d $location;
|
|
}
|
|
return "";
|
|
}
|
|
|
|
sub prepare_t_conf {
|
|
my $self = shift;
|
|
$self->gendir($self->{vars}->{t_conf});
|
|
}
|
|
|
|
my %aliases = (
|
|
"perl-pod" => "perlpod",
|
|
"binary-httpd" => "httpd",
|
|
"binary-perl" => "perl",
|
|
);
|
|
sub generate_httpd_conf {
|
|
my $self = shift;
|
|
my $vars = $self->{vars};
|
|
|
|
#generated httpd.conf depends on these things to exist
|
|
$self->generate_types_config;
|
|
$self->generate_index_html;
|
|
|
|
$self->gendir($vars->{t_logs});
|
|
$self->gendir($vars->{t_state});
|
|
$self->gendir($vars->{t_conf});
|
|
|
|
my @very_last_postamble = ();
|
|
if (my $extra_conf = $self->generate_extra_conf) {
|
|
for my $file (@$extra_conf) {
|
|
my $entry;
|
|
if ($file =~ /\.conf$/) {
|
|
next if $file =~ m|/httpd\.conf$|;
|
|
$entry = qq(Include "$file");
|
|
}
|
|
elsif ($file =~ /\.pl$/) {
|
|
$entry = qq(<IfModule mod_perl.c>\n PerlRequire "$file"\n</IfModule>\n);
|
|
}
|
|
else {
|
|
next;
|
|
}
|
|
|
|
# put the .last includes very last
|
|
if ($file =~ /\.last\.(conf|pl)$/) {
|
|
push @very_last_postamble, $entry;
|
|
}
|
|
else {
|
|
$self->postamble($entry);
|
|
}
|
|
|
|
}
|
|
}
|
|
|
|
$self->configure_proxy;
|
|
|
|
my $conf_file = $vars->{t_conf_file};
|
|
my $conf_file_in = join '.', $conf_file, 'in';
|
|
|
|
my $in = $self->httpd_conf_template($conf_file_in);
|
|
|
|
my $out = $self->genfile($conf_file);
|
|
|
|
$self->find_and_load_module('mod_alias.so');
|
|
|
|
$self->preamble_run($out);
|
|
|
|
for my $name (qw(user group)) { #win32
|
|
if ($vars->{$name}) {
|
|
print $out qq[\u$name "$vars->{$name}"\n];
|
|
}
|
|
}
|
|
|
|
#2.0: ServerName $ServerName:$Port
|
|
#1.3: ServerName $ServerName
|
|
# Port $Port
|
|
my @name_cfg = $self->servername_config($vars->{servername},
|
|
$vars->{port});
|
|
for my $pair (@name_cfg) {
|
|
print $out "@$pair\n";
|
|
}
|
|
|
|
$self->replace_vars($in, $out);
|
|
|
|
# handle the case when mod_alias is built as a shared object
|
|
# but wasn't included in the system-wide httpd.conf
|
|
|
|
print $out "<IfModule mod_alias.c>\n";
|
|
for (sort keys %aliases) {
|
|
next unless $vars->{$aliases{$_}};
|
|
print $out " Alias /getfiles-$_ $vars->{$aliases{$_}}\n";
|
|
}
|
|
print $out "</IfModule>\n";
|
|
|
|
print $out "\n";
|
|
|
|
$self->postamble_run($out);
|
|
|
|
print $out join "\n", @very_last_postamble;
|
|
|
|
close $in;
|
|
close $out or die "close $conf_file: $!";
|
|
}
|
|
|
|
sub need_reconfiguration {
|
|
my($self, $conf_opts) = @_;
|
|
my @reasons = ();
|
|
my $vars = $self->{vars};
|
|
|
|
# if '-port select' we need to check from scratch which ports are
|
|
# available
|
|
if (my $port = $conf_opts->{port} || $Apache::TestConfig::Argv{port}) {
|
|
if ($port eq 'select') {
|
|
push @reasons, "'-port $port' requires reconfiguration";
|
|
}
|
|
}
|
|
|
|
my $exe = $vars->{apxs} || $vars->{httpd} || '';
|
|
# if httpd.conf is older than executable
|
|
push @reasons,
|
|
"$exe is newer than $vars->{t_conf_file}"
|
|
if -e $exe &&
|
|
-e $vars->{t_conf_file} &&
|
|
-M $exe < -M $vars->{t_conf_file};
|
|
|
|
# any .in files are newer than their derived versions?
|
|
if (my @files = $self->extra_conf_files_needing_update) {
|
|
# invalidate the vhosts cache, since a different port could be
|
|
# assigned on reparse
|
|
$self->{vhosts} = {};
|
|
for my $file (@files) {
|
|
push @reasons, "$file.in is newer than $file";
|
|
}
|
|
}
|
|
|
|
# if special env variables are used (since they can change any time)
|
|
# XXX: may be we could check whether they have changed since the
|
|
# last run and thus avoid the reconfiguration?
|
|
{
|
|
my $passenv = passenv();
|
|
if (my @env_vars = sort grep { $ENV{$_} } keys %$passenv) {
|
|
push @reasons, "environment variables (@env_vars) are set";
|
|
}
|
|
}
|
|
|
|
# if the generated config was created with a version of Apache-Test
|
|
# less than the current version
|
|
{
|
|
my $current = Apache::Test->VERSION;
|
|
my $config = $self->{apache_test_version};
|
|
|
|
if (! $config || $config < $current) {
|
|
push @reasons, "configuration generated with old Apache-Test";
|
|
}
|
|
}
|
|
|
|
return @reasons;
|
|
}
|
|
|
|
sub error_log {
|
|
my($self, $rel) = @_;
|
|
my $file = catfile $self->{vars}->{t_logs}, 'error_log';
|
|
my $rfile = abs2rel $file, $self->{vars}->{top_dir};
|
|
return wantarray ? ($file, $rfile) :
|
|
$rel ? $rfile : $file;
|
|
}
|
|
|
|
#utils
|
|
|
|
#For Win32 systems, stores the extensions used for executable files
|
|
#They may be . prefixed, so we will strip the leading periods.
|
|
|
|
my @path_ext = ();
|
|
|
|
if (WIN32) {
|
|
if ($ENV{PATHEXT}) {
|
|
push @path_ext, split ';', $ENV{PATHEXT};
|
|
for my $ext (@path_ext) {
|
|
$ext =~ s/^\.*(.+)$/$1/;
|
|
}
|
|
}
|
|
else {
|
|
#Win9X: doesn't have PATHEXT
|
|
push @path_ext, qw(com exe bat);
|
|
}
|
|
}
|
|
|
|
sub which {
|
|
my $program = shift;
|
|
|
|
return undef unless $program;
|
|
|
|
# No need to search PATH components
|
|
# if $program already contains a path
|
|
return $program if !OSX and !WINFU and
|
|
$program =~ /\// and -f $program and -x $program;
|
|
|
|
my @dirs = File::Spec->path();
|
|
|
|
require Config;
|
|
my $perl_bin = $Config::Config{bin} || '';
|
|
push @dirs, $perl_bin if $perl_bin and -d $perl_bin;
|
|
|
|
for my $base (map { catfile $_, $program } @dirs) {
|
|
if ($ENV{HOME} and not WIN32) {
|
|
# only works on Unix, but that's normal:
|
|
# on Win32 the shell doesn't have special treatment of '~'
|
|
$base =~ s/~/$ENV{HOME}/o;
|
|
}
|
|
|
|
return $base if -x $base && -f _;
|
|
|
|
if (WIN32) {
|
|
for my $ext (@path_ext) {
|
|
return "$base.$ext" if -x "$base.$ext" && -f _;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
sub apxs {
|
|
my($self, $q, $ok_fail) = @_;
|
|
return unless $self->{APXS};
|
|
my $val;
|
|
unless (exists $self->{_apxs}{$q}) {
|
|
local @ENV{ qw(IFS CDPATH ENV BASH_ENV) };
|
|
local $ENV{PATH} = untaint_path($ENV{PATH});
|
|
my $devnull = devnull();
|
|
my $apxs = shell_ready($self->{APXS});
|
|
$val = qx($apxs -q $q 2>$devnull);
|
|
chomp $val if defined $val; # apxs post-2.0.40 adds a new line
|
|
if ($val) {
|
|
$self->{_apxs}{$q} = $val;
|
|
}
|
|
unless ($val) {
|
|
if ($ok_fail) {
|
|
return "";
|
|
}
|
|
else {
|
|
warn "APXS ($self->{APXS}) query for $q failed\n";
|
|
return $val;
|
|
}
|
|
}
|
|
}
|
|
$self->{_apxs}{$q};
|
|
}
|
|
|
|
# return an untainted PATH
|
|
sub untaint_path {
|
|
my $path = shift;
|
|
return '' unless defined $path;
|
|
($path) = ( $path =~ /(.*)/ );
|
|
# win32 uses ';' for a path separator, assume others use ':'
|
|
my $sep = WIN32 ? ';' : ':';
|
|
# -T disallows relative and empty directories in the PATH
|
|
return join $sep, grep File::Spec->file_name_is_absolute($_),
|
|
grep length($_), split /$sep/, $path;
|
|
}
|
|
|
|
sub pop_dir {
|
|
my $dir = shift;
|
|
|
|
my @chunks = splitdir $dir;
|
|
while (my $remove = shift) {
|
|
pop @chunks if $chunks[-1] eq $remove;
|
|
}
|
|
|
|
catfile @chunks;
|
|
}
|
|
|
|
sub add_inc {
|
|
my $self = shift;
|
|
return if $ENV{MOD_PERL}; #already setup by mod_perl
|
|
require lib;
|
|
# make sure that Apache-Test/lib will be first in @INC,
|
|
# followed by modperl-2.0/lib (or some other project's lib/),
|
|
# followed by blib/ and finally system-wide libs.
|
|
my $top_dir = $self->{vars}->{top_dir};
|
|
my @dirs = map { catdir $top_dir, "blib", $_ } qw(lib arch);
|
|
|
|
my $apache_test_dir = catdir $top_dir, "Apache-Test";
|
|
unshift @dirs, $apache_test_dir if -d $apache_test_dir;
|
|
|
|
lib::->import(@dirs);
|
|
|
|
if ($ENV{APACHE_TEST_LIVE_DEV}) {
|
|
# add lib/ in a separate call to ensure that it'll end up on
|
|
# top of @INC
|
|
my $lib_dir = catdir $top_dir, "lib";
|
|
lib::->import($lib_dir) if -d $lib_dir;
|
|
}
|
|
|
|
#print join "\n", "add_inc", @INC, "";
|
|
}
|
|
|
|
#freeze/thaw so other processes can access config
|
|
|
|
sub thaw {
|
|
my $class = shift;
|
|
$class->new({thaw => 1, @_});
|
|
}
|
|
|
|
sub freeze {
|
|
require Data::Dumper;
|
|
local $Data::Dumper::Terse = 1;
|
|
my $data = Data::Dumper::Dumper(shift);
|
|
chomp $data;
|
|
$data;
|
|
}
|
|
|
|
sub sync_vars {
|
|
my $self = shift;
|
|
|
|
return if $self->{save}; #this is not a cached config
|
|
|
|
my $changed = 0;
|
|
my $thaw = $self->thaw;
|
|
my $tvars = $thaw->{vars};
|
|
my $svars = $self->{vars};
|
|
|
|
for my $key (@_) {
|
|
for my $v ($tvars, $svars) {
|
|
if (exists $v->{$key} and not defined $v->{$key}) {
|
|
$v->{$key} = ''; #rid undef
|
|
}
|
|
}
|
|
next if exists $tvars->{$key} and exists $svars->{$key} and
|
|
$tvars->{$key} eq $svars->{$key};
|
|
$tvars->{$key} = $svars->{$key};
|
|
$changed = 1;
|
|
}
|
|
|
|
return unless $changed;
|
|
|
|
$thaw->{save} = 1;
|
|
$thaw->save;
|
|
}
|
|
|
|
sub save {
|
|
my($self) = @_;
|
|
|
|
return unless $self->{save};
|
|
|
|
# add in the Apache-Test version for later comparisions
|
|
$self->{apache_test_version} = Apache::Test->VERSION;
|
|
|
|
my $name = 'apache_test_config';
|
|
my $file = catfile $self->{vars}->{t_conf}, "$name.pm";
|
|
my $fh = $self->genfile($file);
|
|
|
|
debug "saving config data to $name.pm";
|
|
|
|
(my $obj = $self->freeze) =~ s/^/ /;
|
|
|
|
print $fh <<EOF;
|
|
package $name;
|
|
|
|
sub new {
|
|
$obj;
|
|
}
|
|
|
|
1;
|
|
EOF
|
|
|
|
close $fh or die "failed to write $file: $!";
|
|
}
|
|
|
|
sub as_string {
|
|
my $cfg = '';
|
|
my $command = '';
|
|
|
|
# httpd opts
|
|
my $test_config = Apache::TestConfig->new({thaw=>1});
|
|
# XXX: need to run httpd config to get the value of httpd
|
|
if (my $httpd = $test_config->{vars}->{httpd}) {
|
|
$httpd = shell_ready($httpd);
|
|
$command = "$httpd -V";
|
|
$cfg .= "\n*** $command\n";
|
|
$cfg .= qx{$command};
|
|
|
|
$cfg .= ldd_as_string($httpd);
|
|
}
|
|
else {
|
|
$cfg .= "\n\n*** The httpd binary was not found\n";
|
|
}
|
|
|
|
# perl opts
|
|
my $perl = shell_ready($^X);
|
|
$command = "$perl -V";
|
|
$cfg .= "\n\n*** $command\n";
|
|
$cfg .= qx{$command};
|
|
|
|
return $cfg;
|
|
}
|
|
|
|
sub ldd_as_string {
|
|
my $httpd = shift;
|
|
|
|
my $command;
|
|
if (OSX) {
|
|
my $otool = which('otool');
|
|
$command = "$otool -L $httpd" if $otool;
|
|
}
|
|
elsif (!WIN32) {
|
|
my $ldd = which('ldd');
|
|
$command = "$ldd $httpd" if $ldd;
|
|
}
|
|
|
|
my $cfg = '';
|
|
if ($command) {
|
|
$cfg .= "\n*** $command\n";
|
|
$cfg .= qx{$command};
|
|
}
|
|
|
|
return $cfg;
|
|
}
|
|
|
|
# make a string suitable for feed to shell calls (wrap in quotes and
|
|
# escape quotes)
|
|
sub shell_ready {
|
|
my $arg = shift;
|
|
$arg =~ s!\\?"!\\"!g;
|
|
return qq["$arg"];
|
|
}
|
|
|
|
|
|
1;
|
|
|
|
=head1 NAME
|
|
|
|
Apache::TestConfig -- Test Configuration setup module
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use Apache::TestConfig;
|
|
|
|
my $cfg = Apache::TestConfig->new(%args)
|
|
my $fh = $cfg->genfile($file);
|
|
$cfg->writefile($file, $content);
|
|
$cfg->gendir($dir);
|
|
...
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
C<Apache::TestConfig> is used in creating the C<Apache::Test>
|
|
configuration files.
|
|
|
|
=head1 FUNCTIONS
|
|
|
|
=over
|
|
|
|
=item genwarning()
|
|
|
|
my $warn = $cfg->genwarning($filename)
|
|
|
|
genwarning() returns a warning string as a comment, saying that the
|
|
file was autogenerated and that it's not a good idea to modify this
|
|
file. After the warning a perl trace of calls to this this function is
|
|
appended. This trace is useful for finding what code has created the
|
|
file.
|
|
|
|
my $warn = $cfg->genwarning($filename, $from_filename)
|
|
|
|
If C<$from_filename> is specified it'll be used in the warning to tell
|
|
which file it was generated from.
|
|
|
|
genwarning() automatically recognizes the comment type based on the
|
|
file extension. If the extension is not recognized, the default C<#>
|
|
style is used.
|
|
|
|
Currently it support C<E<lt>!-- --E<gt>>, C</* ... */> and C<#>
|
|
styles.
|
|
|
|
=item genfile()
|
|
|
|
my $fh = $cfg->genfile($file);
|
|
|
|
genfile() creates a new file C<$file> for writing and returns a file
|
|
handle.
|
|
|
|
If parent directories of C<$file> don't exist they will be
|
|
automagically created.
|
|
|
|
The file C<$file> and any created parent directories (if found empty)
|
|
will be automatically removed on cleanup.
|
|
|
|
A comment with a warning and calls trace is added to the top of this
|
|
file. See genwarning() for more info about this comment.
|
|
|
|
my $fh = $cfg->genfile($file, $from_file);
|
|
|
|
If C<$from_filename> is specified it'll be used in the warning to tell
|
|
which file it was generated from.
|
|
|
|
my $fh = $cfg->genfile($file, $from_file, $nowarning);
|
|
|
|
If C<$nowarning> is true, the warning won't be added. If using this
|
|
optional argument and there is no C<$from_file> you must pass undef as
|
|
in:
|
|
|
|
my $fh = $cfg->genfile($file, undef, $nowarning);
|
|
|
|
|
|
=item writefile()
|
|
|
|
$cfg->writefile($file, $content, [$nowarning]);
|
|
|
|
writefile() creates a new file C<$file> with the content of
|
|
C<$content>.
|
|
|
|
A comment with a warning and calls trace is added to the top of this
|
|
file unless C<$nowarnings> is passed and set to a true value. See
|
|
genwarning() for more info about this comment.
|
|
|
|
If parent directories of C<$file> don't exist they will be
|
|
automagically created.
|
|
|
|
The file C<$file> and any created parent directories (if found empty)
|
|
will be automatically removed on cleanup.
|
|
|
|
=item write_perlscript()
|
|
|
|
$cfg->write_perlscript($filename, @lines);
|
|
|
|
Similar to writefile() but creates an executable Perl script with
|
|
correctly set shebang line.
|
|
|
|
=item gendir()
|
|
|
|
$cfg->gendir($dir);
|
|
|
|
gendir() creates a new directory C<$dir>.
|
|
|
|
If parent directories of C<$dir> don't exist they will be
|
|
automagically created.
|
|
|
|
The directory C<$dir> and any created parent directories will be
|
|
automatically removed on cleanup if found empty.
|
|
|
|
=back
|
|
|
|
=head1 Environment Variables
|
|
|
|
The following environment variables affect the configuration and the
|
|
run-time of the C<Apache::Test> framework:
|
|
|
|
=head2 APACHE_TEST_COLOR
|
|
|
|
To aid visual control over the configuration process and the run-time
|
|
phase, C<Apache::Test> uses coloured fonts when the environment
|
|
variable C<APACHE_TEST_COLOR> is set to a true value.
|
|
|
|
=head2 APACHE_TEST_LIVE_DEV
|
|
|
|
When using C<Apache::Test> during the project development phase, it's
|
|
often convenient to have the I<project/lib> (live) directory appearing
|
|
first in C<@INC> so any changes to the Perl modules, residing in it,
|
|
immediately affect the server, without a need to rerun C<make> to
|
|
update I<blib/lib>. When the environment variable
|
|
C<APACHE_TEST_LIVE_DEV> is set to a true value during the
|
|
configuration phase (C<t/TEST -config>, C<Apache::Test> will
|
|
automatically unshift the I<project/lib> directory into C<@INC>, via
|
|
the autogenerated I<t/conf/modperl_inc.pl> file.
|
|
|
|
|
|
=head1 Special Placeholders
|
|
|
|
When generating configuration files from the I<*.in> templates,
|
|
special placeholder variables get substituted. To embed a placeholder
|
|
use the C<@foo@> syntax. For example in I<extra.conf.in> you can
|
|
write:
|
|
|
|
Include @ServerRoot@/conf/myconfig.conf
|
|
|
|
When I<extra.conf> is generated, C<@ServerRoot@> will get replaced
|
|
with the location of the server root.
|
|
|
|
Placeholders are case-insensitive.
|
|
|
|
Available placeholders:
|
|
|
|
=head2 Configuration Options
|
|
|
|
All configuration variables that can be passed to C<t/TEST>, such as
|
|
C<MaxClients>, C<DocumentRoot>, C<ServerRoot>, etc. To see the
|
|
complete list run:
|
|
|
|
% t/TEST --help
|
|
|
|
and you will find them in the C<configuration options> sections.
|
|
|
|
=head2 NextAvailablePort
|
|
|
|
Every time this placeholder is encountered it'll be replaced with the
|
|
next available port. This is very useful if you need to allocate a
|
|
special port, but not hardcode it. Later when running:
|
|
|
|
% t/TEST -port=select
|
|
|
|
it's possible to run several concurrent test suites on the same
|
|
machine, w/o having port collisions.
|
|
|
|
=head1 AUTHOR
|
|
|
|
=head1 SEE ALSO
|
|
|
|
perl(1), Apache::Test(3)
|
|
|
|
=cut
|
|
|
|
|
|
__DATA__
|
|
Listen 0.0.0.0:@Port@
|
|
|
|
ServerRoot "@ServerRoot@"
|
|
DocumentRoot "@DocumentRoot@"
|
|
|
|
PidFile @t_pid_file@
|
|
ErrorLog @t_logs@/error_log
|
|
LogLevel debug
|
|
|
|
<IfModule mod_version.c>
|
|
<IfVersion > 2.4.1>
|
|
DefaultRunTimeDir "@t_logs@"
|
|
LogLevel trace8
|
|
</IfVersion>
|
|
<IfVersion > 2.4.34>
|
|
<IfDirective DefaultStateDir>
|
|
DefaultStateDir "@t_state@"
|
|
</IfDirective>
|
|
</IfVersion>
|
|
</IfModule>
|
|
|
|
<IfModule mod_log_config.c>
|
|
TransferLog @t_logs@/access_log
|
|
</IfModule>
|
|
|
|
<IfModule mod_cgid.c>
|
|
ScriptSock @t_logs@/cgisock
|
|
</IfModule>
|
|
|
|
ServerAdmin @ServerAdmin@
|
|
|
|
#needed for http/1.1 testing
|
|
KeepAlive On
|
|
|
|
HostnameLookups Off
|
|
|
|
<Directory />
|
|
Options FollowSymLinks
|
|
AllowOverride None
|
|
</Directory>
|
|
|
|
<IfModule @THREAD_MODULE@>
|
|
<IfModule mod_version.c>
|
|
<IfVersion < 2.3.4>
|
|
LockFile @t_logs@/accept.lock
|
|
</IfVersion>
|
|
</IfModule>
|
|
StartServers @StartServersThreadedMPM@
|
|
MinSpareThreads @ThreadsPerChild@
|
|
MaxSpareThreads @MaxSpareThreadedMPM@
|
|
ThreadsPerChild @ThreadsPerChild@
|
|
MaxClients @MaxClientsThreadedMPM@
|
|
MaxRequestsPerChild 0
|
|
</IfModule>
|
|
|
|
<IfModule perchild.c>
|
|
<IfModule mod_version.c>
|
|
<IfVersion < 2.3.4>
|
|
LockFile @t_logs@/accept.lock
|
|
</IfVersion>
|
|
</IfModule>
|
|
NumServers 1
|
|
StartThreads @MinClients@
|
|
MinSpareThreads 1
|
|
MaxSpareThreads @MaxSpare@
|
|
MaxThreadsPerChild @MaxClients@
|
|
MaxRequestsPerChild 0
|
|
</IfModule>
|
|
|
|
<IfModule prefork.c>
|
|
<IfModule mod_version.c>
|
|
<IfVersion < 2.3.4>
|
|
LockFile @t_logs@/accept.lock
|
|
</IfVersion>
|
|
</IfModule>
|
|
StartServers @MinClients@
|
|
MinSpareServers 1
|
|
MaxSpareServers @MaxSpare@
|
|
MaxClients @MaxClients@
|
|
MaxRequestsPerChild 0
|
|
</IfModule>
|
|
|
|
<IfDefine APACHE1>
|
|
LockFile @t_logs@/accept.lock
|
|
StartServers @MinClients@
|
|
MinSpareServers 1
|
|
MaxSpareServers @MaxSpare@
|
|
MaxClients @MaxClients@
|
|
MaxRequestsPerChild 0
|
|
</IfDefine>
|
|
|
|
<IfModule mpm_winnt.c>
|
|
ThreadsPerChild 50
|
|
MaxRequestsPerChild 0
|
|
</IfModule>
|
|
|
|
<Location /server-info>
|
|
SetHandler server-info
|
|
</Location>
|
|
|
|
<Location /server-status>
|
|
SetHandler server-status
|
|
</Location>
|
|
|