package main;
use Cwd;
use Config;
use File::Basename;
use File::Copy;
use File::Path;
use File::Spec;
BEGIN {
our $RUNNING_ON_WINDOWS = ($^O =~ /^(mswin|dos|os2)/oi);
our $SKIP_SPAMD_TESTS = $RUNNING_ON_WINDOWS;
our $NO_SPAMC_EXE;
our $SKIP_SPAMC_TESTS;
our $SSL_AVAILABLE;
}
sub sa_t_init {
my $tname = shift;
if ($tname !~ /spam[cd]/) {
$NO_SPAMD_REQUIRED = 1;
}
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;
$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{'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";
$spamdhost = $ENV{'SPAMD_HOST'};
$spamdhost ||= "127.0.0.1";
$spamdport = $ENV{'SPAMD_PORT'};
$spamdport ||= probably_unused_spamd_port();
$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");
read_config();
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) && (!$SKIP_SPAMD_TESTS) && (`$spamc -V` =~ /with SSL support/) &&
(`$spamd --version` =~ /with SSL support/));
}
mkdir ("log", 0755);
rmtree ("log/user_state");
rmtree ("log/outputdir.tmp");
rmtree ("log/test_rules_copy");
mkdir ("log/test_rules_copy", 0755);
for $file (<../rules/*.cf>, <../rules/*.pm>, <../rules/*.pre>) {
$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.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 $file (<../rules/*.pre>) {
$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");
print PREFS $default_cf_lines;
close PREFS;
open (PREFS, ">>log/test_default.cf"); close PREFS;
mkdir("log/user_state",0755);
$home = $ENV{'HOME'};
$home ||= $ENV{'WINDIR'} if (defined $ENV{'WINDIR'});
$cwd = getcwd;
$ENV{'TEST_DIR'} = $cwd;
$testname = $tname;
$current_user = (getpwuid($>))[0];
}
sub probably_unused_spamd_port {
return 0 if $NO_SPAMD_REQUIRED;
my $port;
my @nstat = ();
if (open(NSTAT, "netstat -a -n 2>&1 |")) {
@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 {
}
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;
open (OUT, ">log/tst.cf") or die;
print OUT $lines; close OUT;
$scr_pref_args = "-p log/tst.cf";
}
sub tstpre {
my $lines = shift;
open (OUT, ">log/localrules.tmp/zz_tst.pre") or die;
print OUT $lines; close OUT;
}
sub sarun {
my $args = shift;
my $read_sub = shift;
my $post_redir = '';
$args =~ s/ 2\>\&1$// and $post_redir = ' 2>&1';
rmtree ("log/outputdir.tmp"); mkdir ("log/outputdir.tmp", 0755);
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";
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;
}
sub salearnrun {
my $args = shift;
my $read_sub = shift;
rmtree ("log/outputdir.tmp"); mkdir ("log/outputdir.tmp", 0755);
%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";
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 spamcrun {
my $args = shift;
my $read_sub = shift;
my $capture_stderr = 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 ($sa_exitcode != 0) { stop_spamd(); return undef; }
%found = ();
%found_anti = ();
&checkfile ("d.$testname/out.${Test::ntest}", $read_sub) if (defined $read_sub);
($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 start_spamd {
die "NO_SPAMD_REQUIRED in start_spamd! oops" if $NO_SPAMD_REQUIRED;
return if $SKIP_SPAMD_TESTS;
my $spamd_extra_args = shift;
return if (defined($spamd_pid) && $spamd_pid > 0);
rmtree ("log/outputdir.tmp"); mkdir ("log/outputdir.tmp", 0755);
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,
);
}
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}"; 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{&},
);
unlink ($spamd_stdout, $spamd_stderr, $spamd_stdlog);
print ("\t${spamd_cmd}\n");
system ($spamd_cmd);
$spamd_pid = 0;
my $retries = 20;
my $wait = 0;
while ($spamd_pid <= 0) {
my $spamdlog = '';
if (open (IN, "<${spamd_stderr}")) {
while (<IN>) {
/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\n";
return 0;
}
}
1;
}
sub stop_spamd {
die "NO_SPAMD_REQUIRED in stop_spamd! oops" if $NO_SPAMD_REQUIRED;
return 0 if ( defined($spamd_already_killed) || $SKIP_SPAMD_TESTS);
$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");
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;
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,
);
foreach my $arg (keys %$args) {
$setup_args{$arg} = $args->{$arg};
}
require Mail::SpamAssassin;
my $sa = Mail::SpamAssassin->new(\%setup_args);
return $sa;
}
sub checkfile {
my $filename = shift;
my $read_sub = shift;
if (!open (IN, "< log/$filename")) {
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;
$pat = quotemeta($pat);
$pat =~ s/\\\s/\\s\*/gs;
$pat;
}
sub patterns_run_cb {
local ($_);
my $string = shift;
if (defined $string) {
$_ = $string;
} else {
$_ = join ('', <IN>);
}
$matched_output = $_;
foreach my $pat (keys %patterns) {
if ($patterns{$pat} eq '') {
$patterns{$pat} = $pat;
}
}
foreach my $pat (sort keys %patterns) {
my $safe = pattern_to_re ($pat);
if ($_ =~ /${safe}/s) {
$found{$patterns{$pat}}++;
}
}
foreach my $pat (sort keys %anti_patterns) {
my $safe = pattern_to_re ($pat);
if ($_ =~ /${safe}/s) {
$found_anti{$anti_patterns{$pat}}++;
}
}
}
sub ok_all_patterns {
my ($dont_ok) = shift;
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\n";
}
} else {
warn "\tNot found: $type = $pat\n";
if (!$dont_ok) {
ok (0); }
$wasfailure++;
}
}
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\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";
return 0;
} else {
return 1;
}
}
sub skip_all_patterns {
my $skip = shift;
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\n";
warn "\tThis test should have been skipped: $skip\n" if $skip;
} else {
if ($skip) {
warn "\tTest skipped: $skip\n";
} else {
warn "\tNot found: $type = $pat\n";
}
skip ($skip, 0); }
}
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\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;
my $prefix = '';
if (-f 't/test_dir') { $prefix = "t/"; }
if (!open (CF, "<${prefix}config")) {
if (!open (CF, "<${prefix}config.dist")) { die "cannot open test suite configuration file 'config.dist'";
}
}
while (<CF>) {
s/ /^([^=]+)=(.*)$/ or next;
$conf{$1} = $2;
}
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); return ($val+0) if ($val =~ /^\d/); return 0; }
sub mk_safe_tmpdir {
return $safe_tmpdir if defined($safe_tmpdir);
my $dir = File::Spec->tmpdir() || 'log';
my $retries = 10;
my $tmp;
while (1) {
$tmp = "$dir/satest.$$.".rand(99999);
if (!-d $tmp && mkdir ($tmp, 0755)) {
if (-d $tmp && -o $tmp) { lstat($tmp);
if (-d _ && -o _) { last; }
}
}
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) = @_;
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"; 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 dbgprint { print STDOUT "[".time()."] ".$_[0]; }
1;