# common functionality for tests.
# imported into main for ease of use.
package main;
# use strict;
# use warnings;
# use re 'taint';
use Cwd;
use Config;
use File::Basename;
use File::Copy;
use File::Path;
use File::Spec;
use POSIX qw(WIFEXITED WIFSIGNALED WIFSTOPPED WEXITSTATUS WTERMSIG WSTOPSIG);
use vars qw($RUNNING_ON_WINDOWS $SSL_AVAILABLE
$SKIP_SPAMD_TESTS $SKIP_SPAMC_TESTS $NO_SPAMC_EXE
$SKIP_SETUID_NOBODY_TESTS $SKIP_DNSBL_TESTS
$have_inet4 $have_inet6 $spamdhost $spamdport);
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK);
@ISA = qw(Exporter);
@EXPORT = qw($have_inet4 $have_inet6 $spamdhost $spamdport);
# No spamd test in Windows unless env override says user figured out a way
# If you want to know why these are vars and no constants, read this thread:
# <http://www.mail-archive.com/dev%40perl.apache.org/msg05466.html>
# -- mss, 2004-01-13
$RUNNING_ON_WINDOWS = ($^O =~ /^(mswin|dos|os2)/oi);
$SKIP_SPAMD_TESTS =
$RUNNING_ON_WINDOWS ||
( $ENV{'SPAMD_HOST'} && !($ENV{'SPAMD_HOST'} eq '127.0.0.1' ||
$ENV{'SPAMD_HOST'} eq '::1' ||
$ENV{'SPAMD_HOST'} eq 'localhost') );
$SKIP_SETUID_NOBODY_TESTS = 0;
$SKIP_DNSBL_TESTS = 0;
$have_inet4 = eval {
require IO::Socket::INET;
my $sock = IO::Socket::INET->new(LocalAddr => '0.0.0.0', Proto => 'udp');
$sock->close or die "error closing inet socket: $!" if $sock;
$sock ? 1 : undef;
};
$have_inet6 = eval {
require IO::Socket::INET6;
my $sock = IO::Socket::INET6->new(LocalAddr => '::', Proto => 'udp');
$sock->close or die "error closing inet6 socket: $!" if $sock;
$sock ? 1 : undef;
};
}
# Set up for testing. Exports (as global vars):
# out: $home: $HOME env variable
# out: $cwd: here
# out: $scr: spamassassin script
# in: if --override appears at start of command line, next 2 args are used to set
# an environment variable to control test behaviour.
#
sub sa_t_init {
my $tname = shift;
if ($config{PERL_PATH}) {
$perl_path = $config{PERL_PATH};
}
elsif ($^X =~ m|^/|) {
$perl_path = $^X;
}
else {
$perl_path = $Config{perlpath};
$perl_path =~ s|/[^/]*$|/$^X|;
}
$perl_cmd = $perl_path;
# propagate $PERL5OPT; seems to be necessary, at least for the common idiom of
# "PERL5OPT=-MFoo::Bar ./test.t"
if ($ENV{'PERL5OPT'}) {
my $o = $ENV{'PERL5OPT'};
if ($o =~ /(Devel::Cover)/) {
warn "# setting TEST_PERL_TAINT=no to avoid lack of taint-safety in $1\n";
$ENV{'TEST_PERL_TAINT'} = 'no';
}
$perl_cmd .= " \"$o\"";
}
$perl_cmd .= " -T" if !defined($ENV{'TEST_PERL_TAINT'}) or $ENV{'TEST_PERL_TAINT'} ne 'no';
$perl_cmd .= " -w" if !defined($ENV{'TEST_PERL_WARN'}) or $ENV{'TEST_PERL_WARN'} ne 'no';
$scr = $ENV{'SPAMASSASSIN_SCRIPT'};
$scr ||= "$perl_cmd ../spamassassin.raw";
$spamd = "$perl_cmd ../spamd/spamd.raw";
$spamc = $ENV{'SPAMC_SCRIPT'};
$spamc ||= "../spamc/spamc";
$salearn = $ENV{'SALEARN_SCRIPT'};
$salearn ||= "$perl_cmd ../sa-learn.raw";
$spamdlocalhost = $ENV{'SPAMD_LOCALHOST'};
if (!$spamdlocalhost) {
$spamdlocalhost = $have_inet4 || !$have_inet6 ? '127.0.0.1' : '::1';
}
$spamdhost = $ENV{'SPAMD_HOST'};
$spamdhost ||= $spamdlocalhost;
$spamdport = $ENV{'SPAMD_PORT'};
$spamdport ||= probably_unused_spamd_port();
# optimisation -- don't setup spamd test parameters unless we're
# not skipping all spamd tests and this particular test is called
# called "spamd_something" or "spamc_foo"
# We still run spamc tests when there is an external SPAMD_HOST, but don't have to set up the spamd parameters for it
if ($SKIP_SPAMD_TESTS or ($tname !~ /spam[cd]/)) {
$NO_SPAMD_REQUIRED = 1;
}
$spamd_cf_args = "-C log/test_rules_copy";
$spamd_localrules_args = " --siteconfigpath log/localrules.tmp";
$scr_localrules_args = " --siteconfigpath log/localrules.tmp";
$salearn_localrules_args = " --siteconfigpath log/localrules.tmp";
$scr_cf_args = "-C log/test_rules_copy";
$scr_pref_args = "-p log/test_default.cf";
$salearn_cf_args = "-C log/test_rules_copy";
$salearn_pref_args = "-p log/test_default.cf";
$scr_test_args = "";
$salearn_test_args = "";
$set_test_prefs = 0;
$default_cf_lines = "
bayes_path ./log/user_state/bayes
auto_whitelist_path ./log/user_state/auto-whitelist
";
(-f "t/test_dir") && chdir("t"); # run from ..
read_config();
# if running as root, ensure "nobody" can write to it too
if ($> == 0) {
$tmp_dir_mode = 0777;
umask 022; # ensure correct permissions on files and dirs created here
# Bug 5529 initial fix: For now don't run a test as root if it has a problem resuting from setuid nobody
# FIXME: Eventually we can actually test setuid nobody and accessing ./log to make this test more fine grained
# and we can create an accessible temp dir that some of the tests can use. But for now just skip those tests.
$SKIP_SETUID_NOBODY_TESTS = 1;
} else {
$tmp_dir_mode = 0755;
}
if (!$NO_SPAMD_REQUIRED) {
$NO_SPAMC_EXE = ($RUNNING_ON_WINDOWS &&
!$ENV{'SPAMC_SCRIPT'} &&
!(-e "../spamc/spamc.exe"));
$SKIP_SPAMC_TESTS = ($NO_SPAMC_EXE ||
($RUNNING_ON_WINDOWS && !$ENV{'SPAMD_HOST'}));
$SSL_AVAILABLE = ((!$SKIP_SPAMC_TESTS) && # no SSL test if no spamc
(!$SKIP_SPAMD_TESTS) && # or if no local spamd
(`$spamc -V` =~ /with SSL support/) &&
(`$spamd --version` =~ /with SSL support/));
}
# do not remove prior test results!
# rmtree ("log");
unless (-d "log") {
mkdir ("log", 0755) or die ("Error creating log dir: $!");
}
chmod (0755, "log"); # set in case log already exists with wrong permissions
system("chacl -B log 2>/dev/null || setfacl -b log 2>/dev/null"); # remove acls that confuse test
rmtree ("log/user_state");
rmtree ("log/outputdir.tmp");
rmtree ("log/test_rules_copy");
mkdir ("log/test_rules_copy", 0755);
for $tainted (<../rules/*.cf>, <../rules/*.pm>, <../rules/*.pre>) {
$tainted =~ /(.*)/;
my $file = $1;
$base = basename $file;
copy ($file, "log/test_rules_copy/$base")
or warn "cannot copy $file to log/test_rules_copy/$base: $!";
}
copy ("data/01_test_rules.pre", "log/test_rules_copy/01_test_rules.pre")
or warn "cannot copy data/01_test_rules.cf to log/test_rules_copy/01_test_rules.pre: $!";
copy ("data/01_test_rules.cf", "log/test_rules_copy/01_test_rules.cf")
or warn "cannot copy data/01_test_rules.cf to log/test_rules_copy/01_test_rules.cf: $!";
rmtree ("log/localrules.tmp");
mkdir ("log/localrules.tmp", 0755);
for $tainted (<../rules/*.pm>, <../rules/*.pre>) {
$tainted =~ /(.*)/;
my $file = $1;
$base = basename $file;
copy ($file, "log/localrules.tmp/$base")
or warn "cannot copy $file to log/localrules.tmp/$base: $!";
}
copy ("../rules/user_prefs.template", "log/test_rules_copy/99_test_default.cf")
or die "user prefs copy failed: $!";
open (PREFS, ">>log/test_rules_copy/99_test_default.cf")
or die "cannot append to log/test_rules_copy/99_test_default.cf: $!";
print PREFS $default_cf_lines
or die "error writing to log/test_rules_copy/99_test_default.cf: $!";
close PREFS
or die "error closing log/test_rules_copy/99_test_default.cf: $!";
# create an empty .prefs file
open (PREFS, ">>log/test_default.cf")
or die "cannot append to log/test_default.cf: $!";
close PREFS
or die "error closing log/test_default.cf: $!";
mkdir("log/user_state",$tmp_dir_mode);
chmod ($tmp_dir_mode, "log/user_state"); # unaffected by umask
$home = $ENV{'HOME'};
$home ||= $ENV{'WINDIR'} if (defined $ENV{'WINDIR'});
$cwd = getcwd;
$ENV{'TEST_DIR'} = $cwd;
$testname = $tname;
$spamd_run_as_user = ($RUNNING_ON_WINDOWS || ($> == 0)) ? "nobody" : (getpwuid($>))[0] ;
}
# a port number between 32768 and 65535; used to allow multiple test
# suite runs on the same machine simultaneously
sub probably_unused_spamd_port {
return 0 if $NO_SPAMD_REQUIRED;
my $port;
my @nstat;
local $ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin'; # must not be tainted
if (!open(NSTAT, "netstat -a -n 2>&1 |")) {
# not too bad if failing on some architecture, with some luck should be alright
} else {
@nstat = grep(/^\s*tcp/i, <NSTAT>);
close(NSTAT);
}
my $delta = ($$ % 32768) || int(rand(32768));
for (1..10) {
$port = 32768 + $delta;
last unless (getservbyport($port, "tcp") || grep(/[:.]$port\s/, @nstat));
$delta = int(rand(32768));
}
return $port;
}
sub locate_command {
my ($command) = @_;
my @path = File::Spec->path();
push(@path, '/usr/bin') if ! grep { m@/usr/bin/?$@ } @path;
for my $path (@path) {
$location = "$path/$command";
$location =~ s@//@/@g;
return $location if -x $location;
}
return 0;
}
sub sa_t_finish {
# no-op currently
}
sub tstfile {
my $file = shift;
open (OUT, ">log/mail.txt") or die;
print OUT $file; close OUT;
}
sub tstlocalrules {
my $lines = shift;
$set_local_rules = 1;
open (OUT, ">log/localrules.tmp/00test.cf") or die;
print OUT $lines; close OUT;
}
sub tstprefs {
my $lines = shift;
$set_test_prefs = 1;
# TODO: should we use -p, or modify the test_rules_copy/99_test_default.cf?
# for now, I'm taking the -p route, since we have to be able to test
# the operation of user-prefs in general, itself.
open (OUT, ">log/tst.cf") or die;
print OUT $lines; close OUT;
$scr_pref_args = "-p log/tst.cf";
}
# creates a .pre file in the localrules dir to be parsed alongside init.pre
# make it zz_* just to make sure it is parse last
sub tstpre {
my $lines = shift;
open (OUT, ">log/localrules.tmp/zz_tst.pre") or die;
print OUT $lines; close OUT;
}
# Run spamassassin. Calls back with the output.
# in $args: arguments to run with
# in $read_sub: callback for the output (should read from <IN>).
# This is called with no args.
#
# out: $sa_exitcode global: exitcode from sitescooper
# ret: undef if sitescooper fails, 1 for exit 0
#
sub sarun {
my $args = shift;
my $read_sub = shift;
my $post_redir = '';
$args =~ s/ 2\>\&1$// and $post_redir = ' 2>&1';
recreate_outputdir_tmp();
clear_pattern_counters();
if (defined $ENV{'SA_ARGS'}) {
$args = $ENV{'SA_ARGS'} . " ". $args;
}
$args = "$scr_cf_args $scr_localrules_args $scr_pref_args $scr_test_args $args";
# added fix for Windows tests from Rudif
my $scrargs = "$scr $args";
$scrargs =~ s!/!\\!g if ($^O =~ /^MS(DOS|Win)/i);
print ("\t$scrargs\n");
(-d "log/d.$testname") or mkdir ("log/d.$testname", 0755);
system ("$scrargs > log/d.$testname/${Test::ntest} $post_redir");
$sa_exitcode = ($?>>8);
if ($sa_exitcode != 0) { return undef; }
&checkfile ("d.$testname/${Test::ntest}", $read_sub) if (defined $read_sub);
1;
}
# Run salearn. Calls back with the output.
# in $args: arguments to run with
# in $read_sub: callback for the output (should read from <IN>).
# This is called with no args.
#
# out: $salearn_exitcode global: exitcode from sitescooper
# ret: undef if sitescooper fails, 1 for exit 0
#
sub salearnrun {
my $args = shift;
my $read_sub = shift;
recreate_outputdir_tmp();
%found = ();
%found_anti = ();
if (defined $ENV{'SA_ARGS'}) {
$args = $ENV{'SA_ARGS'} . " ". $args;
}
$args = "$salearn_cf_args $salearn_localrules_args $salearn_pref_args $salearn_test_args $args";
# added fix for Windows tests from Rudif
my $salearnargs = "$salearn $args";
$salearnargs =~ s!/!\\!g if ($^O =~ /^MS(DOS|Win)/i);
print ("\t$salearnargs\n");
(-d "log/d.$testname") or mkdir ("log/d.$testname", 0755);
system ("$salearnargs > log/d.$testname/${Test::ntest}");
$salearn_exitcode = ($?>>8);
if ($salearn_exitcode != 0) { return undef; }
&checkfile ("d.$testname/${Test::ntest}", $read_sub) if (defined $read_sub);
1;
}
sub scrun {
spamcrun (@_, 0);
}
sub scrunwithstderr {
spamcrun (@_, 1);
}
sub scrunwantfail {
spamcrun (@_, 1, 1);
}
sub spamcrun {
my $args = shift;
my $read_sub = shift;
my $capture_stderr = shift;
my $expect_failure = shift;
if (defined $ENV{'SC_ARGS'}) {
$args = $ENV{'SC_ARGS'} . " ". $args;
}
my $spamcargs;
if($args !~ /\b(?:-p\s*[0-9]+|-F|-U)\b/)
{
$args = "-d $spamdhost -p $spamdport $args";
}
if ($args !~ /-F/) {
$spamcargs = "$spamc -F data/spamc_blank.cf $args";
}
else {
$spamcargs = "$spamc $args";
}
$spamcargs =~ s!/!\\!g if ($^O =~ /^MS(DOS|Win)/i);
print ("\t$spamcargs\n");
(-d "log/d.$testname") or mkdir ("log/d.$testname", 0755);
if ($capture_stderr) {
system ("$spamcargs > log/d.$testname/out.${Test::ntest} 2>&1");
} else {
system ("$spamcargs > log/d.$testname/out.${Test::ntest}");
}
$sa_exitcode = ($?>>8);
if (!$expect_failure) {
if ($sa_exitcode != 0) { stop_spamd(); return undef; }
}
%found = ();
%found_anti = ();
&checkfile ("d.$testname/out.${Test::ntest}", $read_sub) if (defined $read_sub);
if ($expect_failure) {
($sa_exitcode != 0);
} else {
($sa_exitcode == 0);
}
}
sub spamcrun_background {
my $args = shift;
my $read_sub = shift;
if (defined $ENV{'SC_ARGS'}) {
$args = $ENV{'SC_ARGS'} . " ". $args;
}
my $spamcargs;
if($args !~ /\b(?:-p\s*[0-9]+|-o|-U)\b/)
{
$spamcargs = "$spamc -p $spamdport $args";
}
else
{
$spamcargs = "$spamc $args";
}
$spamcargs =~ s!/!\\!g if ($^O =~ /^MS(DOS|Win)/i);
print ("\t$spamcargs &\n");
(-d "log/d.$testname") or mkdir ("log/d.$testname", 0755);
system ("$spamcargs > log/d.$testname/bg.${Test::ntest} &") and return 0;
1;
}
sub sdrun {
my $sdargs = shift;
my $args = shift;
my $read_sub = shift;
start_spamd ($sdargs);
spamcrun ($args, $read_sub);
stop_spamd ();
1;
}
sub recreate_outputdir_tmp {
rmtree ("log/outputdir.tmp"); # some tests use this
mkdir ("log/outputdir.tmp", $tmp_dir_mode);
chmod ($tmp_dir_mode, "log/outputdir.tmp"); # unaffected by umask
}
# out: $spamd_stderr
sub start_spamd {
return if $SKIP_SPAMD_TESTS;
die "NO_SPAMD_REQUIRED in start_spamd! oops" if $NO_SPAMD_REQUIRED;
my $spamd_extra_args = shift;
return if (defined($spamd_pid) && $spamd_pid > 0);
recreate_outputdir_tmp();
if (defined $ENV{'SD_ARGS'}) {
$spamd_extra_args = $ENV{'SD_ARGS'} . " ". $spamd_extra_args;
}
my @spamd_args = (
$spamd,
qq{-D},
qq{-x}
);
if (!$spamd_inhibit_log_to_err) {
push (@spamd_args,
qq{-s}, qq{stderr},
);
}
if ($spamd_extra_args !~ /(?:-C\s*[^-]\S+)/) {
push(@spamd_args,
$spamd_cf_args,
$spamd_localrules_args,
);
}
if ($spamd_extra_args !~ /(?:-p\s*[0-9]+|-o|--socketpath)/) {
push(@spamd_args,
qq{-p}, $spamdport,
);
}
if ($spamd_extra_args !~ /(?:--socketpath)/) {
push(@spamd_args,
qq{-A}, $spamdhost, qq(-i), $spamdhost
);
}
if ($set_test_prefs) {
warn "oops! SATest.pm: a test prefs file was created, but spamd isn't reading it\n";
}
(-d "log/d.$testname") or mkdir ("log/d.$testname", 0755);
my $spamd_stdout = "log/d.$testname/spamd.out.${Test::ntest}";
$spamd_stderr = "log/d.$testname/spamd.err.${Test::ntest}"; # global
my $spamd_stdlog = "log/d.$testname/spamd.log.${Test::ntest}";
my $spamd_forker = $ENV{'SPAMD_FORKER'} ?
$ENV{'SPAMD_FORKER'} :
$RUNNING_ON_WINDOWS ?
"start $perl_path" :
$perl_path;
my $spamd_cmd = join(' ',
$spamd_forker,
qq{SATest.pl},
qq{-Mredirect},
qq{-O${spamd_stderr}},
qq{-o${spamd_stdout}},
qq{--},
@spamd_args,
$spamd_extra_args,
qq{-s ${spamd_stderr}.timestamped},
qq{&},
);
# DEBUG instrumentation to trace spamd processes. See bug 5731 for history
# if (-f "/home/jm/capture_spamd_straces") {
# $spamd_cmd = "strace -ttt -fo log/d.$testname/spamd.strace.${Test::ntest} $spamd_cmd";
# }
unlink ($spamd_stdout, $spamd_stderr, $spamd_stdlog);
print ("\t${spamd_cmd}\n");
my $startat = time;
system ($spamd_cmd);
# now find the PID
$spamd_pid = 0;
# note that the wait period increases the longer it takes,
# 20 retries works out to a total of 60 seconds
my $retries = 30;
my $wait = 0;
while ($spamd_pid <= 0) {
my $spamdlog = '';
if (open (IN, "<${spamd_stderr}")) {
while (<IN>) {
# Yes, DO retry on this error. I'm getting test failures otherwise
# /Address already in use/ and $retries = 0;
/server pid: (\d+)/ and $spamd_pid = $1;
if (/ERROR/) {
warn "spamd error! $_";
$retries = 0; last;
}
$spamdlog .= $_;
}
close IN;
last if ($spamd_pid);
}
sleep (int($wait++ / 4) + 1) if $retries > 0;
if ($retries-- <= 0) {
warn "spamd start failed: log: $spamdlog";
warn "\n\nMaybe you need to kill a running spamd process?\n";
warn "started at $startat, gave up at ".time."\n\n";
return 0;
}
}
1;
}
sub stop_spamd {
return 0 if ( defined($spamd_already_killed) || $SKIP_SPAMD_TESTS);
die "NO_SPAMD_REQUIRED in stop_spamd! oops" if $NO_SPAMD_REQUIRED;
$spamd_pid ||= 0;
if ( $spamd_pid <= 1) {
print ("Invalid spamd pid: $spamd_pid. Spamd not started/crashed?\n");
return 0;
} else {
my $killed = kill (15, $spamd_pid);
print ("Killed $killed spamd instances\n");
# wait for it to exit, before returning.
for my $waitfor (0 .. 5) {
my $killstat;
if (($killstat = kill (0, $spamd_pid)) == 0) { last; }
print ("Waiting for spamd at pid $spamd_pid to exit...\n");
sleep 1;
}
$spamd_pid = 0;
$spamd_already_killed = 1;
return $killed;
}
}
sub create_saobj {
my ($args) = shift; # lets you override/add arguments
# YUCK, these file/dir names should be some sort of variable, at
# least we keep their definition in the same file for the moment.
my %setup_args = ( rules_filename => 'log/test_rules_copy',
site_rules_filename => 'log/localrules.tmp',
userprefs_filename => 'log/test_default.cf',
userstate_dir => 'log/user_state',
local_tests_only => 1,
# debug => 'all',
);
# override default args
foreach my $arg (keys %$args) {
$setup_args{$arg} = $args->{$arg};
}
# We'll assume that the test has setup INC correctly
require Mail::SpamAssassin;
my $sa = Mail::SpamAssassin->new(\%setup_args);
return $sa;
}
sub create_clientobj {
my $args = shift;
# We'll assume that the test has setup INC correctly
require Mail::SpamAssassin::Client;
my $client = Mail::SpamAssassin::Client->new($args);
return $client;
}
# ---------------------------------------------------------------------------
sub checkfile {
my $filename = shift;
my $read_sub = shift;
# print "Checking $filename\n";
if (!open (IN, "< log/$filename")) {
# could be it already contains the "log/" prefix?
if (!open (IN, "< $filename")) {
warn "cannot open log/$filename or $filename"; return undef;
} else {
push @files_checked, "$filename";
}
} else {
push @files_checked, "log/$filename";
}
&$read_sub();
close IN;
}
# ---------------------------------------------------------------------------
sub pattern_to_re {
my $pat = shift;
if ($pat =~ /^\/(.*)\/$/) {
return $1;
}
$pat = quotemeta($pat);
# make whitespace irrelevant; match any amount as long as the
# non-whitespace chars are OK.
$pat =~ s/\\\s/\\s\*/gs;
$pat;
}
# ---------------------------------------------------------------------------
sub patterns_run_cb {
local ($_);
my $string = shift;
if (defined $string) {
$_ = $string;
} else {
$_ = join ('', <IN>);
}
$matched_output = $_;
# create default names == the pattern itself, if not specified
foreach my $pat (keys %patterns) {
if ($patterns{$pat} eq '') {
$patterns{$pat} = $pat;
}
}
foreach my $pat (sort keys %patterns) {
my $safe = pattern_to_re ($pat);
# print "JMD $patterns{$pat}\n";
if ($_ =~ /${safe}/s) {
$found{$patterns{$pat}}++;
}
}
foreach my $pat (sort keys %anti_patterns) {
my $safe = pattern_to_re ($pat);
# print "JMD $patterns{$pat}\n";
if ($_ =~ /${safe}/s) {
$found_anti{$anti_patterns{$pat}}++;
}
}
}
sub ok_all_patterns {
my ($dont_ok) = shift;
my (undef, $file, $line) = caller();
my $wasfailure = 0;
foreach my $pat (sort keys %patterns) {
my $type = $patterns{$pat};
print "\tChecking $type\n";
if (defined $found{$type}) {
if (!$dont_ok) {
ok ($found{$type} == 1) or warn "Found more than once: $type at $file line $line.\n";
}
} else {
warn "\tNot found: $type = $pat at $file line $line.\n";
if (!$dont_ok) {
ok (0); # keep the right # of tests
}
$wasfailure++;
}
}
foreach my $pat (sort keys %anti_patterns) {
my $type = $anti_patterns{$pat};
print "\tChecking for anti-pattern $type at $file line $line.\n";
if (defined $found_anti{$type}) {
warn "\tFound anti-pattern: $type = $pat at $file line $line.\n";
if (!$dont_ok) { ok (0); }
$wasfailure++;
}
else
{
if (!$dont_ok) { ok (1); }
}
}
if ($wasfailure) {
warn "Output can be examined in: ".
join(' ', @files_checked)."\n" if @files_checked;
return 0;
} else {
return 1;
}
}
sub skip_all_patterns {
my $skip = shift;
my (undef, $file, $line) = caller();
foreach my $pat (sort keys %patterns) {
my $type = $patterns{$pat};
print "\tChecking $type\n";
if (defined $found{$type}) {
skip ($skip, $found{$type} == 1) or warn "Found more than once: $type at $file line $line.\n";
warn "\tThis test should have been skipped: $skip at $file line $line.\n" if $skip;
} else {
if ($skip) {
warn "\tTest skipped: $skip at $file line $line.\n";
} else {
warn "\tNot found: $type = $pat at $file line $line.\n";
}
skip ($skip, 0); # keep the right # of tests
}
}
foreach my $pat (sort keys %anti_patterns) {
my $type = $anti_patterns{$pat};
print "\tChecking for anti-pattern $type\n";
if (defined $found_anti{$type}) {
warn "\tFound anti-pattern: $type = $pat at $file line $line.\n";
skip ($skip, 0);
}
else
{
skip ($skip, 1);
}
}
}
sub clear_pattern_counters {
%found = ();
%found_anti = ();
@files_checked = ();
}
sub read_config {
return if defined($already_read_config);
$already_read_config = 1;
# allow reading config from top-level dir, outside the test suite;
# this is so read_config() will work even when called from
# a "use constant" line at compile time.
my $prefix = '';
if (-f 't/test_dir') { $prefix = "t/"; }
if (!open (CF, "<${prefix}config")) {
if (!open (CF, "<${prefix}config.dist")) { # fall back to defaults
die "cannot open test suite configuration file 'config.dist': $!";
}
}
while (<CF>) {
s/#.*$//; s/^\s+//; s/\s+$//; next if /^$/;
/^([^=]+)=(.*)$/ or next;
$conf{$1} = $2;
}
# allow our xt test suite to override
if (defined $ARGV[0] && $ARGV[0] eq '--override') {
shift @ARGV;
my $k = shift @ARGV;
my $v = shift @ARGV;
# Override only allows setting one variable. Some xt tests need to set more
# config variables. Adding : as a delimeter for config variable and value
# parameters
@k = split (/:/,$k);
@v = split (/:/,$v);
if (scalar(@k) != scalar(@v)) {
print "Error: The number of override arguments for variables and values did not match\n!";
exit;
} else {
print "\nProcessing Overrides:\n\n";
}
for (my $i = 0; $i < scalar(@k); $i++) {
$conf{$k[$i]} = $v[$i];
print "Overriding $k[$i] with value $v[$i]\n";
}
}
close CF;
}
sub conf {
read_config();
return $conf{$_[0]};
}
sub conf_bool {
my $val = conf($_[0]);
return 0 unless defined($val);
return 1 if ($val =~ /^y/i); # y, YES, yes, etc.
return ($val+0) if ($val =~ /^\d/); # 1
return 0; # n or 0
}
sub mk_safe_tmpdir {
return $safe_tmpdir if defined($safe_tmpdir);
my $dir = File::Spec->tmpdir() || 'log';
# be a little paranoid, since we're using a public tmp dir and
# are exposed to race conditions
my $retries = 10;
my $tmp;
while (1) {
$tmp = "$dir/satest.$$.".rand(99999);
if (!-d $tmp && mkdir ($tmp, 0755)) {
if (-d $tmp && -o $tmp) { # check we own it
lstat($tmp);
if (-d _ && -o _) { # double-check, ignoring symlinks
last; # we got it safely
}
}
}
die "cannot get tmp dir, giving up" if ($retries-- < 0);
warn "failed to create tmp dir '$tmp' safely, retrying...";
sleep 1;
}
$safe_tmpdir = $tmp;
return $tmp;
}
sub cleanup_safe_tmpdir {
if ($safe_tmpdir) {
rmtree($safe_tmpdir) or warn "cannot rmtree $safe_tmpdir";
}
}
sub wait_for_file_to_change_or_disappear {
my ($f, $timeout, $action) = @_;
my $lastmod = (-M $f);
$action->();
my $wait = 0;
my $newlastmod;
do {
sleep (int($wait++ / 4) + 1) if $timeout > 0;
$timeout--;
$newlastmod = (-M $f);
} while((-e $f) && defined($newlastmod) &&
$newlastmod == $lastmod && $timeout);
}
sub wait_for_file_to_appear {
my ($f, $timeout) = @_;
# note that the wait period increases the longer it takes,
# 20 retries works out to a total of 60 seconds
my $wait = 0;
do {
sleep (int($wait++ / 4) + 1) if $timeout > 0;
$timeout--;
} while((!-e $f || -z $f) && $timeout);
}
sub read_from_pidfile {
my $f = shift;
my $npid = 0;
my $retries = 5;
do {
if ($retries != 5) {
sleep 1;
warn "retrying read of pidfile $f, due to short/nonexistent read: ".
"retry $retries";
}
$retries--;
if (!open (PID, "<".$f)) {
warn "Could not open pid file ${f}: $!\n"; # and retry
next;
}
$npid = <PID>;
if (defined $npid) { chomp $npid; }
close(PID);
if (!$npid || $npid < 1) {
warn "failed to read anything sensible from $f, retrying read";
$npid = 0;
next;
}
if (!kill (0, $npid)) {
warn "failed to kill -0 $npid, retrying read";
$npid = 0;
}
} until ($npid > 1 or $retries == 0);
return $npid;
}
sub system_or_die {
my $cmd = $_[0];
print ("\t$cmd\n");
system($cmd);
$? == 0 or die "'$cmd' failed: ".exit_status_str($?,0);
}
# (sub exit_status_str copied from Util.pm)
# map process termination status number to an informative string, and
# append optional mesage (dual-valued errno or a string or a number),
# returning the resulting string
#
sub exit_status_str($;$) {
my($stat,$errno) = @_;
my $str;
if (WIFEXITED($stat)) {
$str = sprintf("exit %d", WEXITSTATUS($stat));
} elsif (WIFSTOPPED($stat)) {
$str = sprintf("stopped, signal %d", WSTOPSIG($stat));
} else {
my $sig = WTERMSIG($stat);
$str = sprintf("%s, signal %d (%04x)",
$sig == 2 ? 'INTERRUPTED' : $sig == 6 ? 'ABORTED' :
$sig == 9 ? 'KILLED' : $sig == 15 ? 'TERMINATED' : 'DIED',
$sig, $stat);
}
if (defined $errno) { # deal with dual-valued and plain variables
$str .= ', '.$errno if (0+$errno) != 0 || ($errno ne '' && $errno ne '0');
}
return $str;
}
sub dbgprint { print STDOUT "[".time()."] ".$_[0]; }
sub can_use_net_dns_safely {
return unless eval { require Net::DNS; };
# bug 3806:
# Do not run this test with version of Sys::Hostname::Long older than 1.4
# on non-Linux unices as root, due to a bug in Sys::Hostname::Long
# (which is used by Net::DNS)
return 1 if ($< != 0);
return 1 if ($^O =~ /^(linux|mswin|dos|os2)/oi);
my $has_unsafe_hostname =
eval { require Sys::Hostname::Long && Sys::Hostname::Long->VERSION < 1.4 };
return 1 if !$has_unsafe_hostname;
return;
}
sub debug_hash {
my ($hash) = @_;
my ($string, $key, @keys, @sorted, $i);
if (uc(ref($hash)) eq "HASH") {
foreach $key (keys %$hash) {
push (@keys, $key);
}
@sorted = sort @keys;
for ($i=0; $i < scalar(@sorted); $i++) {
if (uc(ref($hash->{$sorted[$i]})) eq 'HASH') {
$string .= "$sorted[$i] = ".debug_hash($hash->{$sorted[$i]})."\n";
} else {
$string .= "$sorted[$i] = $hash->{$sorted[$i]}\n";
}
}
} else {
warn (uc(ref($hash)) . " is not a HASH\n");
}
return $string;
}
sub debug_array {
my ($array) = @_;
my ($string, $i);
if (uc(ref($array)) eq "ARRAY") {
for ($i =0; $i < scalar(@$array); $i++) {
$string .= "Array Element $i = $array->[$i]\n";
}
}
return $string;
}
1;