#!/usr/bin/perl5
#
# "antest"	K. J. Turner	20/08/98
#
# This script takes a filename on the command line. "file.lot" should contain
# the LOTOS description generated by ANISE. "file.antest" should contain tests
# defined in the ANISE scenario language. Tests are generated from this and
# appended to the main LOTOS file. If there are existing tests the user is
# prompted to replace, extend or leave these.
# 
# Command-line options are:
# 
#   -h		print help 
# 
#   -i		interactive (prompt to replace tests, no topo), default batch
# 
#   -m N	memory in Mbytes for testing, default 5 Mb
# 
# The script assumes certain formats for the LOTOS generated by ANISE:
# 
#   specification SpecName [GateName]	format of specification header
# 
#   OnHookCon : 			format of confirm primitive function
# 
#   OnHookRes : 			format of response primitive function
# 
#   Prof (Num(1)+2+4, Id(5)+4		format of number/id in profile
# 
#   process TestNNN			format of test process header

############################### Initialisation ###############################

use Getopt::Std;				# get options module

################################ Main Program ################################

&init;						# initialise program
&do_tests;					# make and execute tests
&finalise;					# finalise program

################################ Subroutines ################################

# initialise program

sub init {
  $prog = $0;					# set program name
  $prog =~ s/.*\///g;				# strip off pathname
  $code = 0;					# error result code
  $ani_ext = ".anise";				# ANISE extension
  $lot_ext = ".lot";				# LOTOS extension
  $prc_ext = ".anproc";				# LOTOS test process extension
  $tst_ext = ".antest";				# ANISE test extension
  $log_ext = ".log";				# ANISE test result log
  $home = $ENV{'HOME'};				# set home directory
  $tmp_dir = "$home/.NeXT/.NextTrash"; 		# trash directory
  $test_no = 0;					# latest test number
  $lotos_ignore = 0;				# 1 = do not copy LOTOS input
  $test_seen = 0;				# 1 = test text started
  $defs = "";					# m4 macro definitions
  $SIG{INT} = \&prog_int;			# interrupt handler
  $SIG{QUIT} = \&prog_int;			# interrupt handler
  $succ_gate = "OK";				# succes gate in tests
  if (!getopts ('him:')) {			# command argument error?
    &usage;					# print usage
  }
  if ($opt_h) {					# print help?
    &usage;					# print usage
  }
  if ($opt_m ne "") {				# Mbytes given?
    $mb = $opt_m + 0;				# get Mbytes as number
    $mb = int ($mb + 0.5);			# get Mbytes as integer
    if ($mb <= 0) {				# not positive Mbytes?
      print STDERR "$prog: Mbytes must be positive\n";
      &usage;					# print usage
    }
  }
  else {					# use default Mbytes
    $mb = 5;
  }
}

# handle program interrupt

sub prog_int {
  &fail ("abandoned");				# report interrupt
}

# print usage information

sub usage {
  printf STDERR "usage: $prog [-h(elp)] [-i(nteractive)] [-m(bytes) int] file\n";
  exit (1);
}

# print log dividing line

sub log_divide {
  printf LOG_OUT "++++++++++++++++++++++++++++++++++++++";
  printf LOG_OUT "++++++++++++++++++++++++++++++++++++++\n\n";
}

# return word with initial letter of each sub-word capitalised

sub capof {
  my ($name) = @_;				# get name
  $name = "\u$name";				# capitalise first letter
  $name =~					# capitalise sub-words
    s/(announce|back|busy|\bcall|hook|mess|ring|tone|wait)/\u$1/g;
  return ($name);				# return new name
}

# convert LOTOS-format number as parameter to normal as result

sub numof {
  my ($num) = @_;				# get number
  if ($num =~ /(\w+)\s*\((.*)\)/) {		# number prefix?
    $pref = capof ($1); $num = $2;		# extract prefix and number
    $num =~ s/[^0-9SH]//ig;			# leave only digits/S/H
    $num =~ s/S/\*/ig;				# convert S to *
    $num =~ s/H/\#/ig;				# convert H to #
    return ("$pref($num)");			# return prefix/number string
  }
  else {
    $num =~ s/[^0-9SH]//ig;			# leave only digits/S/H
    $num =~ s/S/\*/ig;				# convert S to *
    $num =~ s/H/\#/ig;				# convert H to #
    return ($num);				# return number string
 }
}

# convert LOTOS-format octet string to characters

sub strof {
  my ($oct) = @_;				# get octet string
  my $str;					# string result
  $oct =~ s/\D//g;				# leave only digits
  $str = "";					# initialise string result
  while ($oct =~ /(.)(.)(.)(.)(.)(.)(.)(.)(.*)/) { # 8 bits?
    $bin = ($1<<7)|($2<<6)|($3<<5)|($4<<4)|($5<<3)|($6<<2)|($7<<1)|$8;
    $oct = $9;					# update octet string
    $ch = chr ($bin);				# code to character
    $str .= "$ch";
  }
  return ("\"$str\"");				# return string
}

# set up and execute tests

sub do_tests {
  if ($#ARGV != 0) {				# not one argument?
    &usage;					# print usage
  }
  else {					# file name given as argument
    $file = $ARGV [0];				# get file name
    $lot_infile = $file . $lot_ext;		# set LOTOS input file
    $lot_outfile = "$tmp_dir/$prog$$"."$lot_ext"; # LOTOS output file
    $log_outfile = $file . $log_ext;		# set ANISE test log file
    open (LOG_OUT, ">> $log_outfile")		# open ANISE test log file
      || die "$prog: cannot open $log_outfile\n"; # report failure
    $log_tmpfile = "$tmp_dir/$prog$$" . $log_ext; # set ANISE temp. log file
    open (LOT_IN, "< $lot_infile")		# open LOTOS input file
      || die "$prog: cannot open $lot_infile\n"; # report failure
    open (LOT_OUT, "> $lot_outfile")		# open LOTOS output file
      || die "$prog: cannot open $lot_outfile\n"; # report failure
    while (<LOT_IN>) {				# read LOTOS file line
      if (/specification (\w*) \[(\w*)\]/) {	# specification start?
	$spec = $1;				# extract overall spec name
	$gate = $2;				# extract overall gate name
      }
      elsif (/(\w*)(Con|Res) : /) {		# confirm/response prim?
	$defs .= "-D an_$1$2 ";			# define primitive existence
      }
      elsif (/Prof \(Num\((\d)\)([^,]*), Id\((\d)\)([^,]*),/) { # profile?
	$num = $1 . $2;				# extract number
	$num =~ tr/\+//d;			# remove pluses
	$id = $3 . $4;				# extract identifier
	$id =~ tr/\+//d;			# remove pluses
	if (!exists ($idnum{$id})) {		# identifier not already seen?
	  $idnum{$id} = $num;			# set number for identifier
	}
	$numid{$num} = $id;			# set identifier for number
      }
      elsif (/process (Test_\w*)/) {		# test process?
	$test_proc = $1;			# set test process name
	if (!$lotos_ignore) {			# including LOTOS?
	  if (!$test_no) {			# first test process?
	    if ($opt_i) {			# interactive operation?
	      print STDERR "$prog: tests exist - r(eplace)/e(xtend)/l(eave)? ";
	      $ans = <STDIN>;			# read answer y/n
	      if (($ans =~ /^\n/) || ($ans =~ /^r/i)) { # replace tests?
		$lotos_ignore = 1;		# ignore existing tests
	      }
	      elsif ($ans =~ /^e/i) {		# extend tests?
	      }
	      else {				# leave tests
		$code = 1;			# set error result code
		last;				# leave loop
	      }
	    }
	    else {				# non-interactive - replace
	      $lotos_ignore = 1;		# ignore existing tests
	    }
	  }
	}
	if (!$lotos_ignore) {			# including LOTOS?
	  $test_procs[$test_no++] = "$test_proc"; # append test process name
	}
      }
      elsif (/^endspec/) {			# end of specification?
	$endspec = $_;				# save end line
        &get_profs;				# define profile parameters
	&incl_tests;				# include test processes
	$_ = "\n$endspec";			# set current line
	$lotos_ignore = 0;			# include LOTOS input
      }
      if (!$lotos_ignore) {			# including LOTOS input?
	print LOT_OUT $_;			# output current line
      }
    }
    close (LOT_OUT);				# close LOTOS output file
    close (LOT_IN);				# close LOTOS input file
    unlink ($tst_outfile, $prc_outfile);	# remove temporary files
    if ($code == 0) {				# no problems?
      rename ($lot_outfile, $lot_infile);	# update LOTOS input file
      if (!$opt_i) {				# non-interactive?
	&run_tests;				# run tests with LOLA
      }
    }
  }
}

# generate and include ANISE tests

sub incl_tests {
  $tst_infile = $file . $tst_ext;		# set ANISE test input file
  $tst_outfile = "$tmp_dir/$prog$$"."$tst_ext";	# ANISE test output file
  $prc_outfile = "$tmp_dir/$prog$$"."$prc_ext";	# test process output file
  open (AN_IN, "< $tst_infile")			# open ANISE test input file
    || die "$prog: cannot open $tst_infile\n";	# report failure
  open (AN_OUT, "> $tst_outfile")		# open ANISE test output file
    || die "$prog: cannot open $tst_outfile\n";	# report failure
  while (<AN_IN>) {				# read ANISE file line
    s/\s*%.*//;					# remove trailing comment
    if (/^\s*$/) {				# blank line?
      next;					# ignore blank line
    }
    if (/test\((\w*)/) {			# test starts?
      $test_proc = "Test_$1";			# set test process name
      $test_procs[$test_no++] = "$test_proc";	# append test process name
      print AN_OUT $_;				# output current line
    }
    elsif (/(send|recv)\((\d*)/) {		# found phone number?
      if ($numid{$2}) {				# number known?
        print AN_OUT $`, $1, "(", $numid{$2}, $';
      }
      else {					# number unknown
        print STDERR "$prog: number $2 is unknown\n";
      }
    }
    else {					# normal line
      print AN_OUT $_;				# output current line
    }
  }
  close (AN_OUT);				# close ANISE test output file
  close (AN_IN);				# close ANISE test input file
  $defs .= "-D an_gate=$gate";			# m4 definitions
  $cmd = "m4 $defs $tst_outfile > $prc_outfile"; # m4 command to create tests
  if (system ($cmd) != 0) {			# m4 call failed?
    &sound_failure;				# make failure sound
    die ("\n$prog: M4 run not completed\n");	# exit program
  }
  open (PRC_IN, "< $prc_outfile")		# open test process file
    || die "$prog: cannot open $prc_outfile\n";	# report failure
  while (<PRC_IN>) {				# read test process file line
    if ($test_seen) {				# text already seen?
      print LOT_OUT $_;				# output current line
    }
    elsif (/\S/) {				# non-blank line?
      $test_seen = 1;				# note text seen
      print LOT_OUT $_;				# output current line
    }
  }
  close (PRC_IN);				# close test process file
}

# extract and define profiles from ANISE file

sub get_profs {
    $file = $ARGV [0];				# get file name
    $ani_infile = $file . $ani_ext;		# set ANISE input file
    open (ANI_IN, "< $ani_infile")		# open ANISE input file
      || die "$prog: cannot open $ani_infile\n"; # report failure
    $adding = 0;				# note not adding to profile
    while (<ANI_IN>) {				# read ANISE file line
      s/\s*%.*$//;				# remove trailing comment
      if ($adding) {				# adding to profile?
	if (!/\)$/) {				# not end of profile?
	  $pars .= $_;				# append to profile
	}
	else {					# end of profile
	  $adding = 0;				# note not adding to profile
	  chop; chop;				# remove trailing NL and ")"
	  $pars .= $_;				# append to profile
	  $pars =~ s/[\s\n]*//g;		# remove white space
	  $pars =~ s/([a-zA-Z_]+)/[[$1]]/g;	# quote words
	  $pars =~ s/,/|/g;			# make "," into "|"
	  $defs .= "-D 'profile_$num=$pars' ";# define profile for number
	}
      }
      else {					# not adding to profile
	if (/profile\((\d+),\d+\)/) {		# profile with no parameters?
	  $num = $1;				# extract number
	  $defs .= "-D profile_$num= ";		# define profile for number
	}
	if (/profile\((\d+),\d+,(.*)/) {	# profile with parameters?
	  $num = $1; $pars = $2;		# extract number and params
	  if ($pars !~ /\)$/) {			# not end of profile?
	    $adding = 1;			# note adding to profile
	  }
	  else {				# end of profile
	    chop ($pars);			# remove trailing ")"
	    $pars =~ s/[\s\n]*//g;		# remove white space
	    $pars =~ s/([a-zA-Z_]+)/[[$1]]/g;	# quote words
	    $pars =~ s/,/|/g;			# make "," into "|"
	    $defs .= "-D 'profile_$num=$pars' ";# define profile for number
	  }
	}
      }
    }
    close (ANI_IN);				# close ANISE input file
}

# run ANISE tests with LOLA

sub run_tests {
  foreach $test_name (@test_procs) {		# run through tests
    $name = $test_name;				# extract test name
    $name =~ s/Test_//;				# remove prefix
    $name =~ s/_/ /g;				# change underscore to space
    &log_divide;				# print log divider
    printf STDERR "Testing %-30s", "$name ...";	# print test name
    print LOG_OUT "Testing $name\n";		# log test name
    $cmd = "lola $file -l is 2>&1 > $log_tmpfile <<EOF
      TestExpand $succ_gate $test_name -b $mb
      Quit
      EOF";
    $time = (times)[2];				# note current child user time
    $res = system ($cmd);			# call LOLA
    $time = (times)[2] - $time;			# note current child user time
    open (LOG_TMP, "< $log_tmpfile")		# open ANISE temp. log file
      || die "$prog: cannot open $log_tmpfile\n"; # report failure
    $successes = 0; $failures = 0; $invalid = 0; $malformed = 0;
    while (<LOG_TMP>) {				# read temp. log file line
      print LOG_OUT $_;				# permanently log line
      if (/successes = (\d*)/i) {		# success count found
	$successes = $1;			# set success count
      }
      elsif (/stops = (\d*)/i) {		# success count found
	$failures = $1;				# set failure count
      }
      elsif (/Invalid test/i) {			# invalid test found
	$invalid = 1;				# set invalid test
      }
      elsif (/syntax error|errors detected|wrong rewrite/i) { # LOLA error?
	$malformed = 1;				# set malformed test
      }
    }
    close (LOG_TMP);				# close ANISE temp. log file
    if ($malformed) {				# test malformed?
      $result = "Malformed Test";		# malformed test result
    }
    elsif ($invalid) {				# test invalid?
      $result = "Invalid Test";			# invalid test result
    }
    else {					# test valid
      if ($successes) {				# some successes?
	if ($failures) {			# some failures?
	  $result = "Inconclusive";		# may pass result
	}
	else {
	  $result = "Pass";			# must pass result
	}
      }
      else {					# no successes
	  $result = "Fail";			# reject result
      }
    }
    printf STDERR "%-14s%3d succ %2d fail ", $result, $successes, $failures;
    printf LOG_OUT "%-14s%3d succ %2d fail ", $result, $successes, $failures;
    if ($time < 60) {				# print time in seconds?
      printf STDERR "%4.1f secs", $time;
      printf LOG_OUT "%4.1f secs", $time;
    }
    elsif ($time < 3600) {			# print time in minutes
      printf STDERR "%4.1f mins", $time / 60;
      printf LOG_OUT "%4.1f mins", $time / 60;
    }
    else {					# print time in hours
      printf STDERR "%.1f hours", $time / 3600;
      printf LOG_OUT "%.1f hours", $time / 3600;
    }
    print STDERR "\n";				# end test result
    print LOG_OUT "\n";				# end test result
    if ($res != 0) {				# LOLA call failed?
      &sound_failure;				# make failure sound
      die ("\n$prog: LOLA run not completed\n"); # exit program
    }
    elsif (($result eq "Inconclusive") ||	# inconclusive/fail?
        ($result eq "Fail")) {
      &diag_test;				# run diagnostic test
    }
  }
}

# run ANISE test with LOLA to diagnose deadlocks

sub diag_test {
  &sound_failure;				# make failure sound
  &log_divide;					# print log divider
  print STDERR "\n";
  printf LOG_OUT "Diagnosing $name\n";		# log test name
  $cmd = "lola $file -l is 2>&1 > $log_tmpfile <<EOF
    TestExpand $succ_gate $test_name -s -b $mb
    Print -1
    Quit
    EOF";
  if (system ($cmd) != 0) {			# LOLA call failed?
    &sound_failure;				# make failure sound
    die ("\n$prog: LOLA run not completed\n");	# exit program
  }
  open (LOG_TMP, "< $log_tmpfile")		# open ANISE temp. log file
    || die "$prog: cannot open $log_tmpfile\n"; # report failure
  $successes = 0; $failures = 0; $invalid = 0; $malformed = 0;
  while (<LOG_TMP>) {				# read temp. log file line
    print LOG_OUT $_;				# permanently log line
    s/(\s*)\(/$1 /;				# remove leading parenthesis
    if (/(\s*)$gate\s*! (.*) of id ! ([^;]*);/i) { # event found?
      $indent = $1;				# save indent
      $id = $2;					# extract identifier
      $prim = $3;				# extract primitive
      $num = $idnum{numof ($id)};		# set number from identifier
      if ($prim =~ /(\w*)(\w\w\w)\((.*)\)/) {	# primitive with parameter?
	$group = $1;				# extract group
	$role = $2;				# extract role
	$par = $3;				# extract parameter
	if ($par =~ /octet/) {			# LOTOS format octet string?
	  $par = strof ($par);			# convert to string
	}
	elsif ($par =~ /<>/) {			# LOTOS format number?
	  $par = numof ($par);			# convert to normal
	}
	else {					# literal name
	  $par = capof ($par);			# capitalise name
	}
      }
      else {					# no primitive parameter
	$prim =~ /(\w*)(\w\w\w)/;		# extract group and role
	$group = $1;				# extract group
	$role = $2;				# extract role
	$par = "";				# no parameter
      }
      $group = capof ($group);			# capitalise group
      if (($role eq "req") || ($role eq "res")) { # send?
	print STDERR $indent, "send(";		# print "send"
	print LOG_OUT $indent, "send(";		# print "send"
      }
      else {					# receive
	print STDERR $indent, "recv(";		# print "recv"
	print LOG_OUT $indent, "recv(";		# print "recv"
      }
      print STDERR "$num,$group";		# print number/number
      print LOG_OUT "$num,$group";		# print number/number
      if ($par ne "") {				# parameter not empty?
	print STDERR ",$par";			# print parameter
	print LOG_OUT ",$par";			# print parameter
      }
      print STDERR ")\n";			# print end of event
      print LOG_OUT ")\n";			# print end of event
    }
    elsif (/(\s*)i;/) {				# internal event?
      print STDERR $1, "<internal event>\n";
      print LOG_OUT $1, "<internal event>\n";
    }
    elsif (/(\s*)\[\]/) {			# choice?
      print STDERR $1, "or\n";
      print LOG_OUT $1, "or\n";
    }
    elsif (/(\s*)stop $/) {			# stop?
      print STDERR $1, "<failure point>\n";
      print LOG_OUT $1, "<failure point>\n";
    }
  }
  close (LOG_TMP);				# close ANISE temp. log file
  print STDERR "\n";				# end diagnostic output
  print LOG_OUT "\n";				# end diagnostic output
}

# play failure sound (if on NeXT) else beep

sub sound_failure {
  $cmd = "sndplay /NextLibrary/Sounds/Glass.snd";
  if (system ($cmd) != 0) {			# sound not played?
    print "\a";					# beep
  }
}

# play success sound (if on NeXT) else beep twice

sub sound_success {
  $cmd = "sndplay /NextLibrary/Sounds/Rooster.snd";
  if (system ($cmd) != 0) {			# sound not played?
    print "\a\a";				# beep twice
  }
}

# fail program with message

sub fail {
  printf STDERR "$prog: %s\n", @_;		# print error message
  $code = 1;					# set error code
  &finalise;					# finalise program
}

# finalise program

sub finalise {
  &log_divide;					# print log divider
  close (LOG_OUT);				# close ANISE test log file
  unlink ($log_tmpfile);			# remove temporary files
  &sound_success;				# make success sound
  exit ($code);					# exit with result code
}
