From: Paul Smith Date: Sun, 15 Sep 2019 19:30:34 +0000 (-0400) Subject: Refresh the test suite framework implementation. X-Git-Tag: 4.2.91~2 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=414af96a5010353643d2e8691d86dc3416ffbd75;p=thirdparty%2Fmake.git Refresh the test suite framework implementation. Go through both run_make_tests.pl and test_driver.pl and slightly modernize the Perl and clean up indentation etc. Fix a number of warnings in the test scripts detected by running with -w. * tests/test_driver.pl: Move make error string detection out of the base test driver. (run_all_tests): Ensure that we always look for tests in the cwd. * tests/run_make_tests.pl: Use File::Spec for path manipulations. Correctly use setlocale() when detecting error strings. Get configuration from the config-flags.pm file not config.status. * tests/scripts/features/archives: Use new $cwddir variable. * tests/scripts/features/reinvoke: Add missing semicolon. * tests/scripts/features/vpath2: Avoid non-existent variable. * tests/scripts/functions/foreach: Escape variables. * tests/scripts/misc/bs-nl: Remove non-existing \v escape sequence. * tests/scripts/misc/general4: Use handy create_file(). * tests/scripts/options/dash-C: Use Cwd/$cwddir. * tests/scripts/options/dash-I: Use subst_make_string() and #PWD#. * tests/scripts/options/symlinks: Use File::Spec. * tests/scripts/targets/DEFAULT: Use create_file and run_make_test. * tests/scripts/variables/CURDIR: Use run_make_test. * tests/scripts/variables/automatic: Remove extraneous "\". * tests/scripts/vms/library: Remove extra "my" and extraneous "\". --- 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"; +%CONFIG_FLAGS = (); -require "test_driver.pl"; +# Find the strings that will be generated for various error codes. +# We want them from the C locale regardless of our current locale. -%CONFIG_FLAGS = (); +$ERR_no_such_file = undef; +$ERR_read_only_file = undef; +$ERR_unreadable_file = undef; +$ERR_noexe_file = undef; +$ERR_exe_dir = undef; -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: $!"; -} +{ + use locale; -# Some target systems might not have the POSIX module... -$has_POSIX = eval { require "POSIX.pm" }; + 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"; } -sub set_defaults +# 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 { - # $profile = 1; - $testee = "GNU make"; - $make_path = "make"; - $tmpfilesuffix = "mk"; - $pwd = &get_this_pwd; + 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); - - # 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; - - # 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; - } + local($string); + local($index); + + # Now that we have located make_path, locate the srcdir and blddir + my ($mpv, $mpd, $mpf) = find_prog($make_path); + + # 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"; + } + } + + # 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; + + # 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); + + # 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 ''; + } - # prepend pwd if this is a relative path (ie, does not - # start with a slash, but contains one). Thanks for the - # clue, Roland. + $string = `$make_path -v`; + $string =~ /^(GNU Make [^,\n]*)/ or die "$make_path is not GNU make. Version:\n$string"; + $testee_version = "$1\n"; - if (index ($make_path, ":") != 1 && index ($make_path, "/") > 0) - { - $mkpath = "$pwd$pathsep$make_path"; - } - else - { - $mkpath = $make_path; - } + create_file('null.mk', ''); - # 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; - } + 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; + } - # 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; - } + # prepend pwd if this is a relative path (ie, does not + # start with a slash, but contains one). Thanks for the + # clue, Roland. - # Get Purify log info--if any. + if ($mpd && !file_name_is_absolute($make_path) && $cwdvol == $mpv) { + $mkpath = catpath($cwdvol, catdir($cwd, $mpd), $mpf); + } else { + $mkpath = $make_path; + } - if (exists $ENV{PURIFYOPTIONS} - && $ENV{PURIFYOPTIONS} =~ /.*-logfile=([^ ]+)/) { - $pure_log = $1 || ''; - $pure_log =~ s/%v/$make_name/; - $purify_errors = 0; - } + # 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; + } - $string = `$make_path -j 2 -f null.mk $redir`; - if ($string =~ /not supported/) { - $parallel_jobs = 0; - } - else { - $parallel_jobs = 1; - } + # Get Purify log info--if any. - unlink('null.mk'); + if (exists $ENV{PURIFYOPTIONS} + && $ENV{PURIFYOPTIONS} =~ /.*-logfile=([^ ]+)/) { + $pure_log = $1 || ''; + $pure_log =~ s/%v/$make_name/; + $purify_errors = 0; + } - create_file('features.mk', 'all:;$(info $(.FEATURES))'); - %FEATURES = map { $_ => 1 } split /\s+/, `$make_path -sf features.mk`; - unlink('features.mk'); + $string = `$make_path -j 2 -f null.mk $redir`; + if ($string =~ /not supported/) { + $parallel_jobs = 0; + } + else { + $parallel_jobs = 1; + } - # Set up for valgrind, if requested. + unlink('null.mk'); - $make_command = $make_path; + create_file('features.mk', 'all:;$(info $(.FEATURES))'); + %FEATURES = map { $_ => 1 } split /\s+/, `$make_path -sf features.mk`; + unlink('features.mk'); - 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"; - } + # Set up for valgrind, if requested. - 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"; - } + $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 { + # This test is N/A + return -1; +} - # 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'); +# Set up a symlink sym -> dep +# We'll make both dep and targ older than sym +&utouch(-10, 'dep'); +&utouch(-5, 'targ'); - # 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"); +$dirnm = (splitdir($cwddir))[-1]; +symlink(catfile(updir(), $dirnm, 'dep'), '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"); +# 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 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."); +# 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"); - # Add in a new link between sym and dep. Be sure it's newer than targ. - sleep(1); - rename('dep', 'dep1'); - symlink('dep1', 'dep'); +# 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."); - # 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"); +# Add in a new link between sym and dep. Be sure it's newer than targ. +sleep(1); +rename('dep', 'dep1'); +symlink('dep1', 'dep'); - rmfiles('targ', 'dep', 'sym', 'dep1'); +# 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"); - # 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. +rmfiles('targ', 'dep', 'sym', 'dep1'); - symlink("../$dirname/dep", 'sym'); - run_make_test('targ: sym ; @echo make $@ from $<', '', - "#MAKE#: *** No rule to make target 'sym', needed by 'targ'. Stop.", 512); +# 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. - run_make_test('targ: sym ; @echo make $@ from $<', '-L', - 'make targ from sym'); +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; -} +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; - -open(MAKEFILE,"> $makefile"); - -# The Contents of the MAKEFILE ... - -print MAKEFILE "foo:\n"; -print MAKEFILE "\t\@echo Executing rule FOO\n\n"; -print MAKEFILE ".DEFAULT:\n"; -print MAKEFILE "\t\@\$(MAKE) -f $makefile2 \$\@ \n"; - -# 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_file('defsub.mk', q! +bar: ; @echo Executing rule BAR +!); -# 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"; +run_make_test(q! +foo:; @echo Executing rule FOO -# COMPARE RESULTS +.DEFAULT: ; @$(MAKE) -f defsub.mk $@ +!, + 'bar',"#MAKE#[1]: Entering directory '#PWD#'\n" + . "Executing rule BAR\n" + . "#MAKE#[1]: Leaving directory '#PWD#'\n"); -&compare_output($answer,&get_logfile(1)); +unlink('defsub.mk'); -# 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; - - $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"; + # Make sure we always run the tests from the current directory + unshift(@INC, cwd()); + + $categories_run = 0; + + $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"; + -f $perl_testname or die "Invalid test: $testname\n\n"; - setup_for_test(); + setup_for_test(); - $output = "........................................................ "; + $output = "........................................................ "; - substr($output,0,length($testname)) = "$testname "; + substr($output,0,length($testname)) = "$testname "; - print $output; + print $output; - $tests_run = 0; - $tests_passed = 0; + $tests_run = 0; + $tests_passed = 0; - # Run the test! - $code = do $perl_testname; + # Run the test! + $code = do $perl_testname; - ++$categories_run; - $total_tests_run += $tests_run; - $total_tests_passed += $tests_passed; + ++$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)"; - } + # 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) { + # 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 ($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 == 0) { + # Nothing was done!! + $status = "FAILED (no tests found!)"; - elsif ($tests_run > $tests_passed) { - # Lose! - $status = "FAILED ($tests_passed/$tests_run passed)"; - } + } 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)); - } - } + } else { + # Win! + ++$categories_passed; + $status = "ok ($tests_passed passed)"; - # 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. + # 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 ($verbose) { - if ($detail) { - print "\nWHAT IS BEING TESTED\n"; - print "--------------------"; - } - print "\n\n$description\n\n"; - } + # 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 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 ($verbose) { + if ($detail) { + print "\nWHAT IS BEING TESTED\n"; + print "--------------------"; + } + print "\n\n$description\n\n"; + } - if ($detail) { - print "\nHOW IT IS TESTED\n"; - print "----------------"; - print "\n\n$details\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. - print "$status\n"; + 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; + + $slurp_mod =~ tr,\\,/,; + $slurp_mod =~ s,\r\n,\n,gs; - $answer_mod =~ tr,\\,/,; - $answer_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); + } - $slurp_mod =~ tr,\\,/,; - $slurp_mod =~ s,\r\n,\n,gs; + # 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); - 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); - } - } + } + # 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); } - # 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; - } + 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}; + # Get the vms status. + my $vms_code = ${^CHILD_ERROR_NATIVE}; - # Remove the print status bit - $vms_code &= ~0x10000000; + # Remove the print status bit + $vms_code &= ~0x10000000; - # Posix code translation. - if (($vms_code & 0xFFFFF000) == 0x35a000) { - $code = (($vms_code & 0xFFF) >> 3) * 256; - } + # 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 = $?; + } 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 = $?; + } 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; + 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); - - opendir (DIR, $basedir) || &error ("Couldn't open $basedir: $!\n", 1); - @allfiles = grep (!/^(\.\.?|CVS|RCS)$/, readdir (DIR) ); + 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) - { + 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;