mirror of
https://git.savannah.gnu.org/git/make.git
synced 2024-10-23 20:59:55 +00:00
5eff618c8c
Reset the temp directory for every test to a local directory, then after each test see if any new temp files were created and not deleted: if they were then fail the test. Rather than delete the temp files we leave them there and avoid reporting files that were seen before, so the user can investigate them. Rewrite the temp_stdin tests to rely on this built-in behavior rather than implementing the checks directly. * tests/test_driver.pl: Create a $TEMPDIR variable pointing to a temporary directory outside the test temp directory. (toplevel) Before starting any tests create a temp directory and set the POSIX and Windows temp directory environment variables to use it. (compare_output) Check the contents of the temp directory. If any new files have appeared, fail the test. * tests/scripts/features/temp_stdin: Remove check_tempfile() and all users of it, plus setting of temp environment variables.
1550 lines
42 KiB
Perl
1550 lines
42 KiB
Perl
#!/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-2022 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$
|
|
|
|
use Config;
|
|
use Cwd;
|
|
use File::Spec;
|
|
use File::Temp;
|
|
|
|
# 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;
|
|
|
|
$port_type = undef;
|
|
$osname = undef;
|
|
$vos = undef;
|
|
$pathsep = undef;
|
|
|
|
# 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';
|
|
|
|
$diff_name = undef;
|
|
|
|
# Create a temporary directory that tests can use, outside the temp
|
|
# directory that make is using.
|
|
$TEMPDIR = File::Temp->newdir();
|
|
|
|
# Path to Perl
|
|
$perl_name = $^X;
|
|
if ($^O ne 'VMS') {
|
|
$perl_name .= $Config{_exe} unless $perl_name =~ m/$Config{_exe}$/i;
|
|
}
|
|
|
|
sub which {
|
|
my $cmd = $_[0];
|
|
|
|
# Poor man's File::Which
|
|
my ($v,$d,$f) = File::Spec->splitpath($cmd);
|
|
if ($d) {
|
|
# The command has a pathname so don't look for it in PATH.
|
|
# Use forward-slashes even on Windows, else it fails in recipes.
|
|
(-f $cmd and -x _) or return undef;
|
|
$cmd =~ tr,\\,/,;
|
|
return $cmd;
|
|
}
|
|
|
|
my @ext;
|
|
if ($port_type eq 'UNIX' || $port_type eq 'VMS-DCL') {
|
|
@ext = ('');
|
|
} else {
|
|
@ext = index($f, '.') == -1 ? () : ('');
|
|
push @ext, split /;/, $ENV{PATHEXT};
|
|
}
|
|
|
|
foreach my $dir (File::Spec->path()) {
|
|
foreach my $e (@ext) {
|
|
my $p = File::Spec->catfile($dir, "$cmd$e");
|
|
(-f $p and -x _) or next;
|
|
# Use forward-slashes even on Windows, else it fails in recipes.
|
|
$p =~ tr,\\,/,;
|
|
return $p;
|
|
}
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
# %makeENV is the cleaned-out environment. Tests must not modify it.
|
|
my %makeENV = ();
|
|
|
|
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};
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# Returns a string-ified version of cmd which is a value provided to exec()
|
|
# so it can either be a ref of a list or a string.
|
|
sub cmd2str
|
|
{
|
|
my $cmd = $_[0];
|
|
if (!ref($cmd)) {
|
|
return $cmd;
|
|
}
|
|
|
|
my @c;
|
|
foreach (@$cmd) {
|
|
if (/[][#;"*?&|<>(){}\$`^~!]/) {
|
|
s/\'/\'\\'\'/g;
|
|
push @c, "'$_'";
|
|
} else {
|
|
push @c, $_;
|
|
}
|
|
}
|
|
return join(' ', @c);
|
|
}
|
|
|
|
sub toplevel
|
|
{
|
|
%origENV = %ENV unless $^O eq 'VMS';
|
|
|
|
# Pull in benign variables from the user's environment
|
|
|
|
foreach (# POSIX-specific things
|
|
'TZ', 'TMPDIR', 'HOME', 'USER', 'LOGNAME', 'PATH',
|
|
'LD_LIBRARY_PATH',
|
|
# *SAN things
|
|
'ASAN_OPTIONS', 'UBSAN_OPTIONS',
|
|
# Purify things
|
|
'PURIFYOPTIONS',
|
|
# Windows-specific things
|
|
'Path', 'SystemRoot', 'TEMP', 'TMP', 'USERPROFILE', 'PATHEXT',
|
|
# DJGPP-specific things
|
|
'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';
|
|
$makeENV{LANG} = 'C';
|
|
$makeENV{LANGUAGE} = 'C';
|
|
|
|
# Replace the environment with the new one
|
|
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
|
|
$tempdir = "_tmp"; # A temporary directory
|
|
$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
|
|
|
|
$perl_name = which($perl_name);
|
|
|
|
# See if we have a diff
|
|
$diff_name = which('diff');
|
|
if (!$diff_name) {
|
|
print "No diff found; differences will not be shown\n";
|
|
}
|
|
|
|
&set_defaults; # suite-defined
|
|
|
|
&parse_command_line (@ARGV);
|
|
|
|
print "OS name = '$osname'\n" if $debug;
|
|
|
|
$temppath = File::Spec->rel2abs($tempdir);
|
|
|
|
if (-d $temppath) {
|
|
print "Clearing $temppath...\n";
|
|
&remove_directory_tree("$temppath/")
|
|
or &error ("Couldn't wipe out $temppath: $!\n");
|
|
} else {
|
|
mkdir ($temppath, 0777) or error ("Cannot mkdir $temppath: $!\n");
|
|
}
|
|
|
|
# This is used by POSIX systems
|
|
$makeENV{TMPDIR} = $temppath;
|
|
|
|
# These are used on Windows
|
|
$makeENV{TMP} = $temppath;
|
|
$makeENV{TEMP} = $temppath;
|
|
|
|
$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('/', $cwdpath);
|
|
|
|
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/")
|
|
or &error ("Couldn't wipe out $workpath: $!\n");
|
|
} else {
|
|
mkdir ($workpath, 0777) or &error ("Cannot 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"
|
|
or mkdir ("$workpath/$dir", 0777)
|
|
or &error ("Couldn't mkdir $workpath/$dir: $!\n");
|
|
}
|
|
}
|
|
} else {
|
|
print "Finding tests...\n";
|
|
opendir (SCRIPTDIR, $scriptpath)
|
|
or &error ("Couldn't opendir $scriptpath: $!\n");
|
|
@dirs = grep (!/^(\..*|CVS|RCS)$/, readdir (SCRIPTDIR) );
|
|
closedir (SCRIPTDIR);
|
|
foreach my $dir (@dirs) {
|
|
next if ($dir =~ /^(\..*|CVS|RCS)$/ || ! -d "$scriptpath/$dir");
|
|
push (@rmdirs, $dir);
|
|
# VMS can have overlaid file systems, so directories may repeat.
|
|
next if -d "$workpath/$dir";
|
|
mkdir ("$workpath/$dir", 0777)
|
|
or &error ("Couldn't mkdir $workpath/$dir: $!\n");
|
|
opendir (SCRIPTDIR, "$scriptpath/$dir")
|
|
or &error ("Couldn't opendir $scriptpath/$dir: $!\n");
|
|
@files = grep (!/^(\..*|CVS|RCS|.*~)$/, readdir (SCRIPTDIR) );
|
|
closedir (SCRIPTDIR);
|
|
foreach my $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 my $dir (@rmdirs) {
|
|
rmdir ("$workpath/$dir");
|
|
}
|
|
|
|
rmdir ($temppath);
|
|
|
|
$| = 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;
|
|
}
|
|
|
|
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 : '';
|
|
$vos = 0;
|
|
$pathsep = "/";
|
|
|
|
# find the type of the port. We do this up front to have a single
|
|
# point of change if it needs to be tweaked.
|
|
#
|
|
# This is probably not specific enough.
|
|
#
|
|
if ($osname =~ /MSWin32/i || $osname =~ /Windows/i
|
|
|| $osname =~ /MINGW32/i || $osname =~ /CYGWIN_NT/i) {
|
|
$port_type = 'W32';
|
|
}
|
|
# Bleah, the osname is so variable on DOS. This kind of bites.
|
|
# Well, as far as I can tell if we check for some text at the
|
|
# beginning of the line with either no spaces or a single space, then
|
|
# a D, then either "OS", "os", or "ev" and a space. That should
|
|
# match and be pretty specific.
|
|
elsif ($osname =~ /^([^ ]*|[^ ]* [^ ]*)D(OS|os|ev) /) {
|
|
$port_type = 'DOS';
|
|
}
|
|
# Check for OS/2
|
|
elsif ($osname =~ m%OS/2%) {
|
|
$port_type = 'OS/2';
|
|
}
|
|
|
|
# VMS has a GNV Unix mode or a DCL mode.
|
|
# The SHELL environment variable should not be defined in VMS-DCL mode.
|
|
elsif ($osname eq 'VMS' && !defined $ENV{"SHELL"}) {
|
|
$port_type = 'VMS-DCL';
|
|
}
|
|
# Everything else, right now, is UNIX. Note that we should integrate
|
|
# the VOS support into this as well and get rid of $vos; we'll do
|
|
# that next time.
|
|
else {
|
|
$port_type = 'UNIX';
|
|
}
|
|
|
|
if ($osname eq 'VMS') {
|
|
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") and close (TOUCHFD))
|
|
or $short_filenames = 1;
|
|
unlink ("fancy.file.name") or $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) or &error ("Couldn't create .ostest: $!\n", 1);
|
|
open (TOUCHFD, "> .ostest>ick") and close (TOUCHFD);
|
|
chdir (".ostest") or &error ("Couldn't chdir to .ostest: $!\n", 1);
|
|
}
|
|
|
|
if (! $short_filenames && -f "ick") {
|
|
$osname = "vos";
|
|
$vos = 1;
|
|
$pathsep = ">";
|
|
|
|
} elsif ($osname eq '') {
|
|
# the following is regrettably gnarly, 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)";
|
|
}
|
|
}
|
|
}
|
|
|
|
if (! $short_filenames) {
|
|
chdir ("..") or &error ("Couldn't chdir to ..: $!\n", 1);
|
|
unlink (".ostest>ick");
|
|
rmdir (".ostest") or &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 =~ /^-usage$/i) {
|
|
&print_usage;
|
|
exit 0;
|
|
}
|
|
if ($option =~ /^-(h|help)$/i) {
|
|
&print_help;
|
|
exit 0;
|
|
}
|
|
|
|
if ($option =~ /^-debug$/i) {
|
|
print "\nDEBUG ON\n";
|
|
$debug = 1;
|
|
|
|
} 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
|
|
{
|
|
my $num = shift @_;
|
|
my $newnum;
|
|
|
|
while (@_) {
|
|
$newnum = shift @_;
|
|
if ($newnum > $num) {
|
|
$num = $newnum;
|
|
}
|
|
}
|
|
|
|
return $num;
|
|
}
|
|
|
|
sub print_centered
|
|
{
|
|
my ($width, $string) = @_;
|
|
|
|
if (length ($string)) {
|
|
my $pad = " " x ( ($width - length ($string) + 1) / 2);
|
|
print "$pad$string";
|
|
}
|
|
}
|
|
|
|
sub print_banner
|
|
{
|
|
# $testee is suite-defined
|
|
my $info = "Running tests for $testee on $osname";
|
|
my $len = &max (length($info), length($testee_version), 77) + 2;
|
|
my $line = ("-" x $len) . "\n";
|
|
|
|
&print_centered ($len, $line);
|
|
&print_centered ($len, $info."\n");
|
|
&print_centered ($len, $testee_version);
|
|
&print_centered ($len, $line);
|
|
print "\n";
|
|
}
|
|
|
|
sub run_all_tests
|
|
{
|
|
# Make sure we always run the tests from the current directory
|
|
unshift(@INC, cwd());
|
|
|
|
$categories_run = 0;
|
|
|
|
# Make a copy of STDIN so we can reset it
|
|
open(INCOPY, "<&STDIN");
|
|
|
|
# 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 = '.';
|
|
}
|
|
|
|
$lasttest = '';
|
|
# $testname is published
|
|
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";
|
|
$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";
|
|
|
|
-f $perl_testname or die "Invalid test: $testname\n\n";
|
|
|
|
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;
|
|
|
|
# Reset STDIN from the copy in case it was changed
|
|
open(STDIN, "<&INCOPY");
|
|
|
|
++$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";
|
|
}
|
|
|
|
close(INCOPY);
|
|
}
|
|
|
|
# If the keep flag is not set, this subroutine deletes all filenames that
|
|
# are sent to it.
|
|
|
|
sub rmfiles
|
|
{
|
|
my (@files) = @_;
|
|
|
|
if (!$keep) {
|
|
return (unlink @files);
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
sub print_standard_usage
|
|
{
|
|
my ($plname, @moreusage) = @_;
|
|
|
|
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
|
|
{
|
|
my (@morehelp) = @_;
|
|
my $t = " ";
|
|
|
|
my $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) {
|
|
my $tline = $line;
|
|
if (substr ($tline, 0, 1) eq "\t") {
|
|
substr ($tline, 0, 1) = $t;
|
|
}
|
|
print "$tline\n";
|
|
}
|
|
}
|
|
|
|
#######################################################################
|
|
########### Generic Test Driver Subroutines ###########
|
|
#######################################################################
|
|
|
|
sub get_caller
|
|
{
|
|
my $depth = defined ($_[0]) ? $_[0] : 1;
|
|
my ($pkg, $filename, $linenum) = caller ($depth + 1);
|
|
return "$filename: $linenum";
|
|
}
|
|
|
|
sub error
|
|
{
|
|
my $message = $_[0];
|
|
my $caller = &get_caller (1);
|
|
|
|
if (defined ($_[1])) {
|
|
$caller = &get_caller ($_[1] + 1) . " -> $caller";
|
|
}
|
|
|
|
die "$caller: $message";
|
|
}
|
|
|
|
my %old_tempfiles = ();
|
|
|
|
sub compare_output
|
|
{
|
|
my ($answer, $logfile) = @_;
|
|
my ($slurp, $answer_matched, $extra) = ('', 0, 0);
|
|
|
|
++$tests_run;
|
|
|
|
my @tf = ();
|
|
foreach my $file (glob(File::Spec->catfile($temppath, "*"))) {
|
|
if (!exists $old_tempfiles{$file}) {
|
|
push @tf, $file;
|
|
$old_tempfiles{$file} = 1;
|
|
}
|
|
}
|
|
if (@tf) {
|
|
open (LOGFILE, '>>', $logfile) or die "Cannot open log file $logfile: $!\n";
|
|
print LOGFILE "Leftover temporary files: @tf\n";
|
|
close (LOGFILE);
|
|
$extra = 1;
|
|
}
|
|
|
|
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
|
|
my ($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 ($keep || ! $answer_matched) {
|
|
&create_file(&get_basefile, $answer);
|
|
&create_file(&get_runfile, $command_string);
|
|
}
|
|
|
|
if ($answer_matched && $test_passed && !$extra) {
|
|
print "ok\n" if $debug;
|
|
++$tests_passed;
|
|
return 1;
|
|
}
|
|
|
|
if (! $answer_matched) {
|
|
print "DIFFERENT OUTPUT\n" if $debug;
|
|
|
|
print "\nCreating Difference File ...\n" if $debug;
|
|
|
|
# Create the difference file
|
|
my $base = get_basefile();
|
|
if ($diff_name) {
|
|
my $command = "$diff_name -c $base $logfile";
|
|
&run_command_with_output(get_difffile(), $command);
|
|
} else {
|
|
create_file(get_difffile(), "Log file $logfile differs from base file $base\n");
|
|
}
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub read_file_into_string
|
|
{
|
|
my ($filename) = @_;
|
|
my $oldslash = $/;
|
|
undef $/;
|
|
|
|
open (RFISFILE, '<', $filename) or return "";
|
|
my $slurp = <RFISFILE>;
|
|
close (RFISFILE);
|
|
|
|
$/ = $oldslash;
|
|
|
|
return $slurp;
|
|
}
|
|
|
|
my @OUTSTACK = ();
|
|
my @ERRSTACK = ();
|
|
|
|
sub attach_default_output
|
|
{
|
|
my ($filename) = @_;
|
|
|
|
if ($vos)
|
|
{
|
|
my $code = system "++attach_default_output_hack $filename";
|
|
$code == -2 or &error ("ado 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
|
|
{
|
|
if ($vos)
|
|
{
|
|
my $code = system "++detach_default_output_hack";
|
|
$code == -2 or &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);
|
|
}
|
|
|
|
sub _run_with_timeout
|
|
{
|
|
my $code;
|
|
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(@_);
|
|
#alarm 0;
|
|
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;
|
|
}
|
|
|
|
} elsif ($port_type eq 'W32') {
|
|
my $pid = system(1, @_);
|
|
$pid > 0 or die "Cannot execute $_[0]\n";
|
|
local $SIG{ALRM} = sub {
|
|
my $e = $ERRSTACK[0];
|
|
print $e "\nTest timed out after $test_timeout seconds\n";
|
|
kill -9, $pid;
|
|
die "timeout\n";
|
|
};
|
|
alarm $test_timeout;
|
|
my $r = waitpid($pid, 0);
|
|
alarm 0;
|
|
$r == -1 and die "No such pid: $pid\n";
|
|
# This shouldn't happen since we wait forever or timeout via SIGALRM
|
|
$r == 0 and die "No process exited.\n";
|
|
$code = $?;
|
|
|
|
} else {
|
|
my $pid = fork();
|
|
if (! $pid) {
|
|
exec(@_) or die "exec: Cannot execute $_[0]: $!\n";
|
|
}
|
|
local $SIG{ALRM} = sub {
|
|
my $e = $ERRSTACK[0];
|
|
print $e "\nTest timed out after $test_timeout seconds\n";
|
|
# Resend the alarm to our process group to kill the children.
|
|
$SIG{ALRM} = 'IGNORE';
|
|
kill -14, $$;
|
|
die "timeout\n";
|
|
};
|
|
alarm $test_timeout;
|
|
my $r = waitpid($pid, 0);
|
|
alarm 0;
|
|
$r == -1 and die "No such pid: $pid\n";
|
|
# This shouldn't happen since we wait forever or timeout via SIGALRM
|
|
$r == 0 and die "No process exited.\n";
|
|
$code = $?;
|
|
}
|
|
|
|
return $code;
|
|
}
|
|
|
|
# This runs a command without any debugging info.
|
|
sub _run_command
|
|
{
|
|
my $orig = $SIG{ALRM};
|
|
my $code = eval { _run_with_timeout(@_); };
|
|
$SIG{ALRM} = $orig;
|
|
|
|
# Reset then environment so that it's clean for the next test.
|
|
resetENV();
|
|
|
|
if ($@) {
|
|
# The eval failed. If it wasn't SIGALRM then die.
|
|
$@ eq "timeout\n" or die "Command failed: $@";
|
|
$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
|
|
{
|
|
my ($targetdir) = @_;
|
|
my ($nuketop) = 1;
|
|
|
|
my $ch = substr ($targetdir, length ($targetdir) - 1);
|
|
if ($ch eq "/" || $ch eq $pathsep) {
|
|
$targetdir = substr ($targetdir, 0, length ($targetdir) - 1);
|
|
$nuketop = 0;
|
|
}
|
|
|
|
-e $targetdir or return 1;
|
|
|
|
&remove_directory_tree_inner ("RDT00", $targetdir) or return 0;
|
|
if ($nuketop && !rmdir ($targetdir)) {
|
|
print "Cannot remove $targetdir: $!\n";
|
|
return 0;
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
sub remove_directory_tree_inner
|
|
{
|
|
my ($dirhandle, $targetdir) = @_;
|
|
|
|
opendir ($dirhandle, $targetdir) or return 0;
|
|
my $subdirhandle = $dirhandle;
|
|
$subdirhandle++;
|
|
while (my $object = readdir ($dirhandle)) {
|
|
$object =~ /^(\.\.?|CVS|RCS)$/ and next;
|
|
$object = "$targetdir$pathsep$object";
|
|
|
|
lstat ($object);
|
|
if (-d _ && &remove_directory_tree_inner ($subdirhandle, $object)) {
|
|
if (!rmdir($object)) {
|
|
print "Cannot remove $object: $!\n";
|
|
return 0;
|
|
}
|
|
} else {
|
|
if ($^O ne 'VMS') {
|
|
if (!unlink $object) {
|
|
print "Cannot unlink $object: $!\n";
|
|
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
|
|
#{
|
|
# my (@filenames) = @_;
|
|
# my $now = time;
|
|
#
|
|
# foreach my $file (@filenames) {
|
|
# utime ($now, $now, $file)
|
|
# or (open (TOUCHFD, ">> $file") and close (TOUCHFD))
|
|
# or &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
|
|
{
|
|
foreach my $file (@_) {
|
|
(open(T, '>>', $file) and print(T "\n") and close(T))
|
|
or &error("Couldn't touch $file: $!\n", 1);
|
|
}
|
|
|
|
return @_;
|
|
}
|
|
|
|
# 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
|
|
{
|
|
my $off = shift;
|
|
|
|
&touch(@_);
|
|
|
|
foreach my $f (@_) {
|
|
my @s = stat($f);
|
|
utime($s[8]+$off, $s[9]+$off, $f);
|
|
}
|
|
|
|
return @_;
|
|
}
|
|
|
|
# open a file, write some stuff to it, and close it.
|
|
|
|
sub create_file
|
|
{
|
|
my ($filename, @lines) = @_;
|
|
|
|
open (CF, "> $filename") or &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
|
|
{
|
|
my ($basedir, %dirtree) = @_;
|
|
|
|
&remove_directory_tree ("$basedir");
|
|
mkdir ($basedir, 0777) or &error ("Couldn't mkdir $basedir: $!\n", 1);
|
|
|
|
foreach my $path (sort keys (%dirtree)) {
|
|
if ($dirtree {$path} =~ /^DIR$/) {
|
|
mkdir ("$basedir/$path", 0777)
|
|
or &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")
|
|
or &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
|
|
{
|
|
my ($basedir, %dirtree) = @_;
|
|
my $bogus = 0;
|
|
|
|
opendir (DIR, $basedir) or &error ("Couldn't open $basedir: $!\n", 1);
|
|
my @allfiles = grep (!/^(\.\.?|CVS|RCS)$/, readdir (DIR) );
|
|
closedir (DIR);
|
|
if ($debug) {
|
|
print "dirtree: (%dirtree)\n$basedir: (@allfiles)\n";
|
|
}
|
|
|
|
foreach my $path (sort keys (%dirtree))
|
|
{
|
|
if ($debug) {
|
|
print "Checking $path ($dirtree{$path}).\n";
|
|
}
|
|
|
|
my $found = 0;
|
|
foreach my $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") ) {
|
|
my @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 "*") {
|
|
my $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:(.*)$/) {
|
|
my $target = $1;
|
|
if (!-l _) {
|
|
print "compare_dir_tree: $path is not a link.\n";
|
|
$bogus = 1;
|
|
next;
|
|
}
|
|
|
|
my $contents = readlink ("$basedir/$path");
|
|
$contents =~ tr/>/\//;
|
|
my $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 my $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
|
|
{
|
|
my ($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
|
|
{
|
|
my ($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
|
|
{
|
|
my ($no_increment) = @_;
|
|
|
|
$num_of_tmpfiles += !$no_increment;
|
|
|
|
return ($tmp_filename . &num_suffix ($num_of_tmpfiles));
|
|
}
|
|
|
|
1;
|