# -*-Fundamental-*-
#
# Copyright (c) 1996 Network Appliance, Inc.
#
# You may distribute under the terms of the Artistic License, as
# specified in the README file included in the ttt distribution.
#
$ttt_vers .= "\$Id: //depot/tools/main/p4bench/tttLib.pl#1 $/";
# tttLib.pl
###########################################################################
#
# tttLib.pl
#
# Richard Geiger
# November 1993
#
# General support functions for the ttt Tools driver scripts.
#
# The following group of subroutines comprise a "package" (though they are
# not currently implemented a a separate perl "package") that provides
# services for "declaring" the options that a ttt test supports.
# There can be N "major framework" variants managed by ttt. Some code
# in the libraries is conditional upon which framework is in use. The
# client of the libraries declares which it wants to use by setting
# the global $ttt_framework before the standard preamble.
#
if (! defined($ttt_framework)) { $ttt_framework = "generic"; }
# The following routines are for convenience in testing which
# framework is desired by the client:
#
sub generic { return ($ttt_framework eq "generic"); }
# The following data structures are central to the services it provides:
#
# The associative array %opts is keyed by the option names. Options
# are embodied as global variables available throughout the client
# script. Each element in %opts contains either the null string,
# indicating that the named option is a boolean, or a string giving a
# regular expression constraining the value of the multivalued
# option.
#
# A second, "multidimensional" associative array, %opt, contains
# additional information about each option. (There are two
# associative arrays simply to allow use of "keys(%opts)" to get the
# list of option names.) It contains, for each option:
#
# $opt{$optname,"def"} The hard-wired default value for the option
# $opt{$optname,"use"} The options message line for the option
# $opt{$optname,"1st"} A special "first time only" alternate value.
#
# Options are "declared" by calling the &ttt_add_opt function (see
# below). This function adds the required entries to the %opt and
# %opts arrays.
#
# "Declaring" an option in this way incorporates the option into the
# options message, and implements the standard method for assigning
# the option value: (in order of precedence:)
#
# 1. From the command line;
# 2. From the environment;
# 3. Via an interactive user prompt (if the =interactive option is set);
# 4. From the hard-wired default.
#
# The option is also placed into the environment as a variable of the
# same name, for use by children processes of the test (applies to
# UNIX only).
#
# Option names should be valid shell variable identifiers, of 14 or
# less characters.
#
# Options can be either multivalued or boolean.
#
# Option values cannot contain literal newlines.
#
# Note for the pathologically curious:
#
# The code used to implement these "options" features uses lots of
# "evals", and the quoting gets ugly. In many places the following
# form is used, to protect against option values containing '"'s:
#
# eval <<
# \$$opt = qq
# $val <- The newline here ends "qq"
# <- This empty line ends "<<"
# ; <- terminates the eval
#
# There are two quotes involved here: a "<<" quote with a null
# identifier as the delimiter, around a "qq" quote with a newline as
# a delimiter. This makes the empty line necessary, to delimit the
# "<<" quote. It's funny looking, but necessary; otherwise, "$val"
# would have to be quoted with some character which then wouldn't be
# allowed in option values. With this approach, the only character
# that must be prohibited in an option value is the literal newline
# itself.
# &ttt_add_opt("optname", "[re]", "default", "usage");
#
# > "optname" Name of the option being "declared"
# > "[re]" Validation regex, or "" for boolean options
# > "default" Default value; (0 or 1 for boolean options)
# > "usage" option description line, <= 50 chars
# < (void)
#
# The option named "optname" is declared as an option for this test
# program.
#
sub ttt_add_opt
{
local ($name, $mval, $def, $use) = @_;
local ($qname, $qmval, $qdef, $quse);
($qname = $name) =~ s/"/\"/g;
($qmval = $mval) =~ s/"/\"/g;
($qdef = $def) =~ s/"/\"/g;
($quse = $use) =~ s/"/\"/g;
eval <<""
\$opts{"$qname"} = "$qmval"
;
eval <<""
\$opt{"$qname","use"} = "$quse";
;
if ($mval)
{ eval <<""
\$opt{"$name","def"} = "$qdef"
; }
else
{
eval <<""
\$opt{"$qname","def"} = $qdef
;
}
}
# &ttt_opts()
#
# < (void)
#
# This function defines the options that will be present globally for
# all ttt tests. It also calls back to the test's &opts() function to
# pick up the definitions of the test's own option set.
#
sub ttt_opts
{
# Each framework can have it's own set of base options...
#
if ( (defined ($ttt_framework)) && $ttt_framework ne "No_opts")
{ require "$tttroot/ttt_${ttt_framework}_opts.pl"; }
&opts; # pick up the test's own options.
}
# &ttt_options_line("optname", "usage")
#
# > "optname" option name
# > "usage" option description for usage line, <= 50 chars
# < (void)
#
# Prints an options message line for one option.
#
sub ttt_options_line
{
local($optname, $optuse) = @_;
&ttt_msg("", sprintf(" %-20s %-50s\n", $optname, $optuse));
}
# &ttt_desc()
#
# < (void)
#
# Displays the test's description message. (If it has one!)
#
sub ttt_desc
{
if (defined($desc))
{
&ttt_msg("desc", "\n");
&ttt_msg("", "$desc");
}
else { &ttt_msg("(this program has no description message)\n"); }
}
# &ttt_options()
#
# < (void)
#
# Displays the test's options message.
#
sub ttt_options
{
local ($optstr);
&ttt_msg("options", "\n");
&ttt_msg("", "\n");
&ttt_options_line("=options", "show this options message");
if (defined($desc))
{ &ttt_options_line("desc", "show test description"); }
foreach $opt (sort(keys(%opts)))
{
if ($opts{$opt})
{ $optstr = $opt."=<val>"; }
else
{ $optstr = "[=/-]".$opt; }
&ttt_options_line($optstr, $opt{$opt,"use"}." [".$opt{$opt,"def"}."]");
}
&ttt_msg("", "\n");
}
# &ttt_config()
#
# < (void)
#
# This function does the creation of the actual option variables. It is
# driven by the %opts and %opt arrays set up by the calls to &ttt_add_opt.
#
sub ttt_config
{
&ttt_opts; # initialize %opts & %opt arrays
local(@FARGV); # separate out and stash file/directory name arguments here
# command line gets first crack...
arg: while ($#ARGV >= 0)
{
$_ = $ARGV[0];
if (! ($_ =~ /^[=-]|=/)) { push(@FARGV, $_); shift @ARGV; next arg; }
foreach $opt (keys(%opts))
{
if (/^=options$/)
{ &ttt_options; &ttt_exit("notest"); }
elsif (/^=desc$/)
{ &ttt_desc; &ttt_exit("notest"); }
elsif ((! $opts{$opt}) && /^=$opt$/)
{ eval "\$$opt = 1"; shift @ARGV; next arg; }
elsif ((! $opts{$opt}) && /^-$opt$/)
{ eval "\$$opt = 0"; shift @ARGV; next arg; }
elsif ($opts{$opt} && /^$opt=/)
{
($val = $ARGV[0]) =~ s/^${opt}=//;
if ($val !~ /$opts{$opt}/)
{
&ttt_options;
&ttt_notest("ttt_config: bad \"$opt\" value \"$val\"\n");
}
local($qval);
($qval = $val) =~ s/"/\"/g;
eval <<""
\$$opt = "$qval"
;
shift @ARGV; next arg;
}
}
&ttt_msg("error", "unrecognized option: \"$_\"\n"); &ttt_options;
&ttt_exit("notest");
}
@ARGV = @FARGV; # now save file/directory name arguments for later use
if ($#ARGV < 0) # default to "the current directory" if none given to us
{
if ($UNIX) { push(@ARGV, "."); }
if ($MPW) { push(@ARGV, ":"); }
}
# ...then the environment...
foreach $opt (keys(%opts))
{
if (! eval "defined(\$$opt)")
{
if (eval "defined(\$ENV{\"$opt\"})")
{
local($qopt);
($qopt = $opt) =~ s/"/\"/g;
eval <<""
\$$opt = \$ENV{"$qopt"}
;
}
}
}
# ...next, interactive prompting...
if ($interactive)
{
foreach $opt (keys(%opts))
{
if (! eval "defined(\$$opt)")
{
if ($opts{$opt})
{
$ans = &ttt_ask("$opt = ",
$opt{$opt,"def"}."/".$opts{$opt}."/");
local($qans);
($qans = $ans) =~ s/"/\"/g;
eval <<""
\$$opt = "$qans"
;
}
else
{
$ans = (&ttt_ask("$opt = ",
$opt{$opt,"def"} ? "y" : "n", "y", "n") eq "y");
local($qans);
($qans = $ans) =~ s/"/\"/g;
eval <<""
\$$opt = "$qans"
;
}
}
}
}
# ...hardwired defaults get last crack.
foreach $opt (keys(%opts))
{
if (! eval "defined(\$$opt)")
{
local($qopt);
($qopt = $opt) =~ s/"/\"/g;
eval <<""
\$$opt = "$opt{$qopt,"def"}"
;
}
}
# put all our options into the environment:
foreach $opt (keys(%opts))
{
local($qopt);
($qopt = $opt) =~ s/"/\"/g;
eval <<""
\$ENV{$opt} = "\$$qopt"
;
}
}
sub ttt_dirname
{
local($dir) = @_;
$dir =~ s%^$%.%; $dir = "$dir/";
if ($dir =~ m%^/[^/]*//*$%) { return "/"; }
if ($dir =~ m%^.*[^/]//*[^/][^/]*//*$%)
{ $dir =~ s%^(.*[^/])//*[^/][^/]*//*$%$1%; { return $dir; } }
return ".";
}
# &datestamp;
#
# > "yymmddhhmmss"
#
# A string representing the current time in the format shown above is
# returned.
#
sub datestamp
{
($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
sprintf ("%04d-%02d-%02d %02d:%02d:%02d",
$year+1900, $mon+1, $mday, $hour, $min, $sec);
}
# &ttt_msg(["HANDLE", ["tag", ]]"message");
#
# > ["HANDLE"] The name of the file handle to write to
# > ["tag"] Value for the "tag" column in the output
# > "message" The message to be written
# < (void)
#
# This function should be used for all output from a ttt test.
#
# By default, (unless some other handle is given with "HANDLE"), the
# message is written to the STDOUT handle. If the optonal "tag" is given,
# then the tag is printed in a standard sized left-justified field before
# the message proper. Tags are printed in an 8-column field, and so should
# be <= 8 characters.
#
sub ttt_msg
{
local($msg, $type, $HANDLE);
local($pre, $preverb, $msgfmt);
if ($#_ == 0) { ($msg) = @_; $type = " "; $HANDLE = "STDOUT"; }
elsif ($#_ == 1) { ($type, $msg) = @_; $HANDLE = "STDOUT"; }
elsif ($#_ == 2) { ($HANDLE, $type, $msg) = @_; }
else
{ &ttt_notest("ttt_msg: options: ttt_msg([[HANDLE],type,]msg)\n"); }
if (defined($logfile) && $type ne "-q")
{
if ($type eq "-c")
{ $preverb = ""; }
else
{
$preverb = sprintf("%s: %s", &datestamp,
$type eq "" ? "" : sprintf("%-8s: ", "$type"));
}
}
$pre = ($type =~ /^$|^-[cq]$/) ? "" : sprintf("%-8s: ", "$type");
($msgfmt = $msg) =~ s/^/$pre/;
$msgfmt =~ s/\n(.)/\n$pre$1/g; $msgfmt =~ s/\n\n/\n$pre\n/g;
# An attempt to reduce output clutter: only write version information
# (i.e., ttt* run* version information) to the log file...
#
if ($type ne "vers")
{ printf $HANDLE "%s", $msgfmt; }
if (defined($logfile) && $type ne "-q")
{
($msgfmt = $msg) =~ s/^/$preverb/;
$msgfmt =~ s/\n(.)/\n$preverb$1/g; $msgfmt =~ s/\n\n/\n$preverb\n/g;
printf LOGFILE "%s", $msgfmt;
}
}
# &ttt_msg_filt("outfilt");
#
# > "outfilt" The pipeline to attach ttt STDOUT to
# < (void)
#
# This function attaches ttt's STDOUT (the default output data stream for
# &ttt_msg) to a new file or filter.
#
sub ttt_msg_filt
{
local ($filter) = @_;
if (! open(STDOUT, "|$filter"))
{ &ttt_notest("&ttt_msg_filt: can't open to \"$filter\"\n"); }
}
# &ttt_msg_file("outfile");
#
# > "outfilt" The name of the filehandle to send ttt STDOUT
# < (void)
#
# This function attaches ttt's STDOUT (the default output data stream for
# &ttt_msg) to a new file.
#
sub ttt_msg_file
{
local ($file) = @_;
if (! open(STDOUT, ">&$file"))
{ &ttt_notest("&ttt_msg_file: can't open \"$file\"\n"); }
}
# &ttt_log_file("logfile");
#
# > "logfile" The name of the filehandle to send ttt STDOUT
# < (void)
#
# This function arranges for all messages sent via ttt_msg to be written to
# the specified log file as well.
#
sub ttt_log_file
{
local ($file) = @_;
printf TTYO " : logging to: $file\n";
if (defined($logfile)) { close (LOGFILE); }
if (! open(LOGFILE, ">>$file"))
{ &ttt_notest("&ttt_log_file: can't open \"$file\": $!\n"); }
$logfile = $file;
select LOGFILE; $| = 1; select STDOUT;
}
# &ttt_handle()
#
# < (void)
#
# Return a unique filehandle
#
sub ttt_handle
{
local($rethandle);
if (! defined($ttt_handleno)) { $ttt_handleno = 0; } # first time through.
# We reuse these suckers cause we don't know how to deallocate
# them, and if we didn't reuse them, we'd be leakin' memory!
if ($#handles > -1)
{ $rethandle = pop(@handles); }
else
{ $rethandle = sprintf("TTTH%d", $stu_handleno++); }
return $rethandle;
}
sub ttt_closehandle
{
local($H) = @_;
close($H);
push(@handles, $H);
}
# $answer = &ttt_ask("prompt", "default[/re/]"[, [choice] ...]");
#
# > "prompt" A prompt
# > "default[/re/]" The default answer [and validation re]
# > "choice" ... The valid choices
# < $answer The user's answer
#
# This is a utility function for interactive prompting. The indicated
# prompt is printed to the user's tty. The user can press return to
# selected the indicated default, or enter an answer. If the "choice"
# arguments are supplied, then the user's answer must match one of the
# alternative exactly, or the answer is rejected and the user is
# re-prompoted. Otherwise (if only the default is given) the user's answer
# will only be validated if the optional "/re/" part of the the "default"
# argument is given; if no "/re/" part is present, then validation is done,
# whatsoever.
#
sub ttt_ask
{
local(@askargs) = reverse(@_);
local($tmpaskargs, $default, $validre);
if ($#askargs < 1)
{
&ttt_notest(
"ttt_ask: usage: ttt_ask(prompt, default[/re/], [choice] ...\n");
}
$prompt = pop(@askargs);
if (($default = pop(@askargs)) =~ "/.*/\$")
{
($validre = $default) =~ s%^.*/(.*)/$%$1%;
$default =~ s%^(.*)/.*/$%$1%;
}
@tmpaskargs = reverse(@askargs);
@askargs = @tmpaskargs;
if ($#askargs < 0)
{
askit: while (1)
{
if ($default eq "")
{
&ttt_msg(TTYO, "", "$prompt?");
if ($MPW) { printf TTYO "\n"; } if ($UNIX) { printf " "; }
$ans = <TTYI>; chop($ans);
}
else
{
if ($UNIX) { &ttt_msg(TTYO, "", "$prompt [$default]? "); }
if ($MPW) { &ttt_msg(TTYO, "", "$prompt?\n$default"); }
$ans = <TTYI>; chop($ans);
if ($ans eq "") { $ans = $default; }
}
if (defined($validre))
{ if ($ans =~ $validre) { last askit; } }
else
{ last askit; }
&ttt_msg(TTYO, "", "what? (answer must match \"/$validre/\")\n");
}
}
else
{
$choices = join(" ", @askargs);
askit: while (1)
{
if ($UNIX) { &ttt_msg(TTYO, "", "$prompt ($choices) [$default]? "); }
if ($MPW) { &ttt_msg(TTYO, "", "$prompt ($choices)?\n$default"); }
$ans = <TTYI>; chop($ans);
if ($ans eq "") { $ans = $default; }
$ans =~ tr/A-Z/a-z/;
if ($choices =~ /^$ans | $ans | $ans$/) { last askit; }
&ttt_msg(TTYO, "", "what? (please choose from the \"( )\" menu)\n");
}
}
return $ans;
}
# &ttt_exit("pass" | "fail" | "notest" | <something_else>);
#
# This function should be the only way a ttt suite test terminates. It
# defines the known exit statuses. These are (currently):
#
# "pass" (exit status 0): The test passed.
# "fail" (exit status 1): The test failed.
# "notest" (exit status 2): The test program failed.
# <something_else> : Some other exit status value
# (presumably an integer)
#
# The "fail" vs. "nopass" distinction attempts to distinguish failures of
# the object under test from failures of the test program in a consistent
# way.
#
# This function takes care of temp file cleanup, as long as all temp file
# names used were given names beginning with "$tmp.".
#
sub ttt_exit
{
my($exitstat, $extramsg);
my($rmcmd);
#&ttt_msg("DEBUG","tttLib.pl::ttt_exit\n");
if ($#_ == 0) { ($exitstat) = @_; $extramsg = ""; }
elsif ($#_ == 1) { ($extramsg, $exitstat) = @_; $extramsg = ": $extramsg"; }
# Restore the tty settings, just in case...
#
if ($UNIX && $ttt_atty) { system "/bin/stty $tty_settings"; }
if ($UNIX && <${tmp}* $ttt_othercleanup> ne "")
{
if ($tmp eq "") { $rmcmd = "rm -rf ./_tmp_* $ttt_othercleanup"; }
else { $rmcmd = "rm -rf ${tmp}* ./_tmp_* $ttt_othercleanup"; }
}
if ($MPW && <${tmp}> ne "")
{ $rmcmd = "delete ${tmp} $ttt_othercleanup"; }
if (defined($rmcmd)) { &ttt_msg("cleanup", "${rmcmd}\n"); `$rmcmd`; }
if (defined &on_ttt_exit) { &on_ttt_exit; }
&ttt_msg("exit", "$exitstat$extramsg\n");
if ($exitstat eq "pass") { $exitstat = 0; } # Test passed
elsif ($exitstat eq "fail") { $exitstat = 1; } # Test failed
elsif ($exitstat eq "notest") { $exitstat = 2; } # Test invalid
else
{ &ttt_msg("ttt_exit: bad \$exitstat:$exitstat\n"); }
close(STDIN); close(STDOUT); close(STDERR); exit $exitstat;
}
# &ttt_notest("message");
#
# Displayes the given error message, then exists with the "notest"
# status.
#
sub ttt_notest
{ local($msg) = @_; &ttt_msg(STDERR, "error", "$msg"); &ttt_exit("notest"); }
# &ttt_sigterm("SIGNAME");
#
# This is the default signal handler for all catchable signals which by
# default terminate the recipient. First, checks to see whether the ttt
# program has defined a function called "ttt_int_func"; if so, it is
# called. ttt_sigterm then calls &ttt_notest, indicating the name if the
# signal caught.
#
# Since 0, 1, and 2 are taken exit codes in the ttt framework, the
# return value of ttt_int_func will be increased by 2 so that it can
# be differentiatied from the standard exit codes.
#
sub ttt_sigterm
{
local($signame) = @_;
printf "\n"; # (to get past any echoed "^C", etc.)
#&ttt_msg("DEBUG","tttLib.pl::ttt_sigterm\n");
if (defined &ttt_int_func)
{
my ($status) = &ttt_int_func();
&ttt_msg("DEBUG","ttt_sigterm::status:$status\n");
if (!defined($status)) { &ttt_notest("interrupt: SIG$signame\n"); }
else { &ttt_exit("interrupt: SIG$signame", ($status + 2)); }
}
else
{
&ttt_msg("SIG$signame",
"(no user defined ttt interrupt hook installed)\n");
&ttt_notest("interrupt: SIG$signame\n");
}
}
sub basename
{
local($bname) = @_;
if ($UNIX) { $bname =~ s%^.*/%%; }
if ($MPW) { $bname =~ s%^.*:%%; }
return $bname;
}
# Given the vector of values from uname, determine the correct BIN
# (architecture) value...
#
sub ttt_uname_to_bin
{
local($H_OS, $H_HOSTNAME, $H_OSVER, $H_OSREV, $H_ARCH) = @_;
if ($H_OS eq "IRIX" && $H_ARCH =~ /^IP/)
{ return "MIPS"; }
elsif ($H_OS eq "HP-UX" && $H_ARCH =~ /^9000/)
{ return "PARISC"; }
elsif ($H_OS eq "HP" && $H_ARCH eq "1245")
{ return "HP1200"; }
elsif ($H_OS eq "SunOS" && $H_ARCH =~ /^sun4/)
{ return "SPARC"; }
else
{ return "unknown"; }
}
# Given a host name, determine the correct BIN value for the host:
#
sub ttt_host_to_bin
{
local($hostname) = @_;
local($unamecmd);
local($H_OS, $H_HOSTNAME, $H_OSVER, $H_OSREV, $H_ARCH) = @_;
if ($hostname eq $myhostname)
{ $unamecmd = "/bin/uname -a"; }
else
{ $unamecmd = "$tttrsh $hostname \"/bin/uname -a\""; }
return &ttt_uname_to_bin(split(/ /, `$unamecmd"`));
}
# &ttt_init
#
# This is the main entry point to the standard initialization sequence for
# a test in the suite. It is called by the statement at the last line of
# this mainlib file. After performing some standard initialization steps,
# it calls the standard initialization routines provided by the test, which
# in turn call back to some of the standard option initialization functions
# in this file.
#
sub ttt_init
{
$myname = &basename($0);
select STDERR; $| = 1; # unbuffered output on STDERR
select STDOUT; $| = 1; # unbuffered output on STDOUT (leaves STDOUT selected)
# Temp file/directory name convention:
#
# $ttt_tmpdir/$myname.$$.<name>
#
#
# temp directory
#
if ($UNIX)
{
if (defined($ENV{"ttt_tmpdir"})) { $ttt_tmpdir = $ENV{"ttt_tmpdir"}; }
else { $ttt_tmpdir = "$tttroot/tmp"; }
if (! &ttt_insuredir($ttt_tmpdir))
{ &ttt_exit("couldn't make \"$ttt_tmpdir\"", "notest"); }
$tmp = "$ttt_tmpdir/$myname.$$.";
}
if ($MPW)
{
$tmp = ":_tmp_";
}
if ($UNIX)
{
local($login,$passwd,$uid,$gid,$quota,$comment,$gcos,$dir,$shell)
= getpwuid($<);
$ttt_user = $login;
$ttt_home = $dir;
$ttt_username = $gcos;
}
if ($MPW)
{ $ttt_user = `echo -n {user}`; }
if ($UNIX)
{
# set up signal handler
#
$SIG{"HUP"} = "ttt_sigterm";
$SIG{"INT"} = "ttt_sigterm";
$SIG{"QUIT"} = "ttt_sigterm";
$SIG{"TERM"} = "ttt_sigterm";
}
# get the hostinfo variables we may need in order to handle host
# differences, including where to find any binaries needed by the test
# or the suite in general. But only do this once, at the top level.
# (Hence the flag in the environment).
#
if ($UNIX)
{
if (! defined($ENV{"ttt_configged"}))
{
# Get H_* host specification variables into the environment
#
if ( -x "/bin/uname" )
{
($H_OS, $H_HOSTNAME, $H_OSVER, $H_OSREV, $H_ARCH) =
split (/ /,`/bin/uname -a`);
}
else
{ &ttt_notest("ttt_init: no /bin/uname\n"); }
$ENV{"H_OS"} = $H_OS;
$ENV{"H_HOSTNAME"} = $H_HOSTNAME;
$ENV{"H_OSVER"} = $H_OSVER;
$ENV{"H_OSREV"} = $H_OSREV;
$ENV{"H_ARCH"} = $H_ARCH;
$H_BIN = &ttt_uname_to_bin
($H_OS, $H_HOSTNAME, $H_OSVER, $H_OSREV, $H_ARCH);
if (defined($ENV{"EDITOR"})) { $EDITOR = $ENV{"EDITOR"}; }
else { $EDITOR = "vi"; }
if (defined($ENV{"PAGER"})) { $PAGER = $ENV{"PAGER"}; }
else { $PAGER = "more"; }
$ENV{"ttt_configged"} = "yes";
}
else
{
$H_OS = $ENV{"H_OS"};
$H_HOSTNAME = $ENV{"H_HOSTNAME"};
$H_OSVER = $ENV{"H_OSVER"};
$H_OSREV = $ENV{"H_OSREV"};
$H_ARCH = $ENV{"H_ARCH"};
$EDITOR = $ENV{"EDITOR"};
$PAGER = $ENV{"PAGER"};
}
# Pathing/Compatibility sets...
#
# standard directories for all hosts
$path_std ="/bin:/usr/bin:/etc";
# standard ttt directories
$path_ttt =
"$tttroot/bin:$tttroot/bin/$H_BIN:$tttroot/lib:$tttroot/lib/$H_BIN:".
"$tttroot/plan:$tttroot/filt";
# OS-specific directories
($H_OS eq "SunOS") && do
{ $path_os = "/usr/etc:/usr/ucb:/usr/new:/usr/5bin"; };
($H_OS eq "IRIX") && do
{ $path_os = "/usr/bsd:/usr/etc"; };
# master path
$ENV{"PATH"} = "$path_ttt:$path_os:$path_std:$ENV{'PATH'}";
if ($] =~ /^5\./)
{ eval "use Socket"; } else { require "socket.ph"; }
$RD = 1; $WR = 2;
require "$tttroot/tttAgents.pl";
$myhostname = $ENV{"H_HOSTNAME"};
$user = $ENV{"USER"};
# Misc Environment stuff
# XXX: commented out by mlewin 1997-08-28
# $ENV{"CHRCLASS"}= "ascii";
$ttt_atty = (`tty` !~ /^not a tty/);
if ($ttt_atty)
{ $tty_settings = `stty -g`; chop $tty_settings; }
# open /dev/tty (for ttt_ask (at least))
#
if ($UNIX && $ttt_atty)
{
open(TTYO, ">/dev/tty") || die "Can't open TTYO $!"; select TTYO; $| = 1;
open(TTYI, "</dev/tty") || die "Can't open TTYI $!";
select STDOUT; # for subsequent I/O
}
if ($MPW)
{
open(TTYO, ">&STDOUT") || die "Can't open TTYO $!"; select TTYO; $| = 1;
open(TTYI, "<&STDIN") || die "Can't open TTYI $!";
select STDOUT; # for subsequent I/O
}
if ($H_OS eq "HP-UX") { $tttrsh = "remsh"; } else { $tttrsh = "rsh"; }
}
if ($MPW)
{
#require "${tttroot}socket.ph";
require "${tttroot}tttAgents.pl";
$myhostname = "localhost";
$user = `echo {USER}`; chop $user;
}
&ttt_config; # call-back to test's configuration functions
# You can set $logfile to "nologging" before the standard
# preamble if you wish to disable logging.
#
#
if ($logfile eq "nologging")
{ undef $logfile; }
else
{
if ($MPW)
{
if ($logfile eq "") { $logfile = "${tttroot}ttt_log"; }
&ttt_log_file($logfile);
}
if ($UNIX)
{
if ($logfile eq "") { $logfile = "${ttt_home}/ttt_log"; }
&ttt_log_file($logfile);
}
}
$ttt_file_always = 1; # always output file summary (even when 1 case/file).
&ttt_msg("vers", $ttt_vers);
if (defined &prereqchk)
{ if (! &prereqchk()) { &ttt_exit("notest"); } }
return 1;
}
# These functions and variables provide a framework that a test driver
# uses to inform the user what tests are being run and what the
# results are.
#
# Pass/Fail/Notest counters, for files and cases...
#
$ttt_f_p = 0; # passing files
$ttt_f_f = 0; # failing files
$ttt_f_n = 0; # notest files (no fails, but some "notest"s)
$ttt_c_p = 0; # and counters for cases...
$ttt_c_f = 0;
$ttt_c_n = 0;
$ttt_d_p = 0; # "driver" case counters
$ttt_d_f = 0;
$ttt_d_n = 0;
# &ttt_begin_test()
#
# < (void)
#
# This subroutine should be called once by a test driver when it initializes.
#
sub ttt_begin_test
{
local($agentid, $rbits);
&ttt_msg("begin", "$myname: started by $ttt_user in $ttt_here\n");
&ttt_msg("running files specified by \"@ARGV\"\n");
}
# &ttt_begin_file("filename")
#
# > "filename" The name of the test file to execute
# < (void)
#
# This subroutine should be called once by a test driver before running each
# test file. It initializes the pass/fail/notest tallys for the file, and
# sets the test file name.
#
sub ttt_begin_file
{
($ttt_filename) = @_;
$ttt_c_p_t = 0;
$ttt_c_f_t = 0;
$ttt_c_n_t = 0;
}
# &ttt_begin_case("casename"[, $sep[, $driver]])
#
# > "casename" The name of the test case to be executed
# > $sep Boolean, whether there will be output between the
# _begin and _end
# > $driver Boolean, whether it's a "driver" case (not associated
# with any test file, really...
# < (void)
#
# This subroutine should be called once by a test driver before running each
# test case. It sets the test case name, and prints a message indicating that
# the case is starting.
#
sub ttt_begin_case
{
local($sep, $driver);
($ttt_casename, $sep, $driver) = @_;
if (! defined($driver)) { $driver = 0; }
local($filename);
if ($driver) { $filename = "driver"; } else { $filename = $ttt_filename; }
$ttt_casemsg = sprintf("%-25s%-25s", &basename($filename), $ttt_casename);
if ($sep)
{ &ttt_msg("begin", "$ttt_casemsg\n"); }
else
{ &ttt_msg("case", "$ttt_casemsg "); $ttt_casemsg = ""; }
}
# &ttt_end_case("result"[, $driver])
#
# > "result" The result of the case ("pass", "fail", or "notest")
# > $driver Boolean, whether it's a "driver" case (not associated
# with any test file, really...
# < (void)
#
# This subroutine should be called once by a test driver after running each
# test case, to indicate whether the case passed or failed. It handles the
# result tally, and indicates the results of the case in the output.
#
sub ttt_end_case
{
local($result, $driver) = @_;
if (! defined($driver)) { $driver = 0; }
if ($ttt_casemsg ne "")
{ &ttt_msg("case", "$ttt_casemsg "); $ttt_casemsg = ""; }
if ($result eq "pass")
{
&ttt_msg("-c", "PASS\n"); $ttt_c_p_t++;
if ($driver) { $ttt_d_p++; }
}
elsif ($result eq "fail")
{
&ttt_msg("-c", "FAIL\n"); $ttt_c_f_t++;
if ($driver) { $ttt_d_f++; }
}
else
{
&ttt_msg("-c", "NOTEST\n"); $ttt_c_n_t++;
if ($driver) { $ttt_d_n++; }
}
$ttt_casename = "";
}
# &ttt_end_file()
#
# < (void)
#
# This subroutine should be called once by a test driver after running each
# test file. It handles the tallying of the files tallies, and indicates the
# summary results for the file in the output.
#
sub ttt_end_file
{
local($summ, $total_c_t);
$total_c_t = $ttt_c_p_t + $ttt_c_f_t + $ttt_c_n_t;
if ($ttt_casename ne "")
{ &ttt_end_case("fail"); } # Case started but never finished. Hmmm.
# we don't display "file" results when there's only one case in a file,
# unless $ttt_file_always is set (the default)
#
if ($ttt_file_always || $total_c_t > 1)
{
$summ = sprintf(
" %-20s - %5d total cases: %5d passed; %5d failed; %5d notest\n",
&basename($ttt_filename),
$total_c_t, $ttt_c_p_t, $ttt_c_f_t, $ttt_c_n_t);
&ttt_msg("file", $summ);
}
if ($total_c_t > 0 && $ttt_c_p_t == $total_c_t)
{ $ttt_f_p++; }
elsif ($ttt_c_f_t > 0)
{ $ttt_f_f++; }
else
{ $ttt_f_n++; }
$ttt_c_p += $ttt_c_p_t;
$ttt_c_f += $ttt_c_f_t;
$ttt_c_n += $ttt_c_n_t;
# We zero these out here so that we won't have leftover tallies in
# the event that we do another ttt_end_file before the next
# ttt_begin_file.
#
$ttt_filename = "(unknown)";
$ttt_c_p_t = 0;
$ttt_c_f_t = 0;
$ttt_c_n_t = 0;
}
# &ttt_end_test()
#
# < (void)
#
# This subroutine should be called once by a test driver after after all
# test files have been executed, before the driver terminates. Its indicates
# the overall result summaries for the run in the output, and calls ttt_exit
# to clean up any temp files and terminate the driver.
#
sub ttt_end_test
{
local($total_c) = $ttt_c_p + $ttt_c_f + $ttt_c_n;
local($total_f) = $ttt_f_p + $ttt_f_f + $ttt_f_n;
local($total_d) = $ttt_d_p + $ttt_d_f + $ttt_d_n;
local($exstat, $fmt);
$summ .= sprintf(
" %-20s - %5d total cases: %5d passed; %5d failed; %5d notest\n",
$myname, $total_c, $ttt_c_p, $ttt_c_f, $ttt_c_n);
if ($ttt_file_always || $total_c != $total_f)
{
$summ = $summ.sprintf(
" %-20s - %5d total files: %5d passed; %5d failed; %5d notest\n",
$myname, $total_f, $ttt_f_p, $ttt_f_f, $ttt_f_n);
}
if (($total_d) > 0)
{
$summ = $summ.sprintf(
" %-20s - %5d driver cases: %5d passed; %5d failed; %5d notest\n",
$myname, $total_d, $ttt_d_p, $ttt_d_f, $ttt_d_n);
}
&ttt_msg("summary", $summ);
if ($total_c > 0 && $ttt_f_p == $total_f)
{ $exstat = "pass"; }
elsif ($ttt_f_f > 0)
{ $exstat = "fail"; }
else
{ $exstat = "notest"; }
&ttt_msg("end", "$myname $exstat\n");
&ttt_exit($exstat);
}
# (@files) = &ttt_filesinlist($type, $listpath);
#
# > type String, the test type we're interested in
# > listpath The pathname of the test list to expand
# < files The files to be added to the list
#
# This function expands a test list into a list of test files to be
# run. Only files bearing the specified test type ($type) will be returned.
#
sub ttt_filesinlist
{
local($type, $listpath) = @_;
local(@files, $listfile, $listdir);
local($on) = 1;
$listdir = &ttt_dirname($listpath);
if (! open(LIST, "<$listpath"))
{
&ttt_msg("warning", "can't open $listpath; ignored\n");
return @files; # an empty array
}
Listent: while (<LIST>)
{
chop;
if (/^\@ON$/) { $on = 1; next Listent; }
if (/^\@OFF$/) { $on = 0; next Listent; }
if (/^\@END$/) { last Listent; }
if (/^\s*#/) { next Listent; }
if (/^\s*$/) { next Listent; }
if (! $on) { next Listent; }
($listfile = $_) =~ s/^\s*([^\s]+)/$1/;
if ($MPW) { $listfile =~ s%/%:%g; $listfile = "$listdir$listfile"; }
if ($UNIX) { $listfile =~ s%:%/%g; $listfile = "$listdir/$listfile"; }
push(@files, $listfile);
}
close(LIST);
@files = reverse(@files);
return(@files);
}
# (@files) = &ttt_filesindir($type, @path);
#
# > type String, the test type we're interested in
# > path The pathname of the directory to expand
# < files The files to be added to the list
#
# This function expands a directory name into a list of test files in the
# directory (and, optionally, it's subdirectories) to be run. Only files
# bearing the specified test type ($type) will be returned.
#
sub filesindir
{
local($type, $dir) = @_;
local(@files, $file, $filepath);
if (! opendir($dir,$dir))
{
&ttt_msg("warning", "can't open directory \"$dir\"; ignored\n");
return @files;
}
File: while ($file = readdir($dir))
{
if ($UNIX) { $filepath = "$dir/$file"; }
if ($MPW) { $filepath = "$dir$file"; }
if (-d $filepath)
{
if ($UNIX)
{ if ($file =~ /\.|\.\./) { next File; } }
if ($recursive)
{
if ($MPW) { $filepath = "$filepath:"; }
push(@files, &filesindir($type, $filepath));
}
}
else
{
if (! -f $filepath) { next File; } # just in case (for Unix...)
# If it's a file of the right type, add it to the list!
#
if (! open(FILE, "<$filepath"))
{
&ttt_msg("warning", "can't open file \"$filepath\"; ignored\n");
next File;
}
$line = <FILE>; close(FILE);
if ($line =~ m%^(//|#)\s*(testfile|TDK)\s+$type\b%io)
{
push(@files, $filepath);
}
}
}
closedir($dir);
@files = reverse(@files);
return(@files);
}
# ($file, @paths) = &ttt_nextfile($type, @paths);
#
# > type String, the test type we're interested in
# > paths Array, list of pathnames to process
# < file The next file to execute
# < paths The new list (less $file).
#
# This function returns the name of the next filename to be run by the
# driver. It resolves directories and test lists for the caller.
#
sub ttt_nextfile
{
local($type, @paths) = @_;
local($path);
local($line);
local(@retv);
@retv = ();
# Note: I've diddled the logic of returning the result values
# due to a possible perl5 bug... wherein returns of lists from
# a block enclosed in a while loop seem to be mistakenly evaluated
# as if the function had been called in a scalar context. So, yes,
# the bit with assigning to @retv and then testing it at the top
# of the while loop *is* artificial, but it seems to work with 4.036
# and 5.001e... - rmg 6/8/95
#
# Oh, and I also removed some unecessary "next Path"s
#
Path: while ($#retv >=0 || $#paths >= 0)
{
if ($#retv >= 0) { return @retv; }
$path = pop(@paths);
if (-d $path)
{
if ($MPW && $path !~ /:$/) { $path = "$path:"; }
push(@paths, &filesindir($type, $path));
}
else
{
if (! -e $path)
{
if ($path !~ /\./)
{
if (-e $path. "\.l") { $path .= "\.l"; }
elsif (-e $path. "\.t") { $path .= "\.t"; }
else
{
&ttt_msg("warning",
"\"$path\" does not exist; ignored\n");
}
}
}
if (-f $path)
{
if (! open(FILE, "<$path"))
{
&ttt_msg("warning", "can't open file \"$path\"; ignored\n");
next Path;
}
$line = <FILE>; close(FILE);
if ($line =~ m%^#testlist\b%io)
{ push(@paths, &ttt_filesinlist($type, $path)); }
elsif (($line =~ m%^(//|#)\s*testfile\s+$type\b%io) && ($path !~ /(~$|#$)/))
{ if ($#paths < 0) { @retv = ($path); } else { @retv = ($path, @paths); } }
}
elsif (-e $path)
{ &ttt_msg("warning", "\"$path\" is not a file; ignored\n"); }
}
}
}
# Insure the existence of a directory
#
sub ttt_insuredir
{
local($name) = @_;
if (! -d $name)
{
if (mkdir ($name, 0777))
{ &ttt_msg("mkdir", "$name\n"); return 1; }
else
{
&ttt_msg("error", "couldn't make \"$name\" directory: $!\n");
return 0;
}
}
else
{ return 1; }
}
sub ttt_slurp
{
my ($path) = @_;
my $slashsave;
my $contents;
my $m;
if (! open(S, "<$path"))
{
&ttt_msg("error", "couldn't open \"$path\" to read: $!\n");
return "";
}
$slashsave = $/; undef $/; $contents = <S>; $/ = $slashsave;
close S;
return $contents;
}
#
# $index = &indexOf($element, @list);
#
# > element Element we are seeking to match
# > list Array, list elements to be searched
# < index Index of the element in the list (or -1)
#
# This function searches a list of elements to find the index of the
# specified element. It will return upon finding the first occurrence
# of the element, so elements should probably be unique in the list. If
# the element cannot be found, the function will return -1.
#
sub indexOf
{
my ($element, @list) = @_;
my $index;
for ($index = 0; $index <= $#list; $index++)
{
if ($element eq $list[$index]) { return($index); }
}
return(-1);
}
# Well, let's get on with it!
#
&ttt_init;