#!/usr/bin/perl -w
# $Id: //info.ravenbrook.com/project/mps/master/test/test/script/headread#13 $
#
# subroutines to assist in
# 1. reading test headers
# 2. reading test output
# 3. making pass/fail decision
#
# [returns 1 to make perl happy]
1;
# Example header:
#
# ... TEST_HEADER
# summary=try lots of allocation to provoke errors
# language=c; link=testlib.o
# OUTPUT_SPEC
# alloc=OK
# size1>20
# END_HEADER ...
#
# information is stored in associative arrays:
# %test_header
# %spec_output
# %spec_rel
#
# analysing results gives
# %real_output, like %spec_output
#
# $test_header{key} = value;
# $spec_output{key} = value;
# $spec_rel{key} = relation;
#
#
sub readheader {
local($infile, $parms) = @_;
unless (open(IN, $infile)) {
die "File ".$infile." not found.";
}
$_ = "";
while (! /TEST_HEADER/) {
defined($_=<IN>) || die "Couldn't find start of test header in $infile.\n";
}
s/.*TEST_HEADER//;
$line = $_;
while (! /END_HEADER/) {
defined($_=<IN>) || die "Couldn't find end of test header in $infile.\n";
chomp;
if ($line =~ /\\$/) {
chop($line);
$line = $line.$_;
} else {
$line = $line."; ".$_;
}
}
$line =~ s/END_HEADER.*//;
if ($line =~ /OUTPUT_SPEC/) {
$line =~ /(.*)OUTPUT_SPEC(.*)/;
$header = $1;
$outspec = $2;
} else {
&debug("No output specification -- assuming completed=yes required.");
$header = $line;
$outspec = "completed = yes";
}
&readvals($header, "=");
%test_header = %keyvalues;
&readvals($outspec, "=~|<=|>=|=|<|>|P=");
%spec_output = %keyvalues;
%spec_rel = %keyrelations;
close(IN);
if ($parms) {
&get_parmdefs();
}
if (! exists $test_header{"id"}) {
$test_header{"id"} = "<no id given>";
$testid = "$infile";
} else {
$testid = $test_header{"id"};
}
if (length($testid) > 70) {
$testid = substr($testid, 0, 33) . "..." . substr($testid, -33);
}
if (! exists $test_header{"harness"}) {
$test_header{"harness"} = "1.0";
}
if (-w $infile) {
$test_header{"id"} .= " (but the file is writeable)";
$testid = "$infile (writeable)";
}
#
# Compatibility with old tests
# -- convert result=pass to completed=yes
#
if (vleq($test_header{"harness"}, "1.0") && exists $spec_output{"result"}) {
if ($spec_output{"result"} eq "pass") {
$spec_output{"completed"} = "yes";
} elsif ($spec_output{"result"} eq "fail") {
$spec_output{"completed"} = "no";
} else {
$spec_output{"completed"} = $spec_output{"result"};
}
$spec_rel{"completed"} = $spec_rel{"result"};
delete $spec_output{"result"};
delete $spec_rel{"result"};
}
# If the test case specifies neither completion nor failure, assume
# completion is intended.
my @expected_keys = qw(completed assert abort assert_or_abort errtext);
my $have_expected = 0;
foreach $key (@expected_keys) {
if (exists $spec_output{$key}) {
$have_expected = 1;
}
}
if (!$have_expected) {
$spec_output{"completed"} = "yes";
$spec_rel{"completed"} = "=";
}
}
sub readvals {
local ($_, $relations) = @_;
%keyvalues = ();
%keyrelations = ();
s/([^\\]);/$1;;/g;
foreach (split(/\s*;;\s*/)) {
s/\\(\\|;)/$1/g;
if (m/^\W*(\w+)\s*($relations)\s*(.+)\s*/) {
$keyvalues{$1} = $3;
$keyrelations{$1} = $2;
} else {
unless (m/^\W*/) {
print "Bad header item: ".$_." in $infile.\n";
}
}
}
}
#
# &read_results reads in a log file and sets up %real_output
# as appropriate
#
sub read_results {
local ($logfile) = @_;
&debug("read_results >$logfile<");
open(LOGFILE, $logfile);
%real_output = ("seconds", $testtotaltime);
$testtimeline = &logtimeline($testtotaltime);
while (<LOGFILE>) {
&debug($_);
if (/^!/) {
# result variable
if (/^!(\w+)\s*=\s*(.+?)\s*$/) {
$real_output{$1} = $2
} else {
die "Badly formatted result line in output:\n$_\n";
}
} elsif (/Abort trap|abnormal program termination|Segmentation fault/) {
# abort for other reason
$real_output{"abort"} = "true";
$real_output{"assert_or_abort"} = "true";
} elsif (/^%/ || /^\s$/) {
# comment or blank line
} else {
die "Unexpected line in output:\n$_\n";
}
}
close(LOGFILE);
#
# Compatibility with old tests
# -- convert result=pass/fail to completed=yes/no
#
if (vleq($test_header{"harness"}, "1.0") && exists $real_output{"result"}) {
if ($real_output{"result"} eq "pass") {
$real_output{"completed"} = "yes";
} elsif ($real_output{"result"} eq "fail") {
$real_output{"completed"} = "no";
} else {
$real_output{"completed"} = $real_output{"result"};
}
delete $real_output{"result"};
}
}
#
# filenames_differ takes 2 filenames and returns false iff all of the
# first filename matches with the tail components of the second
# filename. All standard directory separators are permitted (\/:)
#
sub filenames_differ {
local($fname1, $fname2) = @_;
@f1 = split(m;[/:\\];, $fname1);
@f2 = split(m;[/:\\];, $fname2);
$i1 = $#f1;
$i2 = $#f2;
while ($i1 >= 0 && $i2 >= 0) {
if ($f1[$i1] ne $f2[$i2]) {
# return true if names components don't match
return(1);
}
$i1--;
$i2--;
}
# return true if not all of @f1 has been checked
return($i1 >= 0)
}
#
# &verdict has the job of setting $testconclusion, $testconcreason
#
sub verdict {
local ($key, $act, $ope, $spe);
$testconclusion = "PASS";
$testconcreason = "";
foreach $key (sort keys %spec_output) {
$ope = $spec_rel{$key};
$spe = $spec_output{$key};
if (defined($real_output{$key})) {
$acn = $real_output{$key};
&debug("require: $key: $acn $ope $spe");
if ($ope eq "=" && $spe ne $acn
|| $ope eq "=~" && $acn !~ /$spe/
|| $ope eq "<" && $spe <= $acn
|| $ope eq ">" && $spe >= $acn
|| $ope eq "<=" && $spe < $acn
|| $ope eq ">=" && $spe > $acn
|| $ope eq "P=" && filenames_differ($spe, $acn)) {
$testconclusion = "FAIL";
$testconcreason = "failed on $key: wanted $ope $spe, was $acn";
last;
}
} else {
$testconclusion = "FAIL";
$testconcreason = "failed on $key: wanted $ope $spe, was absent";
last;
}
}
}
#
# &get_parmdefs gets parameter definitions from the environment, as
# specified in the test header
#
sub get_parmdefs {
local ($var, $missing, $val);
$missing = "";
%parmdefs = ();
if ($VARIETY eq "hot") {
$parmdefs{CONFIG_VAR_HOT} = 1;
} elsif ($VARIETY eq "cool") {
$parmdefs{CONFIG_VAR_COOL} = 1;
} elsif ($VARIETY eq "rash") {
$parmdefs{CONFIG_VAR_RASH} = 1;
}
if (exists $test_header{"parameters"}) {
foreach (split /\s+/, $test_header{"parameters"}) {
($_, $val) = split /=/, $_;
$var = getparameter($_);
if (defined $var) {
$parmdefs{$_} = $var;
} elsif (defined $val) {
$parmdefs{$_} = $val;
} else {
$missing .= "\n ".$_.",";
}
}
if ($missing ne "") {
chop $missing;
die "Unspecified test parameters:$missing.\n";
}
}
}