emacs/mps/qa/test/script/headread

#!/usr/local/bin/perl
#
# 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) = @_;
 
 unless (open(IN, $infile)) {
  die "File ".$infile." not found.";
 }

 $_ = "";
 while (! /TEST_HEADER/) {
  ($_ = <IN>) || die "Couldn't find start of test header in $infile.\n";
 }
 s/.*TEST_HEADER//;
 $line = $_;
 while (! /END_HEADER/) {
  ($_ = <IN> || die "Couldn't find end of test header in $infile.\n");
  chop;
  $line = $line."; ".$_;
 }
 $line =~ s/END_HEADER.*//;

 if ($line =~ /OUTPUT_SPEC/) {
  $line =~ /(.*)OUTPUT_SPEC(.*)/;
  $header = $1;
  $outspec = $2;
 } else {
  &debug("No output specification -- assuming result=pass required.");
  $header = $line;
  $outspec = "result=pass";
 }

 &readvals($header, "=");
 %test_header = %keyvalues;

 &readvals($outspec, "=|<|>|<=|>=");
 %spec_output = %keyvalues;
 %spec_rel    = %keyrelations;

 close(IN);
}

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);

 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 (/MPS ASSERTION FAILURE/) {
# MPS assertion failure
   $real_output{"assert"} = "true";
   $_=<LOGFILE>; $_=<LOGFILE>; /Id:\s*(.*)$/;
   $real_output{"assertid"} = $1;
   $_=<LOGFILE>; /File:\s*(.*)$/;
   $real_output{"assertfile"} = $1;
   $_=<LOGFILE>; /Line:\s*(.*)$/;
   $real_output{"assertline"} = $1;
   $_=<LOGFILE>; /Condition:\s*(.*)$/;
   $real_output{"assertcond"} = $1;
   $_ = "%";
  } 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);
}

#
# &verdict has the job of setting $testconclusion, $testconcreason
#

sub verdict {
 local ($key, $act, $ope, $spe);

 $testconclusion = "PASS";
 $testconcreason = "";

 foreach $key (keys %spec_output) {
  $act = ($real_output{$key} || "NONE");
  $acn = ($real_output{$key} || 0);
  $ope = $spec_rel{$key};
  $spe = $spec_output{$key};
&debug("require: $key: $act $ope $spe");
  if ($ope eq "=" && $spe ne $act
   || $ope eq "<" && $spe <= $acn
   || $ope eq ">" && $spe >= $acn
   || $ope eq "<=" && $spe < $acn
   || $ope eq ">=" && $spe > $acn) {
   $testconclusion = "FAIL";
   $testconcreason = "failed on $key: wanted $ope $spe, was $act";
   last;
  }
 }
}