# -*-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."="; } 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 = ; chop($ans); } else { if ($UNIX) { &ttt_msg(TTYO, "", "$prompt [$default]? "); } if ($MPW) { &ttt_msg(TTYO, "", "$prompt?\n$default"); } $ans = ; 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 = ; 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" | ); # # 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. # : 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.$$. # # # 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, "&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 () { 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 = ; 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 = ; 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 = ; $/ = $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;