# 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::TestRun;
use strict;
use warnings FATAL => 'all';
use Apache::Test ();
use Apache::TestMM ();
use Apache::TestConfig ();
use Apache::TestConfigC ();
use Apache::TestRequest ();
use Apache::TestHarness ();
use Apache::TestTrace;
use Cwd;
use ExtUtils::MakeMaker;
use File::Find qw(finddepth);
use File::Path;
use File::Spec::Functions qw(catfile catdir canonpath);
use File::Basename qw(basename dirname);
use Getopt::Long qw(GetOptions);
use Config;
use constant IS_APACHE_TEST_BUILD => Apache::TestConfig::IS_APACHE_TEST_BUILD;
use constant STARTUP_TIMEOUT => 300; # secs (good for extreme debug cases)
use subs qw(exit_shell exit_perl);
my $orig_command;
my $orig_cwd;
my $orig_conf_opts;
my %core_files = ();
my @std_run = qw(start-httpd run-tests stop-httpd);
my @others = qw(verbose configure clean help ssl http11 bugreport
save no-httpd one-process);
my @flag_opts = (@std_run, @others);
my @string_opts = qw(order trace);
my @ostring_opts = qw(proxy ping);
my @debug_opts = qw(debug);
my @list_opts = qw(preamble postamble breakpoint);
my @hash_opts = qw(header);
my @help_opts = qw(clean help);
my @request_opts = qw(get post head);
my @exit_opts_no_need_httpd = (@help_opts);
my @exit_opts_need_httpd = (@debug_opts, qw(ping));
my %usage = (
'start-httpd' => 'start the test server',
'run-tests' => 'run the tests',
'order=mode' => 'run the tests in one of the modes: ' .
'(repeat|random|SEED)',
'stop-httpd' => 'stop the test server',
'no-httpd' => 'run the tests without configuring or starting httpd',
'verbose[=1]' => 'verbose output',
'configure' => 'force regeneration of httpd.conf ' .
' (tests will not be run)',
'clean' => 'remove all generated test files',
'help' => 'display this message',
'bugreport' => 'print the hint how to report problems',
'preamble' => 'config to add at the beginning of httpd.conf',
'postamble' => 'config to add at the end of httpd.conf',
'ping[=block]' => 'test if server is running or port in use',
'debug[=name]' => 'start server under debugger name (gdb, ddd, etc.)',
'breakpoint=bp' => 'set breakpoints (multiply bp can be set)',
'header' => "add headers to (" .
join('|', @request_opts) . ") request",
'http11' => 'run all tests with HTTP/1.1 (keep alive) requests',
'ssl' => 'run tests through ssl',
'proxy' => 'proxy requests (default proxy is localhost)',
'trace=T' => 'change tracing default to: warning, notice, ' .
'info, debug, ...',
'one-process' => 'run the server in single process mode',
(map { $_, "\U$_\E url" } @request_opts),
);
sub fixup {
#make sure we use an absolute path to perl
#else Test::Harness uses the perl in our PATH
#which might not be the one we want
$^X = $Config{perlpath} unless -e $^X;
}
# if the test suite was aborted because of a user-error we don't want
# to call the bugreport and invite users to submit a bug report -
# after all it's a user error. but we still want the program to fail,
# so raise this flag in such a case.
my $user_error = 0;
sub user_error {
my $self = shift;
$user_error = shift if @_;
$user_error;
}
sub new {
my $class = shift;
my $self = bless {
tests => [],
@_,
}, $class;
$self->fixup;
$self;
}
#split arguments into test files/dirs and options
#take extra care if -e, the file matches /\.t$/
# if -d, the dir contains .t files
#so we dont slurp arguments that are not tests, example:
# httpd $HOME/apache-2.0/bin/httpd
sub split_test_args {
my($self) = @_;
my(@tests);
my $top_dir = $self->{test_config}->{vars}->{top_dir};
my $t_dir = $self->{test_config}->{vars}->{t_dir};
my $argv = $self->{argv};
my @leftovers = ();
for (@$argv) {
my $arg = $_;
# need the t/ (or t\) for stat-ing, but don't want to include
# it in test output
$arg =~ s@^(?:\.[\\/])?t[\\/]@@;
my $file = catfile $t_dir, $arg;
if (-d $file and $_ ne '/') {
my @files = <$file/*.t>;
my $remove = catfile $top_dir, "";
if (@files) {
push @tests, map { s,^\Q$remove,,; $_ } @files;
next;
}
}
else {
if ($file =~ /\.t$/ and -e $file) {
push @tests, "t/$arg";
next;
}
elsif (-e "$file.t") {
push @tests, "t/$arg.t";
next;
}
elsif (/^[\d.]+$/) {
my @t = $_;
#support range of subtests: t/TEST t/foo/bar 60..65
if (/^(\d+)\.\.(\d+)$/) {
@t = $1..$2;
}
push @{ $self->{subtests} }, @t;
next;
}
}
push @leftovers, $_;
}
$self->{tests} = [ map { canonpath($_) } @tests ];
$self->{argv} = \@leftovers;
}
sub die_on_invalid_args {
my($self) = @_;
# at this stage $self->{argv} should be empty
my @invalid_argv = @{ $self->{argv} };
if (@invalid_argv) {
error "unknown opts or test names: @invalid_argv\n" .
"-help will list options\n";
exit_perl 0;
}
}
sub passenv {
my $passenv = Apache::TestConfig->passenv;
for (keys %$passenv) {
return 1 if $ENV{$_};
}
0;
}
sub getopts {
my($self, $argv) = @_;
local *ARGV = $argv;
my(%opts, %vopts, %conf_opts);
# a workaround to support -verbose and -verbose=0|1
# $Getopt::Long::VERSION > 2.26 can use the "verbose:1" rule
# but we have to support older versions as well
@ARGV = grep defined,
map {/-verbose=(\d)/ ? ($1 ? '-verbose' : undef) : $_ } @ARGV;
# permute : optional values can come before the options
# pass_through : all unknown things are to be left in @ARGV
Getopt::Long::Configure(qw(pass_through permute));
# grab from @ARGV only the options that we expect
GetOptions(\%opts, @flag_opts, @help_opts,
(map "$_:s", @debug_opts, @request_opts, @ostring_opts),
(map "$_=s", @string_opts),
(map { ("$_=s", $vopts{$_} ||= []) } @list_opts),
(map { ("$_=s", $vopts{$_} ||= {}) } @hash_opts));
$opts{$_} = $vopts{$_} for keys %vopts;
# separate configuration options and test files/dirs
my $req_wanted_args = Apache::TestRequest::wanted_args();
my @argv = ();
my %req_args = ();
while (@ARGV) {
my $val = shift @ARGV;
if ($val =~ /^--?(.+)/) { # must have a leading - or --
my $key = lc $1;
# a known config option?
if (exists $Apache::TestConfig::Usage{$key}) {
$conf_opts{$key} = shift @ARGV;
next;
} # a TestRequest config option?
elsif (exists $req_wanted_args->{$key}) {
$req_args{$key} = shift @ARGV;
next;
}
}
# to be processed later
push @argv, $val;
}
# save the orig args (make a deep copy)
$orig_conf_opts = { %conf_opts };
# fixup the filepath options on win32 (spaces, short names, etc.)
if (Apache::TestConfig::WIN32) {
for my $key (keys %conf_opts) {
next unless Apache::TestConfig::conf_opt_is_a_filepath($key);
next unless -e $conf_opts{$key};
$conf_opts{$key} = Win32::GetShortPathName($conf_opts{$key});
}
}
$opts{req_args} = \%req_args;
# only test files/dirs if any at all are left in argv
$self->{argv} = \@argv;
# force regeneration of httpd.conf if commandline args want to
# modify it. configure_opts() has more checks to decide whether to
# reconfigure or not.
# XXX: $self->passenv() is already tested in need_reconfiguration()
$self->{reconfigure} = $opts{configure} ||
(grep { $opts{$_}->[0] } qw(preamble postamble)) ||
(grep { $Apache::TestConfig::Usage{$_} } keys %conf_opts ) ||
$self->passenv() || (! -e 't/conf/httpd.conf');
if (exists $opts{debug}) {
$opts{debugger} = $opts{debug};
$opts{debug} = 1;
}
if ($opts{trace}) {
my %levels = map {$_ => 1} @Apache::TestTrace::Levels;
if (exists $levels{ $opts{trace} }) {
$Apache::TestTrace::Level = $opts{trace};
# propogate the override for the server-side.
# -trace overrides any previous APACHE_TEST_TRACE_LEVEL settings
$ENV{APACHE_TEST_TRACE_LEVEL} = $opts{trace};
}
else {
error "unknown trace level: $opts{trace}",
"valid levels are: @Apache::TestTrace::Levels";
exit_perl 0;
}
}
# breakpoint automatically turns the debug mode on
if (@{ $opts{breakpoint} }) {
$opts{debug} ||= 1;
}
if ($self->{reconfigure}) {
$conf_opts{save} = 1;
delete $self->{reconfigure};
}
else {
$conf_opts{thaw} = 1;
}
#propagate some values
for (qw(verbose)) {
$conf_opts{$_} = $opts{$_};
}
$self->{opts} = \%opts;
$self->{conf_opts} = \%conf_opts;
}
sub default_run_opts {
my $self = shift;
my($opts, $tests) = ($self->{opts}, $self->{tests});
unless (grep { exists $opts->{$_} } @std_run, @request_opts) {
if (@$tests && $self->{server}->ping) {
# if certain tests are specified and server is running,
# dont restart
$opts->{'run-tests'} = 1;
}
else {
#default is start-server run-tests stop-server
$opts->{$_} = 1 for @std_run;
}
}
$opts->{'run-tests'} ||= @$tests;
}
my $parent_pid = $$;
sub is_parent { $$ == $parent_pid }
my $caught_sig_int = 0;
sub install_sighandlers {
my $self = shift;
my($server, $opts) = ($self->{server}, $self->{opts});
$SIG{__DIE__} = sub {
return unless $_[0] =~ /^Failed/i; #dont catch Test::ok failures
# _show_results() calls die() under a few conditions, such as
# when no tests are run or when tests fail. make sure the message
# is propagated back to the user.
print $_[0] if (caller(1))[3]||'' eq 'Test::Harness::_show_results';
$server->stop(1) if $opts->{'start-httpd'};
$server->failed_msg("error running tests");
exit_perl 0;
};
$SIG{INT} = sub {
if ($caught_sig_int++) {
warning "\ncaught SIGINT";
exit_perl 0;
}
warning "\nhalting tests";
$server->stop if $opts->{'start-httpd'};
exit_perl 0;
};
#try to make sure we scan for core no matter what happens
#must eval "" to "install" this END block, otherwise it will
#always run, a subclass might not want that
eval 'END {
return unless is_parent(); # because of fork
$self ||=
Apache::TestRun->new(test_config => Apache::TestConfig->thaw);
{
local $?; # preserve the exit status
eval {
$self->scan_core;
};
}
$self->try_bug_report();
}';
die "failed: $@" if $@;
}
sub try_bug_report {
my $self = shift;
if ($? && !$self->user_error &&
$self->{opts}->{bugreport} && $self->can('bug_report')) {
$self->bug_report;
}
}
#throw away cached config and start fresh
sub refresh {
my $self = shift;
$self->opt_clean(1);
$self->{conf_opts}->{save} = delete $self->{conf_opts}->{thaw} || 1;
$self->{test_config} = $self->new_test_config()->httpd_config;
$self->{test_config}->{server}->{run} = $self;
$self->{server} = $self->{test_config}->server;
}
sub configure_opts {
my $self = shift;
my $save = shift;
my $refreshed = 0;
my($test_config, $opts) = ($self->{test_config}, $self->{opts});
$test_config->{vars}->{scheme} =
$opts->{ssl} ? 'https' :
$self->{conf_opts}->{scheme} || 'http';
if ($opts->{http11}) {
$ENV{APACHE_TEST_HTTP11} = 1;
}
# unless we are already reconfiguring, check for .conf.in files changes
if (!$$save &&
(my @reasons =
$self->{test_config}->need_reconfiguration($self->{conf_opts}))) {
warning "forcing re-configuration:";
warning "\t- $_." for @reasons;
unless ($refreshed) {
$self->refresh;
$refreshed = 1;
$test_config = $self->{test_config};
}
}
# unless we are already reconfiguring, check for -proxy
if (!$$save && exists $opts->{proxy}) {
my $max = $test_config->{vars}->{maxclients};
$opts->{proxy} ||= 'on';
#if config is cached and MaxClients == 1, must reconfigure
if (!$$save and $opts->{proxy} eq 'on' and $max == 1) {
$$save = 1;
warning "server is reconfigured for proxy";
unless ($refreshed) {
$self->refresh;
$refreshed = 1;
$test_config = $self->{test_config};
}
}
$test_config->{vars}->{proxy} = $opts->{proxy};
}
else {
$test_config->{vars}->{proxy} = 'off';
}
return unless $$save;
my $preamble = sub { shift->preamble($opts->{preamble}) };
my $postamble = sub { shift->postamble($opts->{postamble}) };
$test_config->preamble_register($preamble);
$test_config->postamble_register($postamble);
}
sub pre_configure { }
sub configure {
my $self = shift;
if ($self->{opts}->{'no-httpd'}) {
warning "skipping httpd configuration";
return;
}
# create the conf dir as early as possible
$self->{test_config}->prepare_t_conf();
my $save = \$self->{conf_opts}->{save};
$self->configure_opts($save);
my $config = $self->{test_config};
unless ($$save) {
my $addr = \$config->{vars}->{remote_addr};
my $remote_addr = $config->our_remote_addr;
unless ($$addr eq $remote_addr) {
warning "local ip address has changed, updating config cache";
$$addr = $remote_addr;
}
#update minor changes to cached config
#without complete regeneration
#for example this allows switching between
#'t/TEST' and 't/TEST -ssl'
$config->sync_vars(qw(scheme proxy remote_addr));
return;
}
my $test_config = $self->{test_config};
$test_config->sslca_generate;
$test_config->generate_ssl_conf if $self->{opts}->{ssl};
$test_config->cmodules_configure;
$test_config->generate_httpd_conf;
$test_config->save;
}
sub try_exit_opts {
my $self = shift;
my @opts = @_;
for (@opts) {
next unless exists $self->{opts}->{$_};
my $method = "opt_$_";
my $rc = $self->$method();
exit_perl $rc if $rc;
}
if ($self->{opts}->{'stop-httpd'}) {
my $ok = 1;
if ($self->{server}->ping) {
$ok = $self->{server}->stop;
$ok = $ok < 0 ? 0 : 1; # adjust to 0/1 logic
}
else {
warning "server $self->{server}->{name} is not running";
# cleanup a stale pid file if found
my $pid_file = $self->{test_config}->{vars}->{t_pid_file};
unlink $pid_file if -e $pid_file;
}
exit_perl $ok;
}
}
sub start {
my $self = shift;
my $opts = $self->{opts};
my $server = $self->{server};
#if t/TEST -d is running make sure we don't try to stop/start the server
my $file = $server->debugger_file;
if (-e $file and $opts->{'start-httpd'}) {
if ($server->ping) {
warning "server is running under the debugger, " .
"defaulting to -run";
$opts->{'start-httpd'} = $opts->{'stop-httpd'} = 0;
}
else {
warning "removing stale debugger note: $file";
unlink $file;
}
}
$self->check_runtime_user();
if ($opts->{'start-httpd'}) {
exit_perl 0 unless $server->start;
}
elsif ($opts->{'run-tests'}) {
my $is_up = $server->ping
|| (exists $self->{opts}->{ping}
&& $self->{opts}->{ping} eq 'block'
&& $server->wait_till_is_up(STARTUP_TIMEOUT));
unless ($is_up) {
error "server is not ready yet, try again.";
exit_perl 0;
}
}
}
sub run_tests {
my $self = shift;
my $test_opts = {
verbose => $self->{opts}->{verbose},
tests => $self->{tests},
order => $self->{opts}->{order},
subtests => $self->{subtests} || [],
};
if (grep { exists $self->{opts}->{$_} } @request_opts) {
run_request($self->{test_config}, $self->{opts});
}
else {
Apache::TestHarness->run($test_opts)
if $self->{opts}->{'run-tests'};
}
}
sub stop {
my $self = shift;
return $self->{server}->stop if $self->{opts}->{'stop-httpd'};
}
sub new_test_config {
my $self = shift;
Apache::TestConfig->new($self->{conf_opts});
}
sub set_ulimit_via_sh {
return if Apache::TestConfig::WINFU;
return if $ENV{APACHE_TEST_ULIMIT_SET};
# only root can allow unlimited core dumps on Solaris (8 && 9?)
if (Apache::TestConfig::SOLARIS) {
my $user = getpwuid($>) || '';
if ($user ne 'root') {
warning "Skipping 'set unlimited ulimit for coredumps', " .
"since we are running as a non-root user on Solaris";
return;
}
}
my $binsh = '/bin/sh';
return unless -e $binsh;
$ENV{APACHE_TEST_ULIMIT_SET} = 1;
my $sh = Symbol::gensym();
open $sh, "echo ulimit -a | $binsh|" or die;
local $_;
while (<$sh>) {
if (/^core.*unlimited$/) {
#already set to unlimited
$ENV{APACHE_TEST_ULIMIT_SET} = 1;
return;
}
}
close $sh;
$orig_command = "ulimit -c unlimited; $orig_command";
warning "setting ulimit to allow core files\n$orig_command";
# use 'or die' to avoid warnings due to possible overrides of die
exec $orig_command or die "exec $orig_command has failed";
}
sub set_ulimit {
my $self = shift;
#return if $self->set_ulimit_via_bsd_resource;
eval { $self->set_ulimit_via_sh };
}
sub set_env {
#export some environment variables for t/modules/env.t
#(the values are unimportant)
$ENV{APACHE_TEST_HOSTNAME} = 'test.host.name';
$ENV{APACHE_TEST_HOSTTYPE} = 'z80';
}
sub run {
my $self = shift;
# assuming that test files are always in the same directory as the
# driving script, make it possible to run the test suite from any place
# use a full path, which will work after chdir (e.g. ./TEST)
$0 = File::Spec->rel2abs($0);
if (-e $0) {
my $top = dirname dirname $0;
chdir $top if $top and -d $top;
}
# reconstruct argv, preserve multiwords args, eg 'PerlTrace all'
my $argv = join " ", map { /^-/ ? $_ : qq['$_'] } @ARGV;
$orig_command = "$^X $0 $argv";
$orig_cwd = Cwd::cwd();
$self->set_ulimit;
$self->set_env; #make sure these are always set
$self->detect_relocation($orig_cwd);
my(@argv) = @_;
$self->getopts(\@argv);
$self->pre_configure();
# can't setup the httpd-specific parts of the config object yet
$self->{test_config} = $self->new_test_config();
$self->warn_core();
# give TestServer access to our runtime configuration directives
# so we can tell the server stuff if we need to
$self->{test_config}->{server}->{run} = $self;
$self->{server} = $self->{test_config}->server;
local($SIG{__DIE__}, $SIG{INT});
$self->install_sighandlers;
$self->try_exit_opts(@exit_opts_no_need_httpd);
# httpd is found here (unless it was already configured before)
$self->{test_config}->httpd_config();
$self->try_exit_opts(@exit_opts_need_httpd);
if ($self->{opts}->{configure}) {
warning "cleaning out current configuration";
$self->opt_clean(1);
}
$self->split_test_args;
$self->die_on_invalid_args;
$self->default_run_opts;
# if configure() fails for some reason before it has flushed the
# config to a file, save it so -clean will be able to clean
if ($self->{opts}->{'start-httpd'} || $self->{opts}->{'configure'}) {
eval { $self->configure };
if ($@) {
error "configure() has failed:\n$@";
warning "forcing Apache::TestConfig object save";
$self->{test_config}->save;
warning "run 't/TEST -clean' to clean up before continuing";
exit_perl 0;
}
}
if ($self->{opts}->{configure}) {
warning "reconfiguration done";
exit_perl 1;
}
$self->start unless $self->{opts}->{'no-httpd'};
$self->run_tests;
$self->stop unless $self->{opts}->{'no-httpd'};
}
sub rerun {
my $vars = shift;
# in %$vars
# - httpd will be always set
# - apxs is optional
$orig_cwd ||= Cwd::cwd();
chdir $orig_cwd;
my $new_opts = " -httpd $vars->{httpd}";
$new_opts .= " -apxs $vars->{apxs}" if $vars->{apxs};
my $new_command = $orig_command;
# strip any old bogus -httpd/-apxs
$new_command =~ s/--?httpd\s+$orig_conf_opts->{httpd}//
if $orig_conf_opts->{httpd};
$new_command =~ s/--?httpd\s+$orig_conf_opts->{httpd}//
if $orig_conf_opts->{httpd} and $vars->{apxs};
# add new opts
$new_command .= $new_opts;
warning "running with new config opts: $new_command";
# use 'or die' to avoid warnings due to possible overrides of die
exec $new_command or die "exec $new_command has failed";
}
# make it easy to move the whole distro w/o running
# 't/TEST -clean' before moving. when moving the whole package,
# the old cached config will stay, so we want to nuke it only if
# we realize that it's no longer valid. we can't just check the
# existance of the saved top_dir value, since the project may have
# been copied and the old dir could be still there, but that's not
# the one that we work in
sub detect_relocation {
my($self, $cur_top_dir) = @_;
my $config_file = catfile qw(t conf apache_test_config.pm);
return unless -e $config_file;
my %inc = %INC;
eval { require "$config_file" };
%INC = %inc; # be stealth
warn($@), return if $@;
my $cfg = 'apache_test_config'->new;
# if the top_dir from saved config doesn't match the current
# top_dir, that means that the whole project was relocated to a
# different directory, w/o running t/TEST -clean first (in each
# directory with a test suite)
my $cfg_top_dir = $cfg->{vars}->{top_dir};
return unless $cfg_top_dir;
return if $cfg_top_dir eq $cur_top_dir;
# if that's the case silently fixup the saved config to use the
# new paths, and force a complete cleanup. if we don't fixup the
# config files, the cleanup process won't be able to locate files
# to delete and re-configuration will fail
{
# in place editing
local @ARGV = $config_file;
local $^I = ".bak"; # Win32 needs a backup
while (<>) {
s{$cfg_top_dir}{$cur_top_dir}g;
print;
}
unlink $config_file . $^I;
}
my $cleanup_cmd = "$^X $0 -clean";
warning "cleaning up the old config";
# XXX: do we care to check success?
system $cleanup_cmd;
# XXX: I tried hard to accomplish that w/o starting a new process,
# but too many things get on the way, so for now just keep it as an
# external process, as it's absolutely transparent to the normal
# app-run
}
my @oh = qw(jeez golly gosh darn shucks dangit rats nuts dangnabit crap);
sub oh {
$oh[ rand scalar @oh ];
}
#e.g. t/core or t/core.12499
my $core_pat = '^core(\.\d+)?' . "\$";
# $self->scan_core_incremental([$only_top_dir])
# normally would be called after each test
# and since it updates the list of seen core files
# scan_core() won't report these again
# currently used in Apache::TestSmoke
#
# if $only_t_dir arg is true only the t_dir dir (t/) will be scanned
sub scan_core_incremental {
my($self, $only_t_dir) = @_;
my $vars = $self->{test_config}->{vars};
# no core files dropped on win32
return () if Apache::TestConfig::WIN32;
if ($only_t_dir) {
require IO::Dir;
my @cores = ();
for (IO::Dir->new($vars->{t_dir})->read) {
my $file = catfile $vars->{t_dir}, $_;
next unless -f $file;
next unless /$core_pat/o;
next if exists $core_files{$file} &&
$core_files{$file} == -M $file;
$core_files{$file} = -M $file;
push @cores, $file;
}
return @cores
? join "\n", "server dumped core, for stacktrace, run:",
map { "gdb $vars->{httpd} -core $_" } @cores
: ();
}
my @msg = ();
finddepth({ no_chdir => 1,
wanted => sub {
return unless -f $_;
my $file = basename $File::Find::name;
return unless $file =~ /$core_pat/o;
my $core = $File::Find::name;
unless (exists $core_files{$core} && $core_files{$core} == -M $core) {
# new core file!
# XXX: could rename the file if it doesn't include the pid
# in its name (i.e., just called 'core', instead of 'core.365')
# XXX: could pass the test name and rename the core file
# to use that name as a suffix, plus pid, time or some
# other unique identifier, in case the same test is run
# more than once and each time it caused a segfault
$core_files{$core} = -M $core;
push @msg, "server dumped core, for stacktrace, run:\n" .
"gdb $vars->{httpd} -core $core";
}
}}, $vars->{top_dir});
return @msg;
}
sub scan_core {
my $self = shift;
my $vars = $self->{test_config}->{vars};
my $times = 0;
# no core files dropped on win32
return if Apache::TestConfig::WIN32;
finddepth({ no_chdir => 1,
wanted => sub {
return unless -f $_;
my $file = basename $File::Find::name;
return unless $file =~ /$core_pat/o;
my $core = $File::Find::name;
if (exists $core_files{$core} && $core_files{$core} == -M $core) {
# we have seen this core file before the start of the test
info "an old core file has been found: $core";
}
else {
my $oh = oh();
my $again = $times++ ? "again" : "";
error "oh $oh, server dumped core $again";
error "for stacktrace, run: gdb $vars->{httpd} -core $core";
}
}}, $vars->{top_dir});
}
# warn the user that there is a core file before the tests
# start. suggest to delete it before proceeding or a false alarm can
# be generated at the end of the test routine run.
sub warn_core {
my $self = shift;
my $vars = $self->{test_config}->{vars};
%core_files = (); # reset global
# no core files dropped on win32
return if Apache::TestConfig::WIN32;
finddepth(sub {
return unless -f $_;
return unless /$core_pat/o;
my $core = "$File::Find::dir/$_";
info "consider removing an old $core file before running tests";
# remember the timestamp of $core so we can check if it's the
# old core file at the end of the run and not complain then
$core_files{$core} = -M $core;
}, $vars->{top_dir});
}
# catch any attempts to ./t/TEST the tests as root user
sub check_runtime_user {
my $self = shift;
return if Apache::TestConfig::WINFU;
my $user = getpwuid($>) || '';
if ($user eq 'root') {
error "Apache cannot spawn child processes as root, therefore the test suite must be run as a non-privileged user.";
exit_perl(1);
}
return 1;
}
sub run_request {
my($test_config, $opts) = @_;
my @args = (%{ $opts->{header} }, %{ $opts->{req_args} });
my($request, $url) = ("", "");
for (@request_opts) {
next unless exists $opts->{$_};
$url = $opts->{$_} if $opts->{$_};
$request = join $request ? '_' : '', $request, $_;
}
if ($request) {
my $method = \&{"Apache::TestRequest::\U$request"};
my $res = $method->($url, @args);
print Apache::TestRequest::to_string($res);
}
}
sub opt_clean {
my($self, $level) = @_;
my $test_config = $self->{test_config};
$test_config->server->stop;
$test_config->clean($level);
1;
}
sub opt_ping {
my($self) = @_;
my $test_config = $self->{test_config};
my $server = $test_config->server;
my $pid = $server->ping;
my $name = $server->{name};
# support t/TEST -ping=block -run ...
my $exit = not $self->{opts}->{'run-tests'};
if ($pid) {
if ($pid == -1) {
error "port $test_config->{vars}->{port} is in use, ".
"but cannot determine server pid";
}
else {
my $version = $server->{version};
warning "server $name running (pid=$pid, version=$version)";
}
return $exit;
}
if (exists $self->{opts}->{ping} && $self->{opts}->{ping} eq 'block') {
$server->wait_till_is_up(STARTUP_TIMEOUT);
}
else {
warning "no server is running on $name";
exit_perl(0);
}
return $exit; #means call exit() if true
}
sub test_inc {
map { "$_/Apache-Test/lib" } qw(. ..);
}
sub set_perl5lib {
$ENV{PERL5LIB} = join $Config{path_sep}, shift->test_inc();
}
sub set_perldb_opts {
my $config = shift->{test_config};
my $file = catfile $config->{vars}->{t_logs}, 'perldb.out';
$config->genfile($file); #mark for -clean
$ENV{PERLDB_OPTS} = "NonStop frame=4 AutoTrace LineInfo=$file";
warning "perldb log is t/logs/perldb.out";
}
sub opt_debug {
my $self = shift;
my $server = $self->{server};
my $opts = $self->{opts};
my $debug_opts = {};
for (qw(debugger breakpoint)) {
$debug_opts->{$_} = $opts->{$_};
}
if (my $db = $opts->{debugger}) {
if ($db =~ s/^perl=?//) {
$opts->{'run-tests'} = 1;
$self->start; #if not already running
$self->set_perl5lib;
$self->set_perldb_opts if $db eq 'nostop';
system $^X, '-MApache::TestPerlDB', '-d', @{ $self->{tests} };
$self->stop;
return 1;
}
elsif ($db =~ s/^lwp[=:]?//) {
$ENV{APACHE_TEST_DEBUG_LWP} = $db || 1;
$opts->{verbose} = 1;
return 0;
}
}
$server->stop;
$server->start_debugger($debug_opts);
1;
}
sub opt_help {
my $self = shift;
print <<EOM;
usage: TEST [options ...]
where options include:
EOM
for (sort keys %usage){
printf " -%-13s %s\n", $_, $usage{$_};
}
print "\n configuration options:\n";
Apache::TestConfig->usage;
1;
}
# generate t/TEST script (or a different filename) which will drive
# Apache::TestRun
sub generate_script {
my ($class, @opts) = @_;
my %opts = ();
# back-compat
if (@opts == 1) {
$opts{file} = $opts[0];
}
else {
%opts = @opts;
$opts{file} ||= catfile 't', 'TEST';
}
my $body = "BEGIN { eval { require blib && blib->import; } }\n";
my %args = @Apache::TestMM::Argv;
while (my($k, $v) = each %args) {
$v =~ s/\|/\\|/g;
$body .= "\n\$Apache::TestConfig::Argv{'$k'} = q|$v|;\n";
}
my $header = Apache::TestConfig->perlscript_header;
$body .= join "\n",
$header, "use $class ();";
if (my $report = $opts{bugreport}) {
$body .= "\n\npackage $class;\n" .
"sub bug_report { print '$report' }\n\n";
}
$body .= "$class->new->run(\@ARGV);";
Apache::Test::basic_config()->write_perlscript($opts{file},
$body);
}
# in idiomatic perl functions return 1 on success and 0 on
# failure. Shell expects the opposite behavior. So this function
# reverses the status.
sub exit_perl {
exit_shell $_[0] ? 0 : 1;
}
# expects shell's exit status values (0==success)
sub exit_shell {
# require Carp;
# Carp::cluck('exiting');
CORE::exit $_[0];
}
1;
__END__
=head1 NAME
Apache::TestRun - Run the test suite
=head1 SYNOPSIS
=head1 DESCRIPTION
The C<Apache::TestRun> package controls the configuration and running
of the test suite.
=head1 METHODS
Several methods are sub-classable, if the default behavior should be
changed.
=head2 C<bug_report>
The C<bug_report()> method is executed when C<t/TEST> was executed
with the C<-bugreport> option, and C<make test> (or C<t/TEST>)
fail. Normally this is callback which you can use to tell the user how
to deal with the problem, e.g. suggesting to read some document or
email some details to someone who can take care of it. By default
nothing is executed.
The C<-bugreport> option is needed so this feature won't become
annoying to developers themselves. It's automatically added to the
C<run_tests> target in F<Makefile>. So if you repeateadly have to test
your code, just don't use C<make test> but run C<t/TEST>
directly. Here is an example of a custom C<t/TEST>
My::TestRun->new->run(@ARGV);
package My::TestRun;
use base 'Apache::TestRun';
sub bug_report {
my $self = shift;
print <<EOI;
+--------------------------------------------------------+
| Please file a bug report: http://perl.apache.org/bugs/ |
+--------------------------------------------------------+
EOI
}
=head2 C<pre_configure>
The C<pre_configure()> method is executed before the configuration for
C<Apache::Test> is generated. So if you need to adjust the setup
before I<httpd.conf> and other files are autogenerated, this is the
right place to do so.
For example if you don't want to inherit a LoadModule directive for
I<mod_apreq.so> but to make sure that the local version is used, you
can sub-class C<Apache::TestRun> and override this method in
I<t/TEST.PL>:
package My::TestRun;
use base 'Apache::TestRun';
use Apache::TestConfig;
__PACKAGE__->new->run(@ARGV);
sub pre_configure {
my $self = shift;
# Don't load an installed mod_apreq
Apache::TestConfig::autoconfig_skip_module_add('mod_apreq.c');
$self->SUPER::pre_configure();
}
Notice that the extension is I<.c>, and not I<.so>.
Don't forget to run the super class' c<pre_configure()> method.
=head2 C<new_test_config>
META: to be completed
=cut