emacs/mps/qa/test/script/headread

#!/usr/local/bin/perl
# $HopeName: MMQA_harness!script:headread(trunk.18) $
#
# 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";
  chop;
  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 (! 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"};
 }
}

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|^abnormal program termination/ ) {
# abort for other reason
   $real_output{"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 (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 (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";
  }
 }
}