diff --git a/tests/run_make_tests.pl b/tests/run_make_tests.pl
index f49f1d7e..57dfd49d 100644
--- a/tests/run_make_tests.pl
+++ b/tests/run_make_tests.pl
@@ -27,6 +27,21 @@
# You should have received a copy of the GNU General Public License along with
# this program. If not, see .
+# Add the working directory to @INC and load the test driver
+use FindBin;
+use lib "$FindBin::Bin";
+
+require "test_driver.pl";
+
+use File::Spec::Functions qw(:DEFAULT splitdir splitpath catpath);
+
+use Cwd;
+$cwdpath = cwd();
+($cwdvol, $cwddir, $_) = splitpath($cwdpath, 1);
+
+# Some target systems might not have the POSIX module...
+$has_POSIX = eval { require "POSIX.pm" };
+
%FEATURES = ();
$valgrind = 0; # invoke make with valgrind
@@ -36,7 +51,12 @@ $massif_args = '--num-callers=15 --tool=massif --alloc-fn=xmalloc --alloc-fn=xca
$pure_log = undef;
# The location of the GNU make source directory
-$srcdir = '';
+$srcdir = undef;
+$srcvol = undef;
+
+# The location of the build directory
+$blddir = undef;
+$bldvol = undef;
$command_string = '';
@@ -67,24 +87,71 @@ if ($^O eq 'VMS')
$CMD_rmfile = 'delete_file -no_ask';
}
-use FindBin;
-use lib "$FindBin::Bin";
-
-require "test_driver.pl";
-
%CONFIG_FLAGS = ();
-my $statnm = "$FindBin::Bin/../config.status";
-if (open(my $fh, '<', $statnm)) {
- while (my $line = <$fh>) {
- $line =~ m/^[SD]\["([^\"]+)"\]=" *(.*)"/ and $CONFIG_FLAGS{$1} = $2;
- }
-} else {
- warn "Failed to open $statnm: $!";
-}
+# Find the strings that will be generated for various error codes.
+# We want them from the C locale regardless of our current locale.
-# Some target systems might not have the POSIX module...
-$has_POSIX = eval { require "POSIX.pm" };
+$ERR_no_such_file = undef;
+$ERR_read_only_file = undef;
+$ERR_unreadable_file = undef;
+$ERR_noexe_file = undef;
+$ERR_exe_dir = undef;
+
+{
+ use locale;
+
+ my $loc = undef;
+ if ($has_POSIX) {
+ POSIX->import(qw(locale_h));
+ # Windows has POSIX locale, but only LC_ALL not LC_MESSAGES
+ $loc = POSIX::setlocale(&POSIX::LC_ALL);
+ POSIX::setlocale(&POSIX::LC_ALL, 'C');
+ }
+
+ if (open(my $F, '<', 'file.none')) {
+ print "Opened non-existent file! Skipping related tests.\n";
+ } else {
+ $ERR_no_such_file = "$!";
+ }
+
+ unlink('file.out');
+ touch('file.out');
+
+ chmod(0444, 'file.out');
+ if (open(my $F, '>', 'file.out')) {
+ print "Opened read-only file! Skipping related tests.\n";
+ close($F);
+ } else {
+ $ERR_read_only_file = "$!";
+ }
+
+ $_ = `./file.out 2>/dev/null`;
+ if ($? == 0) {
+ print "Executed non-executable file! Skipping related tests.\n";
+ } else {
+ $ERR_nonexe_file = "$!";
+ }
+
+ $_ = `./. 2>/dev/null`;
+ if ($? == 0) {
+ print "Executed directory! Skipping related tests.\n";
+ } else {
+ $ERR_exe_dir = "$!";
+ }
+
+ chmod(0000, 'file.out');
+ if (open(my $F, '<', 'file.out')) {
+ print "Opened unreadable file! Skipping related tests.\n";
+ close($F);
+ } else {
+ $ERR_unreadable_file = "$!";
+ }
+
+ unlink('file.out') or die "Failed to delete file.out: $!\n";
+
+ $loc and POSIX::setlocale(&POSIX::LC_ALL, $loc);
+}
#$SIG{INT} = sub { print STDERR "Caught a signal!\n"; die @_; };
@@ -103,7 +170,7 @@ sub valid_option
if ($option =~ /^-srcdir$/i) {
$srcdir = shift @argv;
- if (! -f "$srcdir/src/gnumake.h") {
+ if (! -f catfile($srcdir, 'src', 'gnumake.h')) {
print "$option $srcdir: Not a valid GNU make source directory.\n";
exit 0;
}
@@ -155,7 +222,7 @@ sub subst_make_string
s/#MAKEPATH#/$mkpath/g;
s/#MAKE#/$make_name/g;
s/#PERL#/$perl_name/g;
- s/#PWD#/$pwd/g;
+ s/#PWD#/$cwdpath/g;
return $_;
}
@@ -170,7 +237,7 @@ sub run_make_test
if (! defined $makestring) {
defined $old_makefile
- || die "run_make_test(undef) invoked before run_make_test('...')\n";
+ or die "run_make_test(undef) invoked before run_make_test('...')\n";
$makefile = $old_makefile;
} else {
if (! defined($makefile)) {
@@ -182,9 +249,9 @@ sub run_make_test
$makestring = subst_make_string($makestring);
# Populate the makefile!
- open(MAKEFILE, "> $makefile") || die "Failed to open $makefile: $!\n";
+ open(MAKEFILE, "> $makefile") or die "Failed to open $makefile: $!\n";
print MAKEFILE $makestring;
- close(MAKEFILE) || die "Failed to write $makefile: $!\n";
+ close(MAKEFILE) or die "Failed to write $makefile: $!\n";
}
# Do the same processing on $answer as we did on $makestring.
@@ -317,8 +384,7 @@ sub run_make_with_options {
# If we have a purify log, save it
$tn = $pure_testname . ($num_of_logfiles ? ".$num_of_logfiles" : "");
print("Renaming purify log file to $tn\n") if $debug;
- rename($pure_log, "$tn")
- || die "Can't rename $log to $tn: $!\n";
+ rename($pure_log, "$tn") or die "Can't rename $log to $tn: $!\n";
++$purify_errors;
} else {
unlink($pure_log);
@@ -363,168 +429,220 @@ sub print_help
"\tRun the test suite under valgrind's memcheck tool.",
"\tChange the default valgrind args with the VALGRIND_ARGS env var.",
"-massif",
- "\tRun the test suite under valgrind's massif toool.",
+ "\tRun the test suite under valgrind's massif tool.",
"\tChange the default valgrind args with the VALGRIND_ARGS env var."
);
}
-sub get_this_pwd {
- if ($has_POSIX) {
- $__pwd = POSIX::getcwd();
- } elsif ($vos) {
- $__pwd = `++(current_dir)`;
- } else {
- # No idea... just try using pwd as a last resort.
- chop ($__pwd = `pwd`);
- }
-
- return $__pwd;
-}
-
sub set_defaults
{
- # $profile = 1;
- $testee = "GNU make";
- $make_path = "make";
- $tmpfilesuffix = "mk";
- $pwd = &get_this_pwd;
+ # $profile = 1;
+ $testee = "GNU make";
+ $make_path = "make";
+ $tmpfilesuffix = "mk";
+}
+
+# This is no longer used: we import config-flags.pm instead
+# sub parse_status
+# {
+# if (open(my $fh, '<', "$_[0]/config.status")) {
+# while (my $line = <$fh>) {
+# $line =~ m/^[SD]\["([^\"]+)"\]=" *(.*)"/ and $CONFIG_FLAGS{$1} = $2;
+# }
+# return 1;
+# }
+# return 0;
+# }
+
+sub find_prog
+{
+ my $prog = $_[0];
+ my ($v, $d, $f) = splitpath($prog);
+
+ # If there's no directory then we need to search the PATH
+ if (! $d) {
+ foreach my $e (path()) {
+ $prog = catfile($e, $f);
+ -x $prog or continue;
+ ($v, $d, $f) = splitpath($prog);
+ last;
+ }
+ }
+
+ return ($v, $d, $f);
}
sub set_more_defaults
{
- local($string);
- local($index);
+ local($string);
+ local($index);
- # On DOS/Windows system the filesystem apparently can't track
- # timestamps with second granularity (!!). Change the sleep time
- # needed to force a file to be considered "old".
- $wtime = $port_type eq 'UNIX' ? 1 : $port_type eq 'OS/2' ? 2 : 4;
+ # Now that we have located make_path, locate the srcdir and blddir
+ my ($mpv, $mpd, $mpf) = find_prog($make_path);
- # Find the full pathname of Make. For DOS systems this is more
- # complicated, so we ask make itself.
- if ($osname eq 'VMS') {
- $port_type = 'VMS-DCL' unless defined $ENV{"SHELL"};
- # On VMS pre-setup make to be found with simply 'make'.
- $make_path = 'make';
- } else {
- create_file('make.mk', 'all:;$(info $(MAKE))');
- my $mk = `$make_path -sf make.mk`;
- unlink('make.mk');
- chop $mk;
- $mk or die "FATAL ERROR: Cannot determine the value of \$(MAKE)\n";
- $make_path = $mk;
- }
+ # We have a make program so try to compute the blddir.
+ if ($mpd) {
+ my $f = catpath($mpv, catdir($mpd, 'tests'), 'config-flags.pm');
+ if (-f $f) {
+ $bldvol = $mpv;
+ $blddir = $mpd;
+ }
+ }
- # Ask make what shell to use
- create_file('shell.mk', 'all:;$(info $(SHELL))');
- $sh_name = `$make_path -sf shell.mk`;
- unlink('shell.mk');
- chop $sh_name;
- if (! $sh_name) {
- print "Cannot determine shell\n";
- $is_posix_sh = 0;
- } else {
- my $o = `$sh_name -c ': do nothing' 2>&1`;
- $is_posix_sh = $? == 0 && $o == '';
- }
+ # If srcdir wasn't provided on the command line, try to find it.
+ if (! $srcdir && $blddir) {
+ # See if the blddir is the srcdir
+ my $f = catpath($bldvol, catdir($blddir, 'src'), 'gnumake.h');
+ if (-f $f) {
+ $srcdir = $blddir;
+ $srcvol = $bldvol;
+ }
+ }
- $string = `$make_path -v`;
- $string =~ /^(GNU Make [^,\n]*)/ or die "$make_path is not GNU make. Version:\n$string";
- $testee_version = "$1\n";
+ if (! $srcdir) {
+ # Not found, see if our parent is the source dir
+ my $f = catpath($cwdvol, catdir(updir(), 'src'), 'gnumake.h');
+ if (-f $f) {
+ $srcdir = updir();
+ $srcvol = $cwdvol;
+ }
+ }
- create_file('null.mk', '');
+ # If we have srcdir but not blddir, set them equal
+ if ($srcdir && !$blddir) {
+ $blddir = $srcdir;
+ $bldvol = $srcvol;
+ }
- my $redir = '2>&1';
- $redir = '' if os_name eq 'VMS';
- $string = `$make_path -f null.mk $redir`;
- if ($string =~ /(.*): \*\*\* No targets\. Stop\./) {
- $make_name = $1;
- }
- else {
- $make_path =~ /^(?:.*$pathsep)?(.+)$/;
- $make_name = $1;
- }
+ # Load the config flags
+ if (!$blddir) {
+ warn "Cannot locate config-flags.pm (no blddir)\n";
+ } else {
+ my $f = catpath($bldvol, catdir($blddir, 'tests'), 'config-flags.pm');
+ if (! -f $f) {
+ warn "Cannot locate $f\n";
+ } else {
+ unshift(@INC, catpath($bldvol, catdir($blddir, 'tests'), ''));
+ require "config-flags.pm";
+ }
+ }
- # prepend pwd if this is a relative path (ie, does not
- # start with a slash, but contains one). Thanks for the
- # clue, Roland.
+ # On DOS/Windows system the filesystem apparently can't track
+ # timestamps with second granularity (!!). Change the sleep time
+ # needed to force a file to be considered "old".
+ $wtime = $port_type eq 'UNIX' ? 1 : $port_type eq 'OS/2' ? 2 : 4;
- if (index ($make_path, ":") != 1 && index ($make_path, "/") > 0)
- {
- $mkpath = "$pwd$pathsep$make_path";
- }
- else
- {
- $mkpath = $make_path;
- }
+ # Find the full pathname of Make. For DOS systems this is more
+ # complicated, so we ask make itself.
+ if ($osname eq 'VMS') {
+ $port_type = 'VMS-DCL' unless defined $ENV{"SHELL"};
+ # On VMS pre-setup make to be found with simply 'make'.
+ $make_path = 'make';
+ } else {
+ create_file('make.mk', 'all:;$(info $(MAKE))');
+ my $mk = `$make_path -sf make.mk`;
+ unlink('make.mk');
+ chop $mk;
+ $mk or die "FATAL ERROR: Cannot determine the value of \$(MAKE)\n";
+ $make_path = $mk;
+ }
+ ($mpv, $mpd, $mpf) = splitpath($make_path);
- # If srcdir wasn't provided on the command line, see if the
- # location of the make program gives us a clue. Don't fail if not;
- # we'll assume it's been installed into /usr/include or wherever.
- if (! $srcdir) {
- $make_path =~ /^(.*$pathsep)?/;
- my $d = $1 || '../';
- -f "${d}/src/gnumake.h" and $srcdir = $d;
- }
+ # Ask make what shell to use
+ create_file('shell.mk', 'all:;$(info $(SHELL))');
+ $sh_name = `$make_path -sf shell.mk`;
+ unlink('shell.mk');
+ chop $sh_name;
+ if (! $sh_name) {
+ print "Cannot determine shell\n";
+ $is_posix_sh = 0;
+ } else {
+ my $o = `$sh_name -c ': do nothing' 2>&1`;
+ $is_posix_sh = $? == 0 && $o eq '';
+ }
- # Not with the make program, so see if we can get it out of the makefile
- if (! $srcdir && open(MF, "< ../Makefile")) {
- local $/ = undef;
- $_ = ;
- close(MF);
- /^abs_srcdir\s*=\s*(.*?)\s*$/m;
- -f "$1/src/gnumake.h" and $srcdir = $1;
- }
+ $string = `$make_path -v`;
+ $string =~ /^(GNU Make [^,\n]*)/ or die "$make_path is not GNU make. Version:\n$string";
+ $testee_version = "$1\n";
- # Get Purify log info--if any.
+ create_file('null.mk', '');
- if (exists $ENV{PURIFYOPTIONS}
- && $ENV{PURIFYOPTIONS} =~ /.*-logfile=([^ ]+)/) {
- $pure_log = $1 || '';
- $pure_log =~ s/%v/$make_name/;
- $purify_errors = 0;
- }
+ my $redir = '2>&1';
+ $redir = '' if os_name eq 'VMS';
+ $string = `$make_path -f null.mk $redir`;
+ if ($string =~ /(.*): \*\*\* No targets\. Stop\./) {
+ $make_name = $1;
+ } else {
+ $make_name = $mpf;
+ }
- $string = `$make_path -j 2 -f null.mk $redir`;
- if ($string =~ /not supported/) {
- $parallel_jobs = 0;
- }
- else {
- $parallel_jobs = 1;
- }
+ # prepend pwd if this is a relative path (ie, does not
+ # start with a slash, but contains one). Thanks for the
+ # clue, Roland.
- unlink('null.mk');
+ if ($mpd && !file_name_is_absolute($make_path) && $cwdvol == $mpv) {
+ $mkpath = catpath($cwdvol, catdir($cwd, $mpd), $mpf);
+ } else {
+ $mkpath = $make_path;
+ }
- create_file('features.mk', 'all:;$(info $(.FEATURES))');
- %FEATURES = map { $_ => 1 } split /\s+/, `$make_path -sf features.mk`;
- unlink('features.mk');
+ # Not with the make program, so see if we can get it out of the makefile
+ if (! $srcdir && open(MF, '<', catfile(updir(), 'Makefile'))) {
+ local $/ = undef;
+ $_ = ;
+ close(MF);
+ /^abs_srcdir\s*=\s*(.*?)\s*$/m;
+ -f catfile($1, 'src', 'gnumake.h') and $srcdir = $1;
+ }
- # Set up for valgrind, if requested.
+ # Get Purify log info--if any.
- $make_command = $make_path;
+ if (exists $ENV{PURIFYOPTIONS}
+ && $ENV{PURIFYOPTIONS} =~ /.*-logfile=([^ ]+)/) {
+ $pure_log = $1 || '';
+ $pure_log =~ s/%v/$make_name/;
+ $purify_errors = 0;
+ }
- if ($valgrind) {
- my $args = $valgrind_args;
- open(VALGRIND, "> valgrind.out")
- || die "Cannot open valgrind.out: $!\n";
- # -q --leak-check=yes
- exists $ENV{VALGRIND_ARGS} and $args = $ENV{VALGRIND_ARGS};
- $make_path = "valgrind --log-fd=".fileno(VALGRIND)." $args $make_path";
- # F_SETFD is 2
- fcntl(VALGRIND, 2, 0) or die "fcntl(setfd) failed: $!\n";
- system("echo Starting on `date` 1>&".fileno(VALGRIND));
- print "Enabled valgrind support.\n";
- }
+ $string = `$make_path -j 2 -f null.mk $redir`;
+ if ($string =~ /not supported/) {
+ $parallel_jobs = 0;
+ }
+ else {
+ $parallel_jobs = 1;
+ }
- if ($debug) {
- print "Port type: $port_type\n";
- print "Make path: $make_path\n";
- print "Shell path: $sh_name".($is_posix_sh ? ' (POSIX)' : '')."\n";
- print "#PWD#: $pwd\n";
- print "#PERL#: $perl_name\n";
- print "#MAKEPATH#: $mkpath\n";
- print "#MAKE#: $make_name\n";
- }
+ unlink('null.mk');
+
+ create_file('features.mk', 'all:;$(info $(.FEATURES))');
+ %FEATURES = map { $_ => 1 } split /\s+/, `$make_path -sf features.mk`;
+ unlink('features.mk');
+
+ # Set up for valgrind, if requested.
+
+ $make_command = $make_path;
+
+ if ($valgrind) {
+ my $args = $valgrind_args;
+ open(VALGRIND, "> valgrind.out") or die "Cannot open valgrind.out: $!\n";
+ # -q --leak-check=yes
+ exists $ENV{VALGRIND_ARGS} and $args = $ENV{VALGRIND_ARGS};
+ $make_path = "valgrind --log-fd=".fileno(VALGRIND)." $args $make_path";
+ # F_SETFD is 2
+ fcntl(VALGRIND, 2, 0) or die "fcntl(setfd) failed: $!\n";
+ system("echo Starting on `date` 1>&".fileno(VALGRIND));
+ print "Enabled valgrind support.\n";
+ }
+
+ if ($debug) {
+ print "Port type: $port_type\n";
+ print "Make path: $make_path\n";
+ print "Shell path: $sh_name".($is_posix_sh ? ' (POSIX)' : '')."\n";
+ print "#PWD#: $cwdpath\n";
+ print "#PERL#: $perl_name\n";
+ print "#MAKEPATH#: $mkpath\n";
+ print "#MAKE#: $make_name\n";
+ }
}
sub setup_for_test
diff --git a/tests/scripts/features/archives b/tests/scripts/features/archives
index 8d88ee38..beceb46c 100644
--- a/tests/scripts/features/archives
+++ b/tests/scripts/features/archives
@@ -14,8 +14,6 @@ $port_type eq 'W32' and return -1;
# Create some .o files to work with
if ($osname eq 'VMS') {
- use Cwd;
- my $pwd = getcwd;
# VMS AR needs real object files at this time.
foreach $afile ('a1', 'a2', 'a3') {
# Use non-standard extension to prevent implicit rules from recreating
@@ -210,7 +208,7 @@ run_make_test(undef, $arvar, "#MAKE#: Nothing to be done for 'default'.\n");
unlink('foo.vhd');
if ($osname eq 'VMS') {
- remove_directory_tree("$pwd/artest");
+ remove_directory_tree("$cwdpath/artest");
} else {
remove_directory_tree('artest');
}
diff --git a/tests/scripts/features/reinvoke b/tests/scripts/features/reinvoke
index 4b26a694..d2a1f50c 100644
--- a/tests/scripts/features/reinvoke
+++ b/tests/scripts/features/reinvoke
@@ -55,7 +55,7 @@ include $(F)',
# Now try with the file we're not updating being the actual file we're
# including: this and the previous one test different parts of the code.
-run_make_test(undef, 'F=b', "[ -f b ] || echo >> b\nhello\n")
+run_make_test(undef, 'F=b', "[ -f b ] || echo >> b\nhello\n");
&rmfiles('a','b','c');
diff --git a/tests/scripts/features/vpath2 b/tests/scripts/features/vpath2
index 7e970a71..c8de29bc 100644
--- a/tests/scripts/features/vpath2
+++ b/tests/scripts/features/vpath2
@@ -13,10 +13,10 @@ open(MAKEFILE,"> $makefile");
# The Contents of the MAKEFILE ...
-print MAKEFILE "VPATH = $workdir:$sourcedir\n";
+print MAKEFILE "VPATH = $workdir:$scriptdir\n";
print MAKEFILE "vpath %.c foo\n";
print MAKEFILE "vpath %.c $workdir\n";
-print MAKEFILE "vpath %.c $sourcedir\n";
+print MAKEFILE "vpath %.c $scriptdir\n";
print MAKEFILE "vpath %.h $workdir\n";
print MAKEFILE "vpath %.c\n";
print MAKEFILE "vpath\n";
diff --git a/tests/scripts/functions/foreach b/tests/scripts/functions/foreach
index 451839a2..9badc52e 100644
--- a/tests/scripts/functions/foreach
+++ b/tests/scripts/functions/foreach
@@ -7,7 +7,7 @@ $details = "This is a test of the foreach function in gnu make.
This function starts with a space separated list of
names and a variable. Each name in the list is subsituted
into the variable and the given text evaluated. The general
-form of the command is $(foreach var,$list,$text). Several
+form of the command is $(foreach var,\$list,\$text). Several
types of foreach loops are tested\n";
diff --git a/tests/scripts/misc/bs-nl b/tests/scripts/misc/bs-nl
index fcb64470..fdf4aabc 100644
--- a/tests/scripts/misc/bs-nl
+++ b/tests/scripts/misc/bs-nl
@@ -139,7 +139,6 @@ sub xlate
s/\\r/\r/g;
s/\\t/\t/g;
s/\\f/\f/g;
- s/\\v/\v/g;
s/\\n/\n/g;
return $_;
}
diff --git a/tests/scripts/misc/general4 b/tests/scripts/misc/general4
index 72f3dbd0..835a9e4a 100644
--- a/tests/scripts/misc/general4
+++ b/tests/scripts/misc/general4
@@ -81,9 +81,7 @@ all: ; \@echo hi
# SV-56834 Ensure setting PATH in the makefile works properly
mkdir('sd', 0775);
-open(my $fh, '>', 'sd/foobar');
-print $fh "exit 0\n";
-close($fh);
+create_file('sd/foobar', "exit 0\n");
chmod 0755, 'sd/foobar';
run_make_test(q!
@@ -107,9 +105,7 @@ rmdir('sd');
# Ensure that local programs are not found if "." is not on the PATH
-open(my $fh, '>', 'foobar');
-print $fh "exit 0\n";
-close($fh);
+create_file('foobar', "exit 0\n");
chmod 0755, 'foobar';
run_make_test(q!
diff --git a/tests/scripts/options/dash-C b/tests/scripts/options/dash-C
index 47aee53a..7daf69f2 100644
--- a/tests/scripts/options/dash-C
+++ b/tests/scripts/options/dash-C
@@ -23,9 +23,11 @@ touch($example);
run_make_with_options("${testname}.mk", "-C $workdir clean", &get_logfile);
+use Cwd;
+
chdir $workdir;
-$wpath = &get_this_pwd;
-chdir $pwd;
+$wpath = cwd();
+chdir $cwdpath;
if (-f $example) {
$test_passed = 0;
@@ -49,10 +51,6 @@ touch($example);
run_make_with_options("${testname}.mk", "-C $workdir/ clean ext=slash", &get_logfile);
-chdir $workdir;
-$wpath = &get_this_pwd;
-chdir $pwd;
-
if (-f $example) {
$test_passed = 0;
}
diff --git a/tests/scripts/options/dash-I b/tests/scripts/options/dash-I
index d47a8d8a..5d2df389 100644
--- a/tests/scripts/options/dash-I
+++ b/tests/scripts/options/dash-I
@@ -50,10 +50,12 @@ $answer = "This is another included makefile\n";
&compare_output($answer,&get_logfile(1));
-$answer = "$mkpath ANOTHER -f $makefile
-${make_name}[1]: Entering directory '$pwd'
+$answer = subst_make_string("$mkpath ANOTHER -f $makefile
+#MAKE#[1]: Entering directory '#PWD#'
This is another included makefile
-${make_name}[1]: Leaving directory '$pwd'\n";
+#MAKE#[1]: Leaving directory '#PWD#'\n");
&run_make_with_options($makefile,"-I $workdir recurse",&get_logfile);
&compare_output($answer,&get_logfile(1));
+
+1;
diff --git a/tests/scripts/options/symlinks b/tests/scripts/options/symlinks
index a1bfce03..ce0c0f01 100644
--- a/tests/scripts/options/symlinks
+++ b/tests/scripts/options/symlinks
@@ -11,58 +11,57 @@ $details = "Verify that symlink handling with and without -L works properly.";
# check for it explicitly.
if ($port_type eq 'W32' || !( eval { symlink("",""); 1 })) {
- # This test is N/A
- -1;
-} else {
-
- # Set up a symlink sym -> dep
- # We'll make both dep and targ older than sym
- $pwd =~ m%/([^/]+)$%;
- $dirnm = $1;
- &utouch(-10, 'dep');
- &utouch(-5, 'targ');
- symlink("../$dirnm/dep", 'sym');
-
- # Without -L, nothing should happen
- # With -L, it should update targ
- run_make_test('targ: sym ; @echo make $@ from $<', '',
- "#MAKE#: 'targ' is up to date.");
- run_make_test(undef, '-L', "make targ from sym");
-
- # Now update dep; in all cases targ should be out of date.
- &touch('dep');
- run_make_test(undef, '', "make targ from sym");
- run_make_test(undef, '-L', "make targ from sym");
-
- # Now update targ; in all cases targ should be up to date.
- &touch('targ');
- run_make_test(undef, '', "#MAKE#: 'targ' is up to date.");
- run_make_test(undef, '-L', "#MAKE#: 'targ' is up to date.");
-
- # Add in a new link between sym and dep. Be sure it's newer than targ.
- sleep(1);
- rename('dep', 'dep1');
- symlink('dep1', 'dep');
-
- # Without -L, nothing should happen
- # With -L, it should update targ
- run_make_test(undef, '', "#MAKE#: 'targ' is up to date.");
- run_make_test(undef, '-L', "make targ from sym");
-
- rmfiles('targ', 'dep', 'sym', 'dep1');
-
- # Check handling when symlinks point to non-existent files. Without -L we
- # should get an error: with -L we should use the timestamp of the symlink.
-
- symlink("../$dirname/dep", 'sym');
- run_make_test('targ: sym ; @echo make $@ from $<', '',
- "#MAKE#: *** No rule to make target 'sym', needed by 'targ'. Stop.", 512);
-
- run_make_test('targ: sym ; @echo make $@ from $<', '-L',
- 'make targ from sym');
-
-
- rmfiles('targ', 'sym');
-
- 1;
+ # This test is N/A
+ return -1;
}
+
+# Set up a symlink sym -> dep
+# We'll make both dep and targ older than sym
+&utouch(-10, 'dep');
+&utouch(-5, 'targ');
+
+$dirnm = (splitdir($cwddir))[-1];
+symlink(catfile(updir(), $dirnm, 'dep'), 'sym');
+
+# Without -L, nothing should happen
+# With -L, it should update targ
+run_make_test('targ: sym ; @echo make $@ from $<', '',
+ "#MAKE#: 'targ' is up to date.");
+run_make_test(undef, '-L', "make targ from sym");
+
+# Now update dep; in all cases targ should be out of date.
+&touch('dep');
+run_make_test(undef, '', "make targ from sym");
+run_make_test(undef, '-L', "make targ from sym");
+
+# Now update targ; in all cases targ should be up to date.
+&touch('targ');
+run_make_test(undef, '', "#MAKE#: 'targ' is up to date.");
+run_make_test(undef, '-L', "#MAKE#: 'targ' is up to date.");
+
+# Add in a new link between sym and dep. Be sure it's newer than targ.
+sleep(1);
+rename('dep', 'dep1');
+symlink('dep1', 'dep');
+
+# Without -L, nothing should happen
+# With -L, it should update targ
+run_make_test(undef, '', "#MAKE#: 'targ' is up to date.");
+run_make_test(undef, '-L', "make targ from sym");
+
+rmfiles('targ', 'dep', 'sym', 'dep1');
+
+# Check handling when symlinks point to non-existent files. Without -L we
+# should get an error: with -L we should use the timestamp of the symlink.
+
+symlink("../$dirnm/dep", 'sym');
+run_make_test('targ: sym ; @echo make $@ from $<', '',
+ "#MAKE#: *** No rule to make target 'sym', needed by 'targ'. Stop.", 512);
+
+run_make_test('targ: sym ; @echo make $@ from $<', '-L',
+ 'make targ from sym');
+
+
+rmfiles('targ', 'sym');
+
+1;
diff --git a/tests/scripts/targets/DEFAULT b/tests/scripts/targets/DEFAULT
index f3d51484..955c5608 100644
--- a/tests/scripts/targets/DEFAULT
+++ b/tests/scripts/targets/DEFAULT
@@ -1,3 +1,5 @@
+# -*-perl-*-
+
$description = "The following test creates a makefile to override part\n"
."of one Makefile with Another Makefile with the .DEFAULT\n"
."rule.";
@@ -9,41 +11,21 @@ $details = "This tests the use of the .DEFAULT special target to say that \n"
."defined here but passes the target bar on to another makefile\n"
."which does have the target bar defined.\n";
-$makefile2 = &get_tmpfile;
+create_file('defsub.mk', q!
+bar: ; @echo Executing rule BAR
+!);
-open(MAKEFILE,"> $makefile");
+run_make_test(q!
+foo:; @echo Executing rule FOO
-# The Contents of the MAKEFILE ...
+.DEFAULT: ; @$(MAKE) -f defsub.mk $@
+!,
+ 'bar',"#MAKE#[1]: Entering directory '#PWD#'\n"
+ . "Executing rule BAR\n"
+ . "#MAKE#[1]: Leaving directory '#PWD#'\n");
-print MAKEFILE "foo:\n";
-print MAKEFILE "\t\@echo Executing rule FOO\n\n";
-print MAKEFILE ".DEFAULT:\n";
-print MAKEFILE "\t\@\$(MAKE) -f $makefile2 \$\@ \n";
+unlink('defsub.mk');
-# END of Contents of MAKEFILE
-
-close(MAKEFILE);
-
-
-open(MAKEFILE,"> $makefile2");
-
-print MAKEFILE "bar:\n";
-print MAKEFILE "\t\@echo Executing rule BAR\n\n";
-
-close(MAKEFILE);
-
-&run_make_with_options($makefile,'bar',&get_logfile);
-
-# Create the answer to what should be produced by this Makefile
-$answer = "${make_name}[1]: Entering directory '$pwd'\n"
- . "Executing rule BAR\n"
- . "${make_name}[1]: Leaving directory '$pwd'\n";
-
-# COMPARE RESULTS
-
-&compare_output($answer,&get_logfile(1));
-
-# This tells the test driver that the perl test script executed properly.
1;
diff --git a/tests/scripts/variables/CURDIR b/tests/scripts/variables/CURDIR
index ee7cacb1..1be54f1a 100644
--- a/tests/scripts/variables/CURDIR
+++ b/tests/scripts/variables/CURDIR
@@ -1,20 +1,16 @@
# -*-perl-*-
-$description = "This tests the CURDIR varaible.";
+$description = "This tests the CURDIR variable.";
$details = "Echo CURDIR both with and without -C. Also ensure overrides work.";
-open(MAKEFILE,"> $makefile");
-print MAKEFILE "all: ; \@echo \$(CURDIR)\n";
-close(MAKEFILE);
-
# TEST #1
# -------
-&run_make_with_options($makefile,"",&get_logfile);
-$answer = "$pwd\n";
-&compare_output($answer,&get_logfile(1));
-
+run_make_test(q!
+all: ; @echo $(CURDIR)
+!,
+ '', "#PWD#\n");
1;
diff --git a/tests/scripts/variables/automatic b/tests/scripts/variables/automatic
index 33c482df..0b2e4513 100644
--- a/tests/scripts/variables/automatic
+++ b/tests/scripts/variables/automatic
@@ -72,7 +72,7 @@ $answer = ".x\n$dir/foo.x\nx\n\$@.x\n$dir.x\nfoo.x\n$dir/bar.x\nbar.x\n";
&compare_output($answer, &get_logfile(1));
&run_make_with_options($makefile2, "$dir/x.z $dir/y.z", &get_logfile);
-$answer = ".x\n$dir/x.z.x\nx\n\$@.x\n$dir.x\nx.z.x\n.y\n$dir/y.z.y\n\y\n\$@.y\n$dir.y\ny.z.y\n";
+$answer = ".x\n$dir/x.z.x\nx\n\$@.x\n$dir.x\nx.z.x\n.y\n$dir/y.z.y\ny\n\$@.y\n$dir.y\ny.z.y\n";
&compare_output($answer, &get_logfile(1));
&run_make_with_options($makefile2, "$dir/biz", &get_logfile);
diff --git a/tests/scripts/vms/library b/tests/scripts/vms/library
index 9a64951e..8375dfa6 100644
--- a/tests/scripts/vms/library
+++ b/tests/scripts/vms/library
@@ -25,7 +25,7 @@ $mk_string = "text : text.tlb(file1.txt)\n\n" .
"file1.txt :\n" .
"\t\@pipe open/write xxx file1.txt ; write xxx \"text file\" ; close xxx\n";
-my $answer = "library /replace text.tlb file1.txt";
+$answer = "library /replace text.tlb file1.txt";
run_make_test($mk_string,
'', $answer);
@@ -37,10 +37,10 @@ unlink('file1.txt');
#Macro library
$mk_string = "macro : macro.mlb(file1.mar)\n\n" .
"file1.mar :\n" .
-"\t\pipe open/write xxx file1.mar ; " .
+"\tpipe open/write xxx file1.mar ; " .
"write xxx \".macro a b\" ; write xxx \".endm\" ; close xxx\n";
-my $answer = "library /replace macro.mlb file1.mar";
+$answer = "library /replace macro.mlb file1.mar";
run_make_test($mk_string,
'', $answer);
@@ -58,7 +58,7 @@ $mk_string =
"file2.c :\n" .
"\t\@pipe open/write xxx file2.c ; write xxx \"file2(){}\" ; close xxx\n";
-my $answer = "library /replace imagelib.olb file2.exe";
+$answer = "library /replace imagelib.olb file2.exe";
run_make_test($mk_string,
'', $answer);
diff --git a/tests/test_driver.pl b/tests/test_driver.pl
index 6ae523d1..1bb98baf 100644
--- a/tests/test_driver.pl
+++ b/tests/test_driver.pl
@@ -30,6 +30,7 @@
# $Id$
+use Cwd;
# The number of test categories we've run
$categories_run = 0;
@@ -56,64 +57,6 @@ $test_timeout = 10 if $^O eq 'VMS';
$perl_name = $^X;
$perl_name =~ tr,\\,/,;
-# Find the strings that will be generated for various error codes.
-# We want them from the C locale regardless of our current locale.
-
-my $loc = undef;
-if ($has_POSIX) {
- $loc = POSIX::setlocale(POSIX::LC_MESSAGES);
- POSIX::setlocale(POSIX::LC_MESSAGES, 'C');
-}
-
-$ERR_no_such_file = undef;
-$ERR_read_only_file = undef;
-$ERR_unreadable_file = undef;
-$ERR_noexe_file = undef;
-$ERR_exe_dir = undef;
-
-if (open(my $F, '<', 'file.none')) {
- print "Opened non-existent file! Skipping related tests.\n";
-} else {
- $ERR_no_such_file = "$!";
-}
-
-unlink('file.out');
-touch('file.out');
-
-chmod(0444, 'file.out');
-if (open(my $F, '>', 'file.out')) {
- print "Opened read-only file! Skipping related tests.\n";
- close($F);
-} else {
- $ERR_read_only_file = "$!";
-}
-
-$_ = `./file.out`;
-if ($? == 0) {
- print "Executed non-executable file! Skipping related tests.\n";
-} else {
- $ERR_nonexe_file = "$!";
-}
-
-$_ = `./.`;
-if ($? == 0) {
- print "Executed directory! Skipping related tests.\n";
-} else {
- $ERR_exe_dir = "$!";
-}
-
-chmod(0000, 'file.out');
-if (open(my $F, '<', 'file.out')) {
- print "Opened unreadable file! Skipping related tests.\n";
- close($F);
-} else {
- $ERR_unreadable_file = "$!";
-}
-
-unlink('file.out') or die "Failed to delete file.out: $!\n";
-
-$loc and POSIX::setlocale(POSIX::LC_MESSAGES, $loc);
-
# %makeENV is the cleaned-out environment.
%makeENV = ();
@@ -248,85 +191,71 @@ sub toplevel
&print_banner;
- if ($osname eq 'VMS' && $cwdslash eq "")
- {
+ 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 @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 ($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)
- {
+ 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");
+ or &error ("Couldn't wipe out $workpath\n");
+ } else {
+ mkdir ($workpath, 0777) or &error ("Couldn't mkdir $workpath: $!\n");
}
- if (!-d $scriptpath)
- {
+ if (!-d $scriptpath) {
&error ("Failed to find $scriptpath containing perl test scripts.\n");
}
- if (@TESTS)
- {
+ if (@TESTS) {
print "Making work dirs...\n";
- foreach $test (@TESTS)
- {
- if ($test =~ /^([^\/]+)\//)
- {
+ foreach $test (@TESTS) {
+ if ($test =~ /^([^\/]+)\//) {
$dir = $1;
push (@rmdirs, $dir);
-d "$workpath/$dir"
- || mkdir ("$workpath/$dir", 0777)
- || &error ("Couldn't mkdir $workpath/$dir: $!\n");
+ or mkdir ("$workpath/$dir", 0777)
+ or &error ("Couldn't mkdir $workpath/$dir: $!\n");
}
}
- }
- else
- {
+ } else {
print "Finding tests...\n";
opendir (SCRIPTDIR, $scriptpath)
- || &error ("Couldn't opendir $scriptpath: $!\n");
+ or &error ("Couldn't opendir $scriptpath: $!\n");
@dirs = grep (!/^(\..*|CVS|RCS)$/, readdir (SCRIPTDIR) );
closedir (SCRIPTDIR);
- foreach $dir (@dirs)
- {
+ foreach my $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");
+ or &error ("Couldn't mkdir $workpath/$dir: $!\n");
opendir (SCRIPTDIR, "$scriptpath/$dir")
- || &error ("Couldn't opendir $scriptpath/$dir: $!\n");
+ or &error ("Couldn't opendir $scriptpath/$dir: $!\n");
@files = grep (!/^(\..*|CVS|RCS|.*~)$/, readdir (SCRIPTDIR) );
closedir (SCRIPTDIR);
- foreach $test (@files)
- {
+ foreach my $test (@files) {
-d $test and next;
push (@TESTS, "$dir/$test");
}
}
}
- if (@TESTS == 0)
- {
+ if (@TESTS == 0) {
&error ("\nNo tests in $scriptpath, and none were specified.\n");
}
@@ -334,8 +263,7 @@ sub toplevel
run_all_tests();
- foreach $dir (@rmdirs)
- {
+ foreach my $dir (@rmdirs) {
rmdir ("$workpath/$dir");
}
@@ -344,8 +272,7 @@ sub toplevel
$categories_failed = $categories_run - $categories_passed;
$total_tests_failed = $total_tests_run - $total_tests_passed;
- if ($total_tests_failed)
- {
+ if ($total_tests_failed) {
print "\n$total_tests_failed Test";
print "s" unless $total_tests_failed == 1;
print " in $categories_failed Categor";
@@ -353,15 +280,13 @@ sub toplevel
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;
- }
+
+ 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
@@ -415,9 +340,9 @@ sub get_osname
# 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);
+ (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
@@ -426,44 +351,39 @@ sub get_osname
# 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);
+ 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")
- {
+ if (! $short_filenames && -f "ick") {
$osname = "vos";
$vos = 1;
$pathsep = ">";
- }
- else
- {
- # the following is regrettably knarly, but it seems to be the only way
+
+ } else {
+ # 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 ($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);
+ chdir ("..") or &error ("Couldn't chdir to ..: $!\n", 1);
unlink (".ostest>ick");
- rmdir (".ostest") || &error ("Couldn't rmdir .ostest: $!\n", 1);
+ rmdir (".ostest") or &error ("Couldn't rmdir .ostest: $!\n", 1);
}
}
@@ -473,61 +393,50 @@ sub parse_command_line
# use @ARGV if no args were passed in
- if (@argv == 0)
- {
+ 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)
- {
+ while (@argv) {
$option = shift @argv;
- if ($option =~ /^-debug$/i)
- {
- print "\nDEBUG ON\n";
- $debug = 1;
- }
- elsif ($option =~ /^-usage$/i)
- {
+ if ($option =~ /^-usage$/i) {
&print_usage;
exit 0;
}
- elsif ($option =~ /^-(h|help)$/i)
- {
+ if ($option =~ /^-(h|help)$/i) {
&print_help;
exit 0;
}
- elsif ($option =~ /^-profile$/i)
- {
+
+ if ($option =~ /^-debug$/i) {
+ print "\nDEBUG ON\n";
+ $debug = 1;
+
+ } elsif ($option =~ /^-profile$/i) {
$profile = 1;
- }
- elsif ($option =~ /^-verbose$/i)
- {
+
+ } elsif ($option =~ /^-verbose$/i) {
$verbose = 1;
- }
- elsif ($option =~ /^-detail$/i)
- {
+
+ } elsif ($option =~ /^-detail$/i) {
$detail = 1;
$verbose = 1;
- }
- elsif ($option =~ /^-keep$/i)
- {
+
+ } elsif ($option =~ /^-keep$/i) {
$keep = 1;
- }
- elsif (&valid_option($option))
- {
+
+ } elsif (&valid_option($option)) {
# The suite-defined subroutine takes care of the option
- }
- elsif ($option =~ /^-/)
- {
+
+ } elsif ($option =~ /^-/) {
print "Invalid option: $option\n";
&print_usage;
exit 0;
- }
- else # must be the name of a test
- {
+
+ } else { # must be the name of a test
$option =~ s/\.pl$//;
push(@TESTS,$option);
}
@@ -536,14 +445,12 @@ sub parse_command_line
sub max
{
- local($num) = shift @_;
- local($newnum);
+ my $num = shift @_;
+ my $newnum;
- while (@_)
- {
+ while (@_) {
$newnum = shift @_;
- if ($newnum > $num)
- {
+ if ($newnum > $num) {
$num = $newnum;
}
}
@@ -553,173 +460,161 @@ sub max
sub print_centered
{
- local($width, $string) = @_;
- local($pad);
+ my ($width, $string) = @_;
- if (length ($string))
- {
- $pad = " " x ( ($width - length ($string) + 1) / 2);
+ if (length ($string)) {
+ my $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;
- }
+ # $testee is suite-defined
+ my $info = "Running tests for $testee on $osname\n";
+ my $len = &max (length($info), length($testee_version), 73) + 5;
+ my $line = ("-" x $len) . "\n";
&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, $testee_version);
&print_centered ($len, $line);
print "\n";
}
sub run_all_tests
{
- $categories_run = 0;
+ # Make sure we always run the tests from the current directory
+ unshift(@INC, cwd());
- $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";
+ $categories_run = 0;
- -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;
-
- ++$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";
+ $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";
+ # 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";
+
+ -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;
+
+ ++$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
@@ -727,10 +622,9 @@ sub run_all_tests
sub rmfiles
{
- local(@files) = @_;
+ my (@files) = @_;
- if (!$keep)
- {
+ if (!$keep) {
return (unlink @files);
}
@@ -739,8 +633,7 @@ sub rmfiles
sub print_standard_usage
{
- local($plname,@moreusage) = @_;
- local($line);
+ my ($plname, @moreusage) = @_;
print "usage:\t$plname [testname] [-verbose] [-detail] [-keep]\n";
print "\t\t\t[-profile] [-usage] [-help] [-debug]\n";
@@ -751,17 +644,15 @@ sub print_standard_usage
sub print_standard_help
{
- local(@morehelp) = @_;
- local($line);
- local($tline);
- local($t) = " ";
+ my (@morehelp) = @_;
+ my $t = " ";
- $line = "Test Driver For $testee";
+ my $line = "Test Driver For $testee";
print "$line\n";
$line = "=" x length ($line);
print "$line\n";
- &print_usage;
+ print_usage();
print "\ntestname\n"
. "${t}You may, if you wish, run only ONE test if you know the name\n"
@@ -791,11 +682,9 @@ sub print_standard_help
. "${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")
- {
+ foreach $line (@morehelp) {
+ my $tline = $line;
+ if (substr ($tline, 0, 1) eq "\t") {
substr ($tline, 0, 1) = $t;
}
print "$tline\n";
@@ -808,23 +697,17 @@ sub print_standard_help
sub get_caller
{
- local($depth);
- local($package);
- local($filename);
- local($linenum);
-
- $depth = defined ($_[0]) ? $_[0] : 1;
- ($package, $filename, $linenum) = caller ($depth + 1);
+ my $depth = defined ($_[0]) ? $_[0] : 1;
+ my ($pkg, $filename, $linenum) = caller ($depth + 1);
return "$filename: $linenum";
}
sub error
{
- local($message) = $_[0];
- local($caller) = &get_caller (1);
+ my $message = $_[0];
+ my $caller = &get_caller (1);
- if (defined ($_[1]))
- {
+ if (defined ($_[1])) {
$caller = &get_caller ($_[1] + 1) . " -> $caller";
}
@@ -833,165 +716,164 @@ sub error
sub compare_output
{
- local($answer,$logfile) = @_;
- local($slurp, $answer_matched) = ('', 0);
+ my ($answer,$logfile) = @_;
+ my ($slurp, $answer_matched) = ('', 0);
++$tests_run;
if (! defined $answer) {
- print "Ignoring output ........ " if $debug;
- $answer_matched = 1;
+ print "Ignoring output ........ " if $debug;
+ $answer_matched = 1;
} else {
- print "Comparing Output ........ " if $debug;
+ print "Comparing output ........ " if $debug;
- $slurp = &read_file_into_string ($logfile);
+ $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;
+ # 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);
+ 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;
+ $answer_mod =~ tr,\\,/,;
+ $answer_mod =~ s,\r\n,\n,gs;
- $slurp_mod =~ tr,\\,/,;
- $slurp_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);
- 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 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 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 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 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 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;
- # 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);
+ }
- }
- 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);
+ }
- # 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);
- # 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);
- }
- }
+ # 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);
}
- # 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/);
- }
+ # 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)
- {
+ if ($answer_matched && $test_passed) {
print "ok\n" if $debug;
++$tests_passed;
return 1;
@@ -1007,7 +889,7 @@ sub compare_output
# Create the difference file
- local($command) = "diff -c " . &get_basefile . " " . $logfile;
+ my $command = "diff -c " . &get_basefile . " " . $logfile;
&run_command_with_output(&get_difffile,$command);
}
@@ -1016,13 +898,12 @@ sub compare_output
sub read_file_into_string
{
- local($filename) = @_;
- local($oldslash) = $/;
-
+ my ($filename) = @_;
+ my $oldslash = $/;
undef $/;
- open (RFISFILE, $filename) || return "";
- local ($slurp) = ;
+ open (RFISFILE, '<', $filename) or return "";
+ my $slurp = ;
close (RFISFILE);
$/ = $oldslash;
@@ -1035,13 +916,12 @@ my @ERRSTACK = ();
sub attach_default_output
{
- local ($filename) = @_;
- local ($code);
+ my ($filename) = @_;
if ($vos)
{
- $code = system "++attach_default_output_hack $filename";
- $code == -2 || &error ("adoh death\n", 1);
+ my $code = system "++attach_default_output_hack $filename";
+ $code == -2 or &error ("adoh death\n", 1);
return 1;
}
@@ -1062,12 +942,10 @@ sub attach_default_output
sub detach_default_output
{
- local ($code);
-
if ($vos)
{
- $code = system "++detach_default_output_hack";
- $code == -2 || &error ("ddoh death\n", 1);
+ my $code = system "++detach_default_output_hack";
+ $code == -2 or &error ("ddoh death\n", 1);
return 1;
}
@@ -1083,73 +961,73 @@ sub detach_default_output
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 = $?;
+ 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;
}
- return $code;
+ # 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.
@@ -1165,9 +1043,9 @@ sub _run_command
$SIG{ALRM} = $orig;
if ($@) {
- # The eval failed. If it wasn't SIGALRM then die.
- $@ eq "timeout\n" or die "Command failed: $@";
- $code = 14;
+ # The eval failed. If it wasn't SIGALRM then die.
+ $@ eq "timeout\n" or die "Command failed: $@";
+ $code = 14;
}
return $code;
@@ -1213,26 +1091,20 @@ sub run_command_with_output
sub remove_directory_tree
{
- local ($targetdir) = @_;
- local ($nuketop) = 1;
- local ($ch);
+ my ($targetdir) = @_;
+ my ($nuketop) = 1;
- $ch = substr ($targetdir, length ($targetdir) - 1);
- if ($ch eq "/" || $ch eq $pathsep)
- {
+ my $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;
- }
+ -e $targetdir or return 1;
- &remove_directory_tree_inner ("RDT00", $targetdir) || return 0;
- if ($nuketop)
- {
- rmdir $targetdir || return 0;
+ &remove_directory_tree_inner ("RDT00", $targetdir) or return 0;
+ if ($nuketop) {
+ rmdir($targetdir) or return 0;
}
return 1;
@@ -1240,35 +1112,22 @@ sub remove_directory_tree
sub remove_directory_tree_inner
{
- local ($dirhandle, $targetdir) = @_;
- local ($object);
- local ($subdirhandle);
+ my ($dirhandle, $targetdir) = @_;
- opendir ($dirhandle, $targetdir) || return 0;
- $subdirhandle = $dirhandle;
+ opendir ($dirhandle, $targetdir) or return 0;
+ my $subdirhandle = $dirhandle;
$subdirhandle++;
- while ($object = readdir ($dirhandle))
- {
- if ($object =~ /^(\.\.?|CVS|RCS)$/)
- {
- next;
- }
-
+ while (my $object = readdir ($dirhandle)) {
+ $object =~ /^(\.\.?|CVS|RCS)$/ and 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
- {
+ lstat ($object);
+ if (-d _ && &remove_directory_tree_inner ($subdirhandle, $object)) {
+ rmdir $object or return 0;
+ } else {
+ if ($^O ne 'VMS') {
+ unlink $object or return 0;
+ } else {
# VMS can have multiple versions of a file.
1 while unlink $object;
}
@@ -1282,15 +1141,13 @@ sub remove_directory_tree_inner
#
#sub touch
#{
-# local (@filenames) = @_;
-# local ($now) = time;
-# local ($file);
+# my (@filenames) = @_;
+# my $now = time;
#
-# foreach $file (@filenames)
-# {
+# foreach my $file (@filenames) {
# utime ($now, $now, $file)
-# || (open (TOUCHFD, ">> $file") && close (TOUCHFD))
-# || &error ("Couldn't touch $file: $!\n", 1);
+# or (open (TOUCHFD, ">> $file") and close (TOUCHFD))
+# or &error ("Couldn't touch $file: $!\n", 1);
# }
# return 1;
#}
@@ -1305,12 +1162,12 @@ sub remove_directory_tree_inner
sub touch
{
- local ($file);
-
- foreach $file (@_) {
- (open(T, ">> $file") && print(T "\n") && close(T))
- || &error("Couldn't touch $file: $!\n", 1);
+ 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
@@ -1318,25 +1175,26 @@ sub touch
sub utouch
{
- local ($off) = shift;
- local ($file);
+ my $off = shift;
&touch(@_);
- local (@s) = stat($_[0]);
+ foreach my $f (@_) {
+ my @s = stat($f);
+ utime($s[8]+$off, $s[9]+$off, $f);
+ }
- utime($s[8]+$off, $s[9]+$off, @_);
+ return @_;
}
# open a file, write some stuff to it, and close it.
sub create_file
{
- local ($filename, @lines) = @_;
+ my ($filename, @lines) = @_;
- open (CF, "> $filename") || &error ("Couldn't open $filename: $!\n", 1);
- foreach $line (@lines)
- {
+ open (CF, "> $filename") or &error ("Couldn't open $filename: $!\n", 1);
+ foreach $line (@lines) {
print CF $line;
}
close (CF);
@@ -1354,35 +1212,28 @@ sub create_file
sub create_dir_tree
{
- local ($basedir, %dirtree) = @_;
- local ($path);
+ my ($basedir, %dirtree) = @_;
&remove_directory_tree ("$basedir");
- mkdir ($basedir, 0777) || &error ("Couldn't mkdir $basedir: $!\n", 1);
+ mkdir ($basedir, 0777) or &error ("Couldn't mkdir $basedir: $!\n", 1);
- foreach $path (sort keys (%dirtree))
- {
- if ($dirtree {$path} =~ /^DIR$/)
- {
+ foreach my $path (sort keys (%dirtree)) {
+ if ($dirtree {$path} =~ /^DIR$/) {
mkdir ("$basedir/$path", 0777)
- || &error ("Couldn't mkdir $basedir/$path: $!\n", 1);
- }
- elsif ($dirtree {$path} =~ /^FILE:(.*)$/)
- {
+ or &error ("Couldn't mkdir $basedir/$path: $!\n", 1);
+
+ } elsif ($dirtree {$path} =~ /^FILE:(.*)$/) {
&create_file ("$basedir/$path", $1 . "\n");
- }
- elsif ($dirtree {$path} =~ /^LINK:(.*)$/)
- {
+
+ } elsif ($dirtree {$path} =~ /^LINK:(.*)$/) {
symlink ("$basedir/$1", "$basedir/$path")
- || &error ("Couldn't symlink $basedir/$path -> $basedir/$1: $!\n", 1);
- }
- else
- {
+ or &error ("Couldn't symlink $basedir/$path -> $basedir/$1: $!\n", 1);
+
+ } else {
&error ("Bogus dirtree type: \"$dirtree{$path}\"\n", 1);
}
}
- if ($just_setup_tree)
- {
+ if ($just_setup_tree) {
die "Tree is setup...\n";
}
}
@@ -1394,40 +1245,27 @@ sub create_dir_tree
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);
+ my ($basedir, %dirtree) = @_;
+ my $bogus = 0;
- opendir (DIR, $basedir) || &error ("Couldn't open $basedir: $!\n", 1);
- @allfiles = grep (!/^(\.\.?|CVS|RCS)$/, readdir (DIR) );
+ opendir (DIR, $basedir) or &error ("Couldn't open $basedir: $!\n", 1);
+ my @allfiles = grep (!/^(\.\.?|CVS|RCS)$/, readdir (DIR) );
closedir (DIR);
- if ($debug)
- {
+ if ($debug) {
print "dirtree: (%dirtree)\n$basedir: (@allfiles)\n";
}
- foreach $path (sort keys (%dirtree))
+ foreach my $path (sort keys (%dirtree))
{
- if ($debug)
- {
+ if ($debug) {
print "Checking $path ($dirtree{$path}).\n";
}
- $found = 0;
- foreach $i (0 .. $#allfiles)
- {
- if ($allfiles[$i] eq $path)
- {
+ my $found = 0;
+ foreach my $i (0 .. $#allfiles) {
+ if ($allfiles[$i] eq $path) {
splice (@allfiles, $i, 1); # delete it
- if ($debug)
- {
+ if ($debug) {
print " Zapped $path; files now (@allfiles).\n";
}
lstat ("$basedir/$path");
@@ -1436,18 +1274,15 @@ sub compare_dir_tree
}
}
- if (!$found)
- {
+ 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);
+ 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);
@@ -1455,71 +1290,59 @@ sub compare_dir_tree
{
print " Read in $path; new files (@files).\n";
}
- }
- else
- {
+
+ } else {
print "compare_dir_tree: $path is not a dir.\n";
$bogus = 1;
}
- }
- elsif ($dirtree {$path} =~ /^FILE:(.*)$/)
- {
- if (-l _ || !-f _)
- {
+
+ } 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")
- {
+ 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:(.*)$/)
- {
- $target = $1;
- if (!-l _)
- {
+
+ } elsif ($dirtree {$path} =~ /^LINK:(.*)$/) {
+ my $target = $1;
+ if (!-l _) {
print "compare_dir_tree: $path is not a link.\n";
$bogus = 1;
next;
}
- $contents = readlink ("$basedir/$path");
+ my $contents = readlink ("$basedir/$path");
$contents =~ tr/>/\//;
- $fulltarget = "$basedir/$target";
+ my $fulltarget = "$basedir/$target";
$fulltarget =~ tr/>/\//;
- if (!($contents =~ /$fulltarget$/))
- {
- if ($debug)
- {
+ if (!($contents =~ /$fulltarget$/)) {
+ if ($debug) {
$target = $fulltarget;
}
print "compare_dir_tree: $path should be link to $target, "
. "not $contents.\n";
$bogus = 1;
}
- }
- else
- {
+
+ } else {
&error ("Bogus dirtree type: \"$dirtree{$path}\"\n", 1);
}
}
- if ($debug)
- {
+ if ($debug) {
print "leftovers: (@allfiles).\n";
}
- foreach $file (@allfiles)
- {
+ foreach my $file (@allfiles) {
print "compare_dir_tree: $file should not exist.\n";
$bogus = 1;
}
@@ -1534,8 +1357,7 @@ sub compare_dir_tree
sub num_suffix
{
- local($num) = @_;
-
+ my ($num) = @_;
if (--$num > 0) {
return "$extext$num";
}
@@ -1553,7 +1375,7 @@ sub num_suffix
sub get_logfile
{
- local($no_increment) = @_;
+ my ($no_increment) = @_;
$num_of_logfiles += !$no_increment;
@@ -1594,7 +1416,7 @@ sub get_runfile
sub get_tmpfile
{
- local($no_increment) = @_;
+ my ($no_increment) = @_;
$num_of_tmpfiles += !$no_increment;