# You should have received a copy of the GNU General Public License along with
# this program. If not, see <http://www.gnu.org/licenses/>.
+# 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
$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 = '';
$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 @_; };
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;
}
s/#MAKEPATH#/$mkpath/g;
s/#MAKE#/$make_name/g;
s/#PERL#/$perl_name/g;
- s/#PWD#/$pwd/g;
+ s/#PWD#/$cwdpath/g;
return $_;
}
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)) {
$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.
# 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);
"\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;
- $_ = <MF>;
- 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;
+ $_ = <MF>;
+ 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
# $Id$
+use Cwd;
# The number of test categories we've run
$categories_run = 0;
$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 = ();
&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");
}
run_all_tests();
- foreach $dir (@rmdirs)
- {
+ foreach my $dir (@rmdirs) {
rmdir ("$workpath/$dir");
}
$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";
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
# 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
# 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);
}
}
# 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);
}
sub max
{
- local($num) = shift @_;
- local($newnum);
+ my $num = shift @_;
+ my $newnum;
- while (@_)
- {
+ while (@_) {
$newnum = shift @_;
- if ($newnum > $num)
- {
+ if ($newnum > $num) {
$num = $newnum;
}
}
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
sub rmfiles
{
- local(@files) = @_;
+ my (@files) = @_;
- if (!$keep)
- {
+ if (!$keep) {
return (unlink @files);
}
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";
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"
. "${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";
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";
}
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;
# 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);
}
sub read_file_into_string
{
- local($filename) = @_;
- local($oldslash) = $/;
-
+ my ($filename) = @_;
+ my $oldslash = $/;
undef $/;
- open (RFISFILE, $filename) || return "";
- local ($slurp) = <RFISFILE>;
+ open (RFISFILE, '<', $filename) or return "";
+ my $slurp = <RFISFILE>;
close (RFISFILE);
$/ = $oldslash;
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;
}
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;
}
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.
$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;
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;
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;
}
#
#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;
#}
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
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);
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";
}
}
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");
}
}
- 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);
{
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;
}
sub num_suffix
{
- local($num) = @_;
-
+ my ($num) = @_;
if (--$num > 0) {
return "$extext$num";
}
sub get_logfile
{
- local($no_increment) = @_;
+ my ($no_increment) = @_;
$num_of_logfiles += !$no_increment;
sub get_tmpfile
{
- local($no_increment) = @_;
+ my ($no_increment) = @_;
$num_of_tmpfiles += !$no_increment;
projects / thirdparty / make.git / commitdiff
