The Perl and Raku Conference 2025: Greenville, South Carolina - June 27-29 Learn more

# SATest with unused functions removed
package main;
require v5.14.0;
# use strict;
# use warnings;
# use re 'taint';
use Cwd;
use Config;
use File::Temp qw(tempdir);
use Test::More ();
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
$workdir $siterules $localrules $userrules $userstate
$keep_workdir $mainpid $spamd_pidfile);
my $sa_code_dir;
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:
# -- 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 {
my $sock = IO::Socket::INET->new(LocalAddr => '127.0.0.1', Proto => 'udp');
$sock->close or die "error closing inet socket: $!" if $sock;
$sock ? 1 : undef;
};
$have_inet6 = eval {
my $sock = IO::Socket::INET6->new(LocalAddr => '::1', Proto => 'udp');
$sock->close or die "error closing inet6 socket: $!" if $sock;
$sock ? 1 : undef;
};
# Clean PATH so taint doesn't complain
if (!$RUNNING_ON_WINDOWS) {
$ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin';
# Remove tainted envs, at least ENV used in FreeBSD
delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
} else {
# Windows might need non-system directories in PATH to run a Perl installation
# The best we can do is clean out obviously bad stuff such as relative paths or \..\
my @pathdirs = split(';', $ENV{'PATH'});
$ENV{'PATH'} =
join(';', # filter for only dirs that are canonical absolute paths that exist
map {
my $pathdir = $_;
$pathdir =~ s/\\*\z//;
my $abspathdir = File::Spec->canonpath(Cwd::realpath($pathdir)) if (-d $pathdir);
if (defined $abspathdir) {
$abspathdir =~ /^(.*)\z/s;
$abspathdir = $1; # untaint it
}
((defined $abspathdir) and (lc $pathdir eq lc $abspathdir))?($abspathdir):()
}
@pathdirs);
}
# Fix INC to point to absolute path of built SA
if (-e 't/test_dir') { $sa_code_dir = 'blib/lib'; }
elsif (-e 'test_dir') { $sa_code_dir = '../blib/lib'; }
else { die "FATAL: not in or below test directory?\n"; }
File::Spec->rel2abs($sa_code_dir) =~ /^(.*)\z/s;
$sa_code_dir = $1;
if (not -d $sa_code_dir) {
die "FATAL: not in expected directory relative to built code tree?\n";
}
}
# use is run at compile time, but after the variable has been computed in the BEGIN block
use lib $sa_code_dir;
# 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;
$mainpid = $$;
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';
# Copy directories in PERL5LIB into -I options in perl_cmd because -T suppresses use of PERL5LIB in call to ./spamassassin
# If PERL5LIB is empty copy @INC instead because on some platforms like FreeBSD MakeMaker clears PER5LIB and sets @INC
# Filter out relative paths, and canonicalize so no symlinks or /../ will be left in untainted result as a nod to security
# Since this is only used to run tests, the security considerations are not as strict as with more general situations.
my @pathdirs = @INC;
if ($ENV{'PERL5LIB'}) {
@pathdirs = split($Config{path_sep}, $ENV{'PERL5LIB'});
}
my $inc_opts =
join(' -I', # filter for only dirs that are absolute paths that exist, then canonicalize them
map {
my $pathdir = $_;
my $canonpathdir = File::Spec->canonpath(Cwd::realpath($pathdir)) if ((-d $pathdir) and File::Spec->file_name_is_absolute($pathdir));
if (defined $canonpathdir) {
$canonpathdir =~ /^(.*)\z/s;
$canonpathdir = $1; # untaint it
}
((defined $canonpathdir))?($canonpathdir):()
}
@pathdirs);
$perl_cmd .= " -I$inc_opts" if ($inc_opts);
# To work in Windows, the perl scripts have to be launched by $perl_cmd and
# the ones that are exe files have to be directly called in the command lines
$scr = $ENV{'SPAMASSASSIN_SCRIPT'};
$scr ||= "$perl_cmd ../spamassassin.raw";
$spamd = $ENV{'SPAMD_SCRIPT'};
$spamd ||= "$perl_cmd ../spamd/spamd.raw";
$spamc = $ENV{'SPAMC_SCRIPT'};
$spamc ||= "../spamc/spamc";
$salearn = $ENV{'SALEARN_SCRIPT'};
$salearn ||= "$perl_cmd ../sa-learn.raw";
$saawl = $ENV{'SAAWL_SCRIPT'};
$saawl ||= "$perl_cmd ../sa-awl";
$sacheckspamd = $ENV{'SACHECKSPAMD_SCRIPT'};
$sacheckspamd ||= "$perl_cmd ../sa-check_spamd";
$spamdlocalhost = $ENV{'SPAMD_LOCALHOST'};
if (!$spamdlocalhost) {
$spamdlocalhost = $have_inet4 || !$have_inet6 ? '127.0.0.1' : '::1';
}
$spamdhost = $ENV{'SPAMD_HOST'};
$spamdhost ||= $spamdlocalhost;
# 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 ($tname !~ /spam[cd]/) {
$TEST_DOES_NOT_RUN_SPAMC_OR_D = 1;
} else {
$spamdport = $ENV{'SPAMD_PORT'};
$spamdport ||= probably_unused_spamd_port();
}
(-f "t/test_dir") && chdir("t"); # run from ..
-f "test_dir" or die "FATAL: not in test directory?\n";
mkdir ("log", 0755);
-d "log" or die "FATAL: failed to create log dir\n";
chmod (0755, "log"); # set in case log already exists with wrong permissions
if (!$RUNNING_ON_WINDOWS) {
untaint_system("chacl -B log 2>/dev/null || setfacl -b log 2>/dev/null"); # remove acls that confuse test
}
# clean old workdir if sa_t_init called multiple times
if (defined $workdir) {
if (!$keep_workdir) {
rmtree($workdir);
}
}
# individual work directory to make parallel tests possible
$workdir = tempdir("$tname.XXXXXX", DIR => "log");
die "FATAL: failed to create workdir: $!" unless -d $workdir;
chmod (0755, $workdir); # sometimes tempdir() ignores umask
$keep_workdir = 0;
# $siterules contains all stock *.pre files
$siterules = "$workdir/siterules";
# $localrules contains all stock *.cf files
$localrules = "$workdir/localrules";
# $userrules contains user rules
$userrules = "$workdir/user.cf";
# user_state directory
$userstate = "$workdir/user_state";
mkdir($siterules) or die "FATAL: failed to create $siterules\n";
mkdir($localrules) or die "FATAL: failed to create $localrules\n";
open(OUT, ">$userrules") or die "FATAL: failed to create $userrules\n";
close(OUT);
mkdir($userstate) or die "FATAL: failed to create $userstate\n";
$spamd_pidfile = "$workdir/spamd.pid";
$spamd_cf_args = "-C $localrules";
$spamd_localrules_args = " --siteconfigpath $siterules";
$scr_localrules_args = " --siteconfigpath $siterules";
$salearn_localrules_args = " --siteconfigpath $siterules";
$scr_cf_args = "-C $localrules";
$scr_pref_args = "-p $userrules";
$salearn_cf_args = "-C $localrules";
$salearn_pref_args = "-p $userrules";
$scr_test_args = "";
$salearn_test_args = "";
$set_user_prefs = 0;
$default_cf_lines = "
bayes_path ./$userstate/bayes
auto_welcomelist_path ./$userstate/auto-welcomelist
";
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;
}
$NO_SPAMC_EXE = $TEST_DOES_NOT_RUN_SPAMC_OR_D ||
($RUNNING_ON_WINDOWS &&
!$ENV{'SPAMC_SCRIPT'} &&
!(-e "../spamc/spamc.exe"));
$SKIP_SPAMC_TESTS = ($NO_SPAMC_EXE ||
($RUNNING_ON_WINDOWS && !$ENV{'SPAMD_HOST'}));
$SSL_AVAILABLE = (!$TEST_DOES_NOT_RUN_SPAMC_OR_D) &&
(!$SKIP_SPAMC_TESTS) && # no SSL test if no spamc
(!$SKIP_SPAMD_TESTS) && # or if no local spamd
(untaint_cmd("$spamc -V") =~ /with SSL support/) &&
(untaint_cmd("$spamd --version") =~ /with SSL support/);
for $tainted (<../rules/*.pm>, <../rules/*.pre>, <../rules/languages>) {
$tainted =~ /(.*)/;
my $file = $1;
$base = basename $file;
copy ($file, "$siterules/$base")
or warn "cannot copy $file to $siterules/$base: $!";
}
for $tainted (<../rules/*.cf>) {
$tainted =~ /(.*)/;
my $file = $1;
$base = basename $file;
copy ($file, "$localrules/$base")
or warn "cannot copy $file to $localrules/$base: $!";
}
copy ("data/01_test_rules.pre", "$localrules/01_test_rules.pre")
or warn "cannot copy data/01_test_rules.cf to $localrules/01_test_rules.pre: $!";
copy ("data/01_test_rules.cf", "$localrules/01_test_rules.cf")
or warn "cannot copy data/01_test_rules.cf to $localrules/01_test_rules.cf: $!";
open (PREFS, ">>$localrules/99_test_default.cf")
or die "cannot append to $localrules/99_test_default.cf: $!";
print PREFS $default_cf_lines
or die "error writing to $localrules/99_test_default.cf: $!";
close PREFS
or die "error closing $localrules/99_test_default.cf: $!";
$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 40000 and 65520; used to allow multiple test
# suite runs on the same machine simultaneously
sub probably_unused_spamd_port {
return 0 if $SKIP_SPAMD_TESTS;
my $port;
my @nstat;
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);
}
for (1..20) {
$port = 40000 + int(rand(65500-40000));
last unless (getservbyport($port, "tcp") || grep(/[:.]$port\s/, @nstat));
}
return $port;
}
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 delimiter 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;
}
# Simple version of untaint_var for internal use
sub untaint_var {
local($1);
$_[0] =~ /^(.*)\z/s;
return $1;
}
# untainted system()
sub untaint_system {
my @args;
push @args, untaint_var($_) foreach (@_);
return system(@args);
}
# untainted version of `shell command`
sub untaint_cmd {
if (open(CMD, untaint_var($_[0])."|")) {
my $stdout = do { local($/); <CMD> };
close CMD;
return $stdout;
} else {
return "";
}
}
END {
# Cleanup workdir (but not if inside forked process)
if (defined $workdir && !$keep_workdir && $$ == $mainpid) {
rmtree($workdir);
}
}
1;