#!/usr/bin/perl
# -*-perl-*-
#
# Modification history:
# Written 91-12-02 through 92-01-01 by Stephen McGee.
# Modified 92-02-11 through 92-02-22 by Chris Arthur to further generalize.
#
# Copyright (C) 1991-2014 Free Software Foundation, Inc.
# This file is part of GNU Make.
#
# GNU Make is free software; you can redistribute it and/or modify it under
# the terms of the GNU General Public License as published by the Free Software
# Foundation; either version 3 of the License, or (at your option) any later
# version.
#
# GNU Make is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
# details.
#
# You should have received a copy of the GNU General Public License along with
# this program. If not, see <http://www.gnu.org/licenses/>.
# Test driver routines used by a number of test suites, including
# those for SCS, make, roll_dir, and scan_deps (?).
#
# this routine controls the whole mess; each test suite sets up a few
# variables and then calls &toplevel, which does all the real work.
# $Id$
# The number of test categories we've run
$categories_run = 0;
# The number of test categroies that have passed
$categories_passed = 0;
# The total number of individual tests that have been run
$total_tests_run = 0;
# The total number of individual tests that have passed
$total_tests_passed = 0;
# The number of tests in this category that have been run
$tests_run = 0;
# The number of tests in this category that have passed
$tests_passed = 0;
# Yeesh. This whole test environment is such a hack!
$test_passed = 1;
# Timeout in seconds. If the test takes longer than this we'll fail it.
$test_timeout = 5;
$test_timeout = 10 if $^O eq 'VMS';
# Path to Perl
$perl_name = $^X;
# %makeENV is the cleaned-out environment.
%makeENV = ();
# %extraENV are any extra environment variables the tests might want to set.
# These are RESET AFTER EVERY TEST!
%extraENV = ();
sub vms_get_process_logicals {
# Sorry for the long note here, but to keep this test running on
# VMS, it is needed to be understood.
#
# Perl on VMS by default maps the %ENV array to the system wide logical
# name table.
#
# This is a very large dynamically changing table.
# On Linux, this would be the equivalent of a table that contained
# every mount point, temporary pipe, and symbolic link on every
# file system. You normally do not have permission to clear or replace it,
# and if you did, the results would be catastrophic.
#
# On VMS, added/changed %ENV items show up in the process logical
# name table. So to track changes, a copy of it needs to be captured.
my $raw_output = `show log/process/access_mode=supervisor`;
my @raw_output_lines = split('\n',$raw_output);
my %log_hash;
foreach my $line (@raw_output_lines) {
if ($line =~ /^\s+"([A-Za-z\$_]+)"\s+=\s+"(.+)"$/) {
$log_hash{$1} = $2;
}
}
return \%log_hash
}
# %origENV is the caller's original environment
if ($^O ne 'VMS') {
%origENV = %ENV;
} else {
my $proc_env = vms_get_process_logicals;
%origENV = %{$proc_env};
}
sub resetENV
{
# We used to say "%ENV = ();" but this doesn't work in Perl 5.000
# through Perl 5.004. It was fixed in Perl 5.004_01, but we don't
# want to require that here, so just delete each one individually.
if ($^O ne 'VMS') {
foreach $v (keys %ENV) {
delete $ENV{$v};
}
%ENV = %makeENV;
} else {
my $proc_env = vms_get_process_logicals();
my %delta = %{$proc_env};
foreach my $v (keys %delta) {
if (exists $origENV{$v}) {
if ($origENV{$v} ne $delta{$v}) {
$ENV{$v} = $origENV{$v};
}
} else {
delete $ENV{$v};
}
}
}
foreach $v (keys %extraENV) {
$ENV{$v} = $extraENV{$v};
delete $extraENV{$v};
}
}
sub toplevel
{
# Pull in benign variables from the user's environment
foreach (# UNIX-specific things
'TZ', 'TMPDIR', 'HOME', 'USER', 'LOGNAME', 'PATH',
'LD_LIBRARY_PATH',
# Purify things
'PURIFYOPTIONS',
# Windows NT-specific stuff
'Path', 'SystemRoot',
# DJGPP-specific stuff
'DJDIR', 'DJGPP', 'SHELL', 'COMSPEC', 'HOSTNAME', 'LFN',
'FNCASE', '387', 'EMU387', 'GROUP'
) {
$makeENV{$_} = $ENV{$_} if $ENV{$_};
}
# Make sure our compares are not foiled by locale differences
$makeENV{LC_ALL} = 'C';
# Replace the environment with the new one
#
%origENV = %ENV unless $^O eq 'VMS';
resetENV();
$| = 1; # unbuffered output
$debug = 0; # debug flag
$profile = 0; # profiling flag
$verbose = 0; # verbose mode flag
$detail = 0; # detailed verbosity
$keep = 0; # keep temp files around
$workdir = "work"; # The directory where the test will start running
$scriptdir = "scripts"; # The directory where we find the test scripts
$tmpfilesuffix = "t"; # the suffix used on tmpfiles
$default_output_stack_level = 0; # used by attach_default_output, etc.
$default_input_stack_level = 0; # used by attach_default_input, etc.
$cwd = "."; # don't we wish we knew
$cwdslash = ""; # $cwd . $pathsep, but "" rather than "./"
&get_osname; # sets $osname, $vos, $pathsep, and $short_filenames
&set_defaults; # suite-defined
&parse_command_line (@ARGV);
print "OS name = '$osname'\n" if $debug;
$workpath = "$cwdslash$workdir";
$scriptpath = "$cwdslash$scriptdir";
&set_more_defaults; # suite-defined
&print_banner;
if ($osname eq 'VMS' && $cwdslash eq "")
{
# Porting this script to VMS revealed a small bug in opendir() not
# handling search lists correctly when the directory only exists in
# one of the logical_devices. Need to find the first directory in
# the search list, as that is where things will be written to.
my @dirs = split("/", $pwd);
my $logical_device = $ENV{$dirs[1]};
if ($logical_device =~ /([A-Za-z0-9_]+):(:?.+:)+/)
{
# A search list was found. Grab the first logical device
# and use it instead of the search list.
$dirs[1]=$1;
my $lcl_pwd = join('/', @dirs);
$workpath = $lcl_pwd . '/' . $workdir
}
}
if (-d $workpath)
{
print "Clearing $workpath...\n";
&remove_directory_tree("$workpath/")
|| &error ("Couldn't wipe out $workpath\n");
}
else
{
mkdir ($workpath, 0777) || &error ("Couldn't mkdir $workpath: $!\n");
}
if (!-d $scriptpath)
{
&error ("Failed to find $scriptpath containing perl test scripts.\n");
}
if (@TESTS)
{
print "Making work dirs...\n";
foreach $test (@TESTS)
{
if ($test =~ /^([^\/]+)\//)
{
$dir = $1;
push (@rmdirs, $dir);
-d "$workpath/$dir"
|| mkdir ("$workpath/$dir", 0777)
|| &error ("Couldn't mkdir $workpath/$dir: $!\n");
}
}
}
else
{
print "Finding tests...\n";
opendir (SCRIPTDIR, $scriptpath)
|| &error ("Couldn't opendir $scriptpath: $!\n");
@dirs = grep (!/^(\..*|CVS|RCS)$/, readdir (SCRIPTDIR) );
closedir (SCRIPTDIR);
foreach $dir (@dirs)
{
next if ($dir =~ /^(\..*|CVS|RCS)$/ || ! -d "$scriptpath/$dir");
push (@rmdirs, $dir);
# VMS can have overlayed file systems, so directories may repeat.
next if -d "$workpath/$dir";
mkdir ("$workpath/$dir", 0777)
|| &error ("Couldn't mkdir $workpath/$dir: $!\n");
opendir (SCRIPTDIR, "$scriptpath/$dir")
|| &error ("Couldn't opendir $scriptpath/$dir: $!\n");
@files = grep (!/^(\..*|CVS|RCS|.*~)$/, readdir (SCRIPTDIR) );
closedir (SCRIPTDIR);
foreach $test (@files)
{
-d $test and next;
push (@TESTS, "$dir/$test");
}
}
}
if (@TESTS == 0)
{
&error ("\nNo tests in $scriptpath, and none were specified.\n");
}
print "\n";
run_all_tests();
foreach $dir (@rmdirs)
{
rmdir ("$workpath/$dir");
}
$| = 1;
$categories_failed = $categories_run - $categories_passed;
$total_tests_failed = $total_tests_run - $total_tests_passed;
if ($total_tests_failed)
{
print "\n$total_tests_failed Test";
print "s" unless $total_tests_failed == 1;
print " in $categories_failed Categor";
print ($categories_failed == 1 ? "y" : "ies");
print " Failed (See .$diffext* files in $workdir dir for details) :-(\n\n";
return 0;
}
else
{
print "\n$total_tests_passed Test";
print "s" unless $total_tests_passed == 1;
print " in $categories_passed Categor";
print ($categories_passed == 1 ? "y" : "ies");
print " Complete ... No Failures :-)\n\n";
return 1;
}
}
sub get_osname
{
# Set up an initial value. In perl5 we can do it the easy way.
$osname = defined($^O) ? $^O : '';
if ($osname eq 'VMS')
{
$vos = 0;
$pathsep = "/";
return;
}
# Find a path to Perl
# See if the filesystem supports long file names with multiple
# dots. DOS doesn't.
$short_filenames = 0;
(open (TOUCHFD, "> fancy.file.name") && close (TOUCHFD))
|| ($short_filenames = 1);
unlink ("fancy.file.name") || ($short_filenames = 1);
if (! $short_filenames) {
# Thanks go to meyering@cs.utexas.edu (Jim Meyering) for suggesting a
# better way of doing this. (We used to test for existence of a /mnt
# dir, but that apparently fails on an SGI Indigo (whatever that is).)
# Because perl on VOS translates /'s to >'s, we need to test for
# VOSness rather than testing for Unixness (ie, try > instead of /).
mkdir (".ostest", 0777) || &error ("Couldn't create .ostest: $!\n", 1);
open (TOUCHFD, "> .ostest>ick") && close (TOUCHFD);
chdir (".ostest") || &error ("Couldn't chdir to .ostest: $!\n", 1);
}
if (! $short_filenames && -f "ick")
{
$osname = "vos";
$vos = 1;
$pathsep = ">";
}
else
{
# the following is regrettably knarly, but it seems to be the only way
# to not get ugly error messages if uname can't be found.
# Hmmm, BSD/OS 2.0's uname -a is excessively verbose. Let's try it
# with switches first.
eval "chop (\$osname = `sh -c 'uname -nmsr 2>&1'`)";
if ($osname =~ /not found/i)
{
$osname = "(something posixy with no uname)";
}
elsif ($@ ne "" || $?)
{
eval "chop (\$osname = `sh -c 'uname -a 2>&1'`)";
if ($@ ne "" || $?)
{
$osname = "(something posixy)";
}
}
$vos = 0;
$pathsep = "/";
}
if (! $short_filenames) {
chdir ("..") || &error ("Couldn't chdir to ..: $!\n", 1);
unlink (".ostest>ick");
rmdir (".ostest") || &error ("Couldn't rmdir .ostest: $!\n", 1);
}
}
sub parse_command_line
{
@argv = @_;
# use @ARGV if no args were passed in
if (@argv == 0)
{
@argv = @ARGV;
}
# look at each option; if we don't recognize it, maybe the suite-specific
# command line parsing code will...
while (@argv)
{
$option = shift @argv;
if ($option =~ /^-debug$/i)
{
print "\nDEBUG ON\n";
$debug = 1;
}
elsif ($option =~ /^-usage$/i)
{
&print_usage;
exit 0;
}
elsif ($option =~ /^-(h|help)$/i)
{
&print_help;
exit 0;
}
elsif ($option =~ /^-profile$/i)
{
$profile = 1;
}
elsif ($option =~ /^-verbose$/i)
{
$verbose = 1;
}
elsif ($option =~ /^-detail$/i)
{
$detail = 1;
$verbose = 1;
}
elsif ($option =~ /^-keep$/i)
{
$keep = 1;
}
elsif (&valid_option($option))
{
# The suite-defined subroutine takes care of the option
}
elsif ($option =~ /^-/)
{
print "Invalid option: $option\n";
&print_usage;
exit 0;
}
else # must be the name of a test
{
$option =~ s/\.pl$//;
push(@TESTS,$option);
}
}
}
sub max
{
local($num) = shift @_;
local($newnum);
while (@_)
{
$newnum = shift @_;
if ($newnum > $num)
{
$num = $newnum;
}
}
return $num;
}
sub print_centered
{
local($width, $string) = @_;
local($pad);
if (length ($string))
{
$pad = " " x ( ($width - length ($string) + 1) / 2);
print "$pad$string";
}
}
sub print_banner
{
local($info);
local($line);
local($len);
$info = "Running tests for $testee on $osname\n"; # $testee is suite-defined
$len = &max (length ($line), length ($testee_version),
length ($banner_info), 73) + 5;
$line = ("-" x $len) . "\n";
if ($len < 78)
{
$len = 78;
}
&print_centered ($len, $line);
&print_centered ($len, $info);
&print_centered ($len, $testee_version); # suite-defined
&print_centered ($len, $banner_info); # suite-defined
&print_centered ($len, $line);
print "\n";
}
sub run_all_tests
{
$categories_run = 0;
$lasttest = '';
foreach $testname (sort @TESTS) {
# Skip duplicates on VMS caused by logical name search lists.
next if $testname eq $lasttest;
$lasttest = $testname;
$suite_passed = 1; # reset by test on failure
$num_of_logfiles = 0;
$num_of_tmpfiles = 0;
$description = "";
$details = "";
$old_makefile = undef;
$testname =~ s/^$scriptpath$pathsep//;
$perl_testname = "$scriptpath$pathsep$testname";
$testname =~ s/(\.pl|\.perl)$//;
$testpath = "$workpath$pathsep$testname";
# Leave enough space in the extensions to append a number, even
# though it needs to fit into 8+3 limits.
if ($short_filenames) {
$logext = 'l';
$diffext = 'd';
$baseext = 'b';
$runext = 'r';
$extext = '';
} else {
$logext = 'log';
$diffext = 'diff';
$baseext = 'base';
$runext = 'run';
$extext = '.';
}
$extext = '_' if $^O eq 'VMS';
$log_filename = "$testpath.$logext";
$diff_filename = "$testpath.$diffext";
$base_filename = "$testpath.$baseext";
$run_filename = "$testpath.$runext";
$tmp_filename = "$testpath.$tmpfilesuffix";
setup_for_test();
$output = "........................................................ ";
substr($output,0,length($testname)) = "$testname ";
print $output;
$tests_run = 0;
$tests_passed = 0;
# Run the test!
$code = do $perl_testname;
++$categories_run;
$total_tests_run += $tests_run;
$total_tests_passed += $tests_passed;
# How did it go?
if (!defined($code)) {
# Failed to parse or called die
if (length ($@)) {
warn "\n*** Test died ($testname): $@\n";
} else {
warn "\n*** Couldn't parse $perl_testname\n";
}
$status = "FAILED ($tests_passed/$tests_run passed)";
}
elsif ($code == -1) {
# Skipped... not supported
$status = "N/A";
--$categories_run;
}
elsif ($code != 1) {
# Bad result... this shouldn't really happen. Usually means that
# the suite forgot to end with "1;".
warn "\n*** Test returned $code\n";
$status = "FAILED ($tests_passed/$tests_run passed)";
}
elsif ($tests_run == 0) {
# Nothing was done!!
$status = "FAILED (no tests found!)";
}
elsif ($tests_run > $tests_passed) {
# Lose!
$status = "FAILED ($tests_passed/$tests_run passed)";
}
else {
# Win!
++$categories_passed;
$status = "ok ($tests_passed passed)";
# Clean up
for ($i = $num_of_tmpfiles; $i; $i--) {
rmfiles($tmp_filename . num_suffix($i));
}
for ($i = $num_of_logfiles ? $num_of_logfiles : 1; $i; $i--) {
rmfiles($log_filename . num_suffix($i));
rmfiles($base_filename . num_suffix($i));
}
}
# If the verbose option has been specified, then a short description
# of each test is printed before displaying the results of each test
# describing WHAT is being tested.
if ($verbose) {
if ($detail) {
print "\nWHAT IS BEING TESTED\n";
print "--------------------";
}
print "\n\n$description\n\n";
}
# If the detail option has been specified, then the details of HOW
# the test is testing what it says it is testing in the verbose output
# will be displayed here before the results of the test are displayed.
if ($detail) {
print "\nHOW IT IS TESTED\n";
print "----------------";
print "\n\n$details\n\n";
}
print "$status\n";
}
}
# If the keep flag is not set, this subroutine deletes all filenames that
# are sent to it.
sub rmfiles
{
local(@files) = @_;
if (!$keep)
{
return (unlink @files);
}
return 1;
}
sub print_standard_usage
{
local($plname,@moreusage) = @_;
local($line);
print "usage:\t$plname [testname] [-verbose] [-detail] [-keep]\n";
print "\t\t\t[-profile] [-usage] [-help] [-debug]\n";
foreach (@moreusage) {
print "\t\t\t$_\n";
}
}
sub print_standard_help
{
local(@morehelp) = @_;
local($line);
local($tline);
local($t) = " ";
$line = "Test Driver For $testee";
print "$line\n";
$line = "=" x length ($line);
print "$line\n";
&print_usage;
print "\ntestname\n"
. "${t}You may, if you wish, run only ONE test if you know the name\n"
. "${t}of that test and specify this name anywhere on the command\n"
. "${t}line. Otherwise ALL existing tests in the scripts directory\n"
. "${t}will be run.\n"
. "-verbose\n"
. "${t}If this option is given, a description of every test is\n"
. "${t}displayed before the test is run. (Not all tests may have\n"
. "${t}descriptions at this time)\n"
. "-detail\n"
. "${t}If this option is given, a detailed description of every\n"
. "${t}test is displayed before the test is run. (Not all tests\n"
. "${t}have descriptions at this time)\n"
. "-profile\n"
. "${t}If this option is given, then the profile file\n"
. "${t}is added to other profiles every time $testee is run.\n"
. "${t}This option only works on VOS at this time.\n"
. "-keep\n"
. "${t}You may give this option if you DO NOT want ANY\n"
. "${t}of the files generated by the tests to be deleted. \n"
. "${t}Without this option, all files generated by the test will\n"
. "${t}be deleted IF THE TEST PASSES.\n"
. "-debug\n"
. "${t}Use this option if you would like to see all of the system\n"
. "${t}calls issued and their return status while running the tests\n"
. "${t}This can be helpful if you're having a problem adding a test\n"
. "${t}to the suite, or if the test fails!\n";
foreach $line (@morehelp)
{
$tline = $line;
if (substr ($tline, 0, 1) eq "\t")
{
substr ($tline, 0, 1) = $t;
}
print "$tline\n";
}
}
#######################################################################
########### Generic Test Driver Subroutines ###########
#######################################################################
sub get_caller
{
local($depth);
local($package);
local($filename);
local($linenum);
$depth = defined ($_[0]) ? $_[0] : 1;
($package, $filename, $linenum) = caller ($depth + 1);
return "$filename: $linenum";
}
sub error
{
local($message) = $_[0];
local($caller) = &get_caller (1);
if (defined ($_[1]))
{
$caller = &get_caller ($_[1] + 1) . " -> $caller";
}
die "$caller: $message";
}
sub compare_output
{
local($answer,$logfile) = @_;
local($slurp, $answer_matched) = ('', 0);
++$tests_run;
if (! defined $answer) {
print "Ignoring output ........ " if $debug;
$answer_matched = 1;
} else {
print "Comparing Output ........ " if $debug;
$slurp = &read_file_into_string ($logfile);
# For make, get rid of any time skew error before comparing--too bad this
# has to go into the "generic" driver code :-/
$slurp =~ s/^.*modification time .*in the future.*\n//gm;
$slurp =~ s/^.*Clock skew detected.*\n//gm;
if ($slurp eq $answer) {
$answer_matched = 1;
} else {
# See if it is a slash or CRLF problem
local ($answer_mod, $slurp_mod) = ($answer, $slurp);
$answer_mod =~ tr,\\,/,;
$answer_mod =~ s,\r\n,\n,gs;
$slurp_mod =~ tr,\\,/,;
$slurp_mod =~ s,\r\n,\n,gs;
$answer_matched = ($slurp_mod eq $answer_mod);
if ($^O eq 'VMS') {
# VMS has extra blank lines in output sometimes.
# Ticket #41760
if (!$answer_matched) {
$slurp_mod =~ s/\n\n+/\n/gm;
$slurp_mod =~ s/\A\n+//g;
$answer_matched = ($slurp_mod eq $answer_mod);
}
# VMS adding a "Waiting for unfinished jobs..."
# Remove it for now to see what else is going on.
if (!$answer_matched) {
$slurp_mod =~ s/^.+\*\*\* Waiting for unfinished jobs.+$//m;
$slurp_mod =~ s/\n\n/\n/gm;
$slurp_mod =~ s/^\n+//gm;
$answer_matched = ($slurp_mod eq $answer_mod);
}
# VMS wants target device to exist or generates an error,
# Some test tagets look like VMS devices and trip this.
if (!$answer_matched) {
$slurp_mod =~ s/^.+\: no such device or address.*$//gim;
$slurp_mod =~ s/\n\n/\n/gm;
$slurp_mod =~ s/^\n+//gm;
$answer_matched = ($slurp_mod eq $answer_mod);
}
# VMS error message has a different case
if (!$answer_matched) {
$slurp_mod =~ s/no such file /No such file /gm;
$answer_matched = ($slurp_mod eq $answer_mod);
}
# VMS is putting comas instead of spaces in output
if (!$answer_matched) {
$slurp_mod =~ s/,/ /gm;
$answer_matched = ($slurp_mod eq $answer_mod);
}
# VMS Is sometimes adding extra leading spaces to output?
if (!$answer_matched) {
my $slurp_mod = $slurp_mod;
$slurp_mod =~ s/^ +//gm;
$answer_matched = ($slurp_mod eq $answer_mod);
}
# VMS port not handling POSIX encoded child status
# Translate error case it for now.
if (!$answer_matched) {
$slurp_mod =~ s/0x1035a00a/1/gim;
$answer_matched = 1 if $slurp_mod =~ /\Q$answer_mod\E/i;
}
if (!$answer_matched) {
$slurp_mod =~ s/0x1035a012/2/gim;
$answer_matched = ($slurp_mod eq $answer_mod);
}
# Tests are using a UNIX null command, temp hack
# until this can be handled by the VMS port.
# ticket # 41761
if (!$answer_matched) {
$slurp_mod =~ s/^.+DCL-W-NOCOMD.*$//gim;
$slurp_mod =~ s/\n\n+/\n/gm;
$slurp_mod =~ s/^\n+//gm;
$answer_matched = ($slurp_mod eq $answer_mod);
}
# Tests are using exit 0;
# this generates a warning that should stop the make, but does not
if (!$answer_matched) {
$slurp_mod =~ s/^.+NONAME-W-NOMSG.*$//gim;
$slurp_mod =~ s/\n\n+/\n/gm;
$slurp_mod =~ s/^\n+//gm;
$answer_matched = ($slurp_mod eq $answer_mod);
}
# VMS is sometimes adding single quotes to output?
if (!$answer_matched) {
my $noq_slurp_mod = $slurp_mod;
$noq_slurp_mod =~ s/\'//gm;
$answer_matched = ($noq_slurp_mod eq $answer_mod);
# And missing an extra space in output
if (!$answer_matched) {
$noq_answer_mod = $answer_mod;
$noq_answer_mod =~ s/\h\h+/ /gm;
$answer_matched = ($noq_slurp_mod eq $noq_answer_mod);
}
# VMS adding ; to end of some lines.
if (!$answer_matched) {
$noq_slurp_mod =~ s/;\n/\n/gm;
$answer_matched = ($noq_slurp_mod eq $noq_answer_mod);
}
# VMS adding trailing space to end of some quoted lines.
if (!$answer_matched) {
$noq_slurp_mod =~ s/\h+\n/\n/gm;
$answer_matched = ($noq_slurp_mod eq $noq_answer_mod);
}
# And VMS missing leading blank line
if (!$answer_matched) {
$noq_answer_mod =~ s/\A\n//g;
$answer_matched = ($noq_slurp_mod eq $noq_answer_mod);
}
# Unix double quotes showing up as single quotes on VMS.
if (!$answer_matched) {
$noq_answer_mod =~ s/\"//g;
$answer_matched = ($noq_slurp_mod eq $noq_answer_mod);
}
}
}
# If it still doesn't match, see if the answer might be a regex.
if (!$answer_matched && $answer =~ m,^/(.+)/$,) {
$answer_matched = ($slurp =~ /$1/);
if (!$answer_matched && $answer_mod =~ m,^/(.+)/$,) {
$answer_matched = ($slurp_mod =~ /$1/);
}
}
}
}
if ($answer_matched && $test_passed)
{
print "ok\n" if $debug;
++$tests_passed;
return 1;
}
if (! $answer_matched) {
print "DIFFERENT OUTPUT\n" if $debug;
&create_file (&get_basefile, $answer);
&create_file (&get_runfile, $command_string);
print "\nCreating Difference File ...\n" if $debug;
# Create the difference file
local($command) = "diff -c " . &get_basefile . " " . $logfile;
&run_command_with_output(&get_difffile,$command);
}
return 0;
}
sub read_file_into_string
{
local($filename) = @_;
local($oldslash) = $/;
undef $/;
open (RFISFILE, $filename) || return "";
local ($slurp) = <RFISFILE>;
close (RFISFILE);
$/ = $oldslash;
return $slurp;
}
my @OUTSTACK = ();
my @ERRSTACK = ();
sub attach_default_output
{
local ($filename) = @_;
local ($code);
if ($vos)
{
$code = system "++attach_default_output_hack $filename";
$code == -2 || &error ("adoh death\n", 1);
return 1;
}
my $dup = undef;
open($dup, '>&', STDOUT) or error("ado: $! duping STDOUT\n", 1);
push @OUTSTACK, $dup;
$dup = undef;
open($dup, '>&', STDERR) or error("ado: $! duping STDERR\n", 1);
push @ERRSTACK, $dup;
open(STDOUT, '>', $filename) or error("ado: $filename: $!\n", 1);
open(STDERR, ">&STDOUT") or error("ado: $filename: $!\n", 1);
}
# close the current stdout/stderr, and restore the previous ones from
# the "stack."
sub detach_default_output
{
local ($code);
if ($vos)
{
$code = system "++detach_default_output_hack";
$code == -2 || &error ("ddoh death\n", 1);
return 1;
}
@OUTSTACK or error("default output stack has flown under!\n", 1);
close(STDOUT);
close(STDERR) unless $^O eq 'VMS';
open (STDOUT, '>&', pop @OUTSTACK) or error("ddo: $! duping STDOUT\n", 1);
open (STDERR, '>&', pop @ERRSTACK) or error("ddo: $! duping STDERR\n", 1);
}
# This runs a command without any debugging info.
sub _run_command
{
my $code;
# We reset this before every invocation. On Windows I think there is only
# one environment, not one per process, so I think that variables set in
# test scripts might leak into subsequent tests if this isn't reset--???
resetENV();
eval {
if ($^O eq 'VMS') {
local $SIG{ALRM} = sub {
my $e = $ERRSTACK[0];
print $e "\nTest timed out after $test_timeout seconds\n";
die "timeout\n"; };
# alarm $test_timeout;
system(@_);
my $severity = ${^CHILD_ERROR_NATIVE} & 7;
$code = 0;
if (($severity & 1) == 0) {
$code = 512;
}
# Get the vms status.
my $vms_code = ${^CHILD_ERROR_NATIVE};
# Remove the print status bit
$vms_code &= ~0x10000000;
# Posix code translation.
if (($vms_code & 0xFFFFF000) == 0x35a000) {
$code = (($vms_code & 0xFFF) >> 3) * 256;
}
} else {
my $pid = fork();
if (! $pid) {
exec(@_) or die "Cannot execute $_[0]\n";
}
local $SIG{ALRM} = sub { my $e = $ERRSTACK[0]; print $e "\nTest timed out after $test_timeout seconds\n"; die "timeout\n"; };
alarm $test_timeout;
waitpid($pid, 0) > 0 or die "No such pid: $pid\n";
$code = $?;
}
alarm 0;
};
if ($@) {
# The eval failed. If it wasn't SIGALRM then die.
$@ eq "timeout\n" or die "Command failed: $@";
# Timed out. Resend the alarm to our process group to kill the children.
$SIG{ALRM} = 'IGNORE';
kill -14, $$;
$code = 14;
}
return $code;
}
# run one command (passed as a list of arg 0 - n), returning 0 on success
# and nonzero on failure.
sub run_command
{
print "\nrun_command: @_\n" if $debug;
my $code = _run_command(@_);
print "run_command returned $code.\n" if $debug;
print "vms status = ${^CHILD_ERROR_NATIVE}\n" if $debug and $^O eq 'VMS';
return $code;
}
# run one command (passed as a list of arg 0 - n, with arg 0 being the
# second arg to this routine), returning 0 on success and non-zero on failure.
# The first arg to this routine is a filename to connect to the stdout
# & stderr of the child process.
sub run_command_with_output
{
my $filename = shift;
print "\nrun_command_with_output($filename,$runname): @_\n" if $debug;
&attach_default_output ($filename);
my $code = eval { _run_command(@_) };
my $err = $@;
&detach_default_output;
$err and die $err;
print "run_command_with_output returned $code.\n" if $debug;
print "vms status = ${^CHILD_ERROR_NATIVE}\n" if $debug and $^O eq 'VMS';
return $code;
}
# performs the equivalent of an "rm -rf" on the first argument. Like
# rm, if the path ends in /, leaves the (now empty) directory; otherwise
# deletes it, too.
sub remove_directory_tree
{
local ($targetdir) = @_;
local ($nuketop) = 1;
local ($ch);
$ch = substr ($targetdir, length ($targetdir) - 1);
if ($ch eq "/" || $ch eq $pathsep)
{
$targetdir = substr ($targetdir, 0, length ($targetdir) - 1);
$nuketop = 0;
}
if (! -e $targetdir)
{
return 1;
}
&remove_directory_tree_inner ("RDT00", $targetdir) || return 0;
if ($nuketop)
{
rmdir $targetdir || return 0;
}
return 1;
}
sub remove_directory_tree_inner
{
local ($dirhandle, $targetdir) = @_;
local ($object);
local ($subdirhandle);
opendir ($dirhandle, $targetdir) || return 0;
$subdirhandle = $dirhandle;
$subdirhandle++;
while ($object = readdir ($dirhandle))
{
if ($object =~ /^(\.\.?|CVS|RCS)$/)
{
next;
}
$object = "$targetdir$pathsep$object";
lstat ($object);
if (-d _ && &remove_directory_tree_inner ($subdirhandle, $object))
{
rmdir $object || return 0;
}
else
{
if ($^O ne 'VMS')
{
unlink $object || return 0;
}
else
{
# VMS can have multiple versions of a file.
1 while unlink $object;
}
}
}
closedir ($dirhandle);
return 1;
}
# We used to use this behavior for this function:
#
#sub touch
#{
# local (@filenames) = @_;
# local ($now) = time;
# local ($file);
#
# foreach $file (@filenames)
# {
# utime ($now, $now, $file)
# || (open (TOUCHFD, ">> $file") && close (TOUCHFD))
# || &error ("Couldn't touch $file: $!\n", 1);
# }
# return 1;
#}
#
# But this behaves badly on networked filesystems where the time is
# skewed, because it sets the time of the file based on the _local_
# host. Normally when you modify a file, it's the _remote_ host that
# determines the modtime, based on _its_ clock. So, instead, now we open
# the file and write something into it to force the remote host to set
# the modtime correctly according to its clock.
#
sub touch
{
local ($file);
foreach $file (@_) {
(open(T, ">> $file") && print(T "\n") && close(T))
|| &error("Couldn't touch $file: $!\n", 1);
}
}
# Touch with a time offset. To DTRT, call touch() then use stat() to get the
# access/mod time for each file and apply the offset.
sub utouch
{
local ($off) = shift;
local ($file);
&touch(@_);
local (@s) = stat($_[0]);
utime($s[8]+$off, $s[9]+$off, @_);
}
# open a file, write some stuff to it, and close it.
sub create_file
{
local ($filename, @lines) = @_;
open (CF, "> $filename") || &error ("Couldn't open $filename: $!\n", 1);
foreach $line (@lines)
{
print CF $line;
}
close (CF);
}
# create a directory tree described by an associative array, wherein each
# key is a relative pathname (using slashes) and its associated value is
# one of:
# DIR indicates a directory
# FILE:contents indicates a file, which should contain contents +\n
# LINK:target indicates a symlink, pointing to $basedir/target
# The first argument is the dir under which the structure will be created
# (the dir will be made and/or cleaned if necessary); the second argument
# is the associative array.
sub create_dir_tree
{
local ($basedir, %dirtree) = @_;
local ($path);
&remove_directory_tree ("$basedir");
mkdir ($basedir, 0777) || &error ("Couldn't mkdir $basedir: $!\n", 1);
foreach $path (sort keys (%dirtree))
{
if ($dirtree {$path} =~ /^DIR$/)
{
mkdir ("$basedir/$path", 0777)
|| &error ("Couldn't mkdir $basedir/$path: $!\n", 1);
}
elsif ($dirtree {$path} =~ /^FILE:(.*)$/)
{
&create_file ("$basedir/$path", $1 . "\n");
}
elsif ($dirtree {$path} =~ /^LINK:(.*)$/)
{
symlink ("$basedir/$1", "$basedir/$path")
|| &error ("Couldn't symlink $basedir/$path -> $basedir/$1: $!\n", 1);
}
else
{
&error ("Bogus dirtree type: \"$dirtree{$path}\"\n", 1);
}
}
if ($just_setup_tree)
{
die "Tree is setup...\n";
}
}
# compare a directory tree with an associative array in the format used
# by create_dir_tree, above.
# The first argument is the dir under which the structure should be found;
# the second argument is the associative array.
sub compare_dir_tree
{
local ($basedir, %dirtree) = @_;
local ($path);
local ($i);
local ($bogus) = 0;
local ($contents);
local ($target);
local ($fulltarget);
local ($found);
local (@files);
local (@allfiles);
opendir (DIR, $basedir) || &error ("Couldn't open $basedir: $!\n", 1);
@allfiles = grep (!/^(\.\.?|CVS|RCS)$/, readdir (DIR) );
closedir (DIR);
if ($debug)
{
print "dirtree: (%dirtree)\n$basedir: (@allfiles)\n";
}
foreach $path (sort keys (%dirtree))
{
if ($debug)
{
print "Checking $path ($dirtree{$path}).\n";
}
$found = 0;
foreach $i (0 .. $#allfiles)
{
if ($allfiles[$i] eq $path)
{
splice (@allfiles, $i, 1); # delete it
if ($debug)
{
print " Zapped $path; files now (@allfiles).\n";
}
lstat ("$basedir/$path");
$found = 1;
last;
}
}
if (!$found)
{
print "compare_dir_tree: $path does not exist.\n";
$bogus = 1;
next;
}
if ($dirtree {$path} =~ /^DIR$/)
{
if (-d _ && opendir (DIR, "$basedir/$path") )
{
@files = readdir (DIR);
closedir (DIR);
@files = grep (!/^(\.\.?|CVS|RCS)$/ && ($_ = "$path/$_"), @files);
push (@allfiles, @files);
if ($debug)
{
print " Read in $path; new files (@files).\n";
}
}
else
{
print "compare_dir_tree: $path is not a dir.\n";
$bogus = 1;
}
}
elsif ($dirtree {$path} =~ /^FILE:(.*)$/)
{
if (-l _ || !-f _)
{
print "compare_dir_tree: $path is not a file.\n";
$bogus = 1;
next;
}
if ($1 ne "*")
{
$contents = &read_file_into_string ("$basedir/$path");
if ($contents ne "$1\n")
{
print "compare_dir_tree: $path contains wrong stuff."
. " Is:\n$contentsShould be:\n$1\n";
$bogus = 1;
}
}
}
elsif ($dirtree {$path} =~ /^LINK:(.*)$/)
{
$target = $1;
if (!-l _)
{
print "compare_dir_tree: $path is not a link.\n";
$bogus = 1;
next;
}
$contents = readlink ("$basedir/$path");
$contents =~ tr/>/\//;
$fulltarget = "$basedir/$target";
$fulltarget =~ tr/>/\//;
if (!($contents =~ /$fulltarget$/))
{
if ($debug)
{
$target = $fulltarget;
}
print "compare_dir_tree: $path should be link to $target, "
. "not $contents.\n";
$bogus = 1;
}
}
else
{
&error ("Bogus dirtree type: \"$dirtree{$path}\"\n", 1);
}
}
if ($debug)
{
print "leftovers: (@allfiles).\n";
}
foreach $file (@allfiles)
{
print "compare_dir_tree: $file should not exist.\n";
$bogus = 1;
}
return !$bogus;
}
# this subroutine generates the numeric suffix used to keep tmp filenames,
# log filenames, etc., unique. If the number passed in is 1, then a null
# string is returned; otherwise, we return ".n", where n + 1 is the number
# we were given.
sub num_suffix
{
local($num) = @_;
if (--$num > 0) {
return "$extext$num";
}
return "";
}
# This subroutine returns a log filename with a number appended to
# the end corresponding to how many logfiles have been created in the
# current running test. An optional parameter may be passed (0 or 1).
# If a 1 is passed, then it does NOT increment the logfile counter
# and returns the name of the latest logfile. If either no parameter
# is passed at all or a 0 is passed, then the logfile counter is
# incremented and the new name is returned.
sub get_logfile
{
local($no_increment) = @_;
$num_of_logfiles += !$no_increment;
return ($log_filename . &num_suffix ($num_of_logfiles));
}
# This subroutine returns a base (answer) filename with a number
# appended to the end corresponding to how many logfiles (and thus
# base files) have been created in the current running test.
# NO PARAMETERS ARE PASSED TO THIS SUBROUTINE.
sub get_basefile
{
return ($base_filename . &num_suffix ($num_of_logfiles));
}
# This subroutine returns a difference filename with a number appended
# to the end corresponding to how many logfiles (and thus diff files)
# have been created in the current running test.
sub get_difffile
{
return ($diff_filename . &num_suffix ($num_of_logfiles));
}
# This subroutine returns a command filename with a number appended
# to the end corresponding to how many logfiles (and thus command files)
# have been created in the current running test.
sub get_runfile
{
return ($run_filename . &num_suffix ($num_of_logfiles));
}
# just like logfile, only a generic tmp filename for use by the test.
# they are automatically cleaned up unless -keep was used, or the test fails.
# Pass an argument of 1 to return the same filename as the previous call.
sub get_tmpfile
{
local($no_increment) = @_;
$num_of_tmpfiles += !$no_increment;
return ($tmp_filename . &num_suffix ($num_of_tmpfiles));
}
1;