diff options
Diffstat (limited to 'tests/test_driver.pl')
-rw-r--r-- | tests/test_driver.pl | 1237 |
1 files changed, 1237 insertions, 0 deletions
diff --git a/tests/test_driver.pl b/tests/test_driver.pl new file mode 100644 index 0000000..dec869d --- /dev/null +++ b/tests/test_driver.pl @@ -0,0 +1,1237 @@ +#!/usr/bin/perl +# -*-perl-*- +# +# Modification history: +# Written 91-12-02 through 92-01-01 by Stephen McGee. +# Modified 92-02-11 through 92-02-22 by Chris Arthur to further generalize. +# +# Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, +# 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software +# Foundation, Inc. +# This file is part of GNU Make. +# +# GNU Make is free software; you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation; either version 3 of the License, or (at your option) any later +# version. +# +# GNU Make is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see <http://www.gnu.org/licenses/>. + + +# Test driver routines used by a number of test suites, including +# those for SCS, make, roll_dir, and scan_deps (?). +# +# this routine controls the whole mess; each test suite sets up a few +# variables and then calls &toplevel, which does all the real work. + +# $Id: test_driver.pl,v 1.30 2010/07/28 05:39:50 psmith Exp $ + + +# The number of test categories we've run +$categories_run = 0; +# The number of test categroies that have passed +$categories_passed = 0; +# The total number of individual tests that have been run +$total_tests_run = 0; +# The total number of individual tests that have passed +$total_tests_passed = 0; +# The number of tests in this category that have been run +$tests_run = 0; +# The number of tests in this category that have passed +$tests_passed = 0; + + +# Yeesh. This whole test environment is such a hack! +$test_passed = 1; + + +# Timeout in seconds. If the test takes longer than this we'll fail it. +$test_timeout = 5; + +# Path to Perl +$perl_name = $^X; + +# %makeENV is the cleaned-out environment. +%makeENV = (); + +# %extraENV are any extra environment variables the tests might want to set. +# These are RESET AFTER EVERY TEST! +%extraENV = (); + +# %origENV is the caller's original environment +%origENV = %ENV; + +sub resetENV +{ + # We used to say "%ENV = ();" but this doesn't work in Perl 5.000 + # through Perl 5.004. It was fixed in Perl 5.004_01, but we don't + # want to require that here, so just delete each one individually. + foreach $v (keys %ENV) { + delete $ENV{$v}; + } + + %ENV = %makeENV; + foreach $v (keys %extraENV) { + $ENV{$v} = $extraENV{$v}; + delete $extraENV{$v}; + } +} + +sub toplevel +{ + # Pull in benign variables from the user's environment + + foreach (# UNIX-specific things + 'TZ', 'TMPDIR', 'HOME', 'USER', 'LOGNAME', 'PATH', + # Purify things + 'PURIFYOPTIONS', + # Windows NT-specific stuff + 'Path', 'SystemRoot', + # DJGPP-specific stuff + 'DJDIR', 'DJGPP', 'SHELL', 'COMSPEC', 'HOSTNAME', 'LFN', + 'FNCASE', '387', 'EMU387', 'GROUP' + ) { + $makeENV{$_} = $ENV{$_} if $ENV{$_}; + } + + # Make sure our compares are not foiled by locale differences + + $makeENV{LC_ALL} = 'C'; + + # Replace the environment with the new one + # + %origENV = %ENV; + + resetENV(); + + $| = 1; # unbuffered output + + $debug = 0; # debug flag + $profile = 0; # profiling flag + $verbose = 0; # verbose mode flag + $detail = 0; # detailed verbosity + $keep = 0; # keep temp files around + $workdir = "work"; # The directory where the test will start running + $scriptdir = "scripts"; # The directory where we find the test scripts + $tmpfilesuffix = "t"; # the suffix used on tmpfiles + $default_output_stack_level = 0; # used by attach_default_output, etc. + $default_input_stack_level = 0; # used by attach_default_input, etc. + $cwd = "."; # don't we wish we knew + $cwdslash = ""; # $cwd . $pathsep, but "" rather than "./" + + &get_osname; # sets $osname, $vos, $pathsep, and $short_filenames + + &set_defaults; # suite-defined + + &parse_command_line (@ARGV); + + print "OS name = `$osname'\n" if $debug; + + $workpath = "$cwdslash$workdir"; + $scriptpath = "$cwdslash$scriptdir"; + + &set_more_defaults; # suite-defined + + &print_banner; + + if (-d $workpath) + { + print "Clearing $workpath...\n"; + &remove_directory_tree("$workpath/") + || &error ("Couldn't wipe out $workpath\n"); + } + else + { + mkdir ($workpath, 0777) || &error ("Couldn't mkdir $workpath: $!\n"); + } + + if (!-d $scriptpath) + { + &error ("Failed to find $scriptpath containing perl test scripts.\n"); + } + + if (@TESTS) + { + print "Making work dirs...\n"; + foreach $test (@TESTS) + { + if ($test =~ /^([^\/]+)\//) + { + $dir = $1; + push (@rmdirs, $dir); + -d "$workpath/$dir" + || mkdir ("$workpath/$dir", 0777) + || &error ("Couldn't mkdir $workpath/$dir: $!\n"); + } + } + } + else + { + print "Finding tests...\n"; + opendir (SCRIPTDIR, $scriptpath) + || &error ("Couldn't opendir $scriptpath: $!\n"); + @dirs = grep (!/^(\..*|CVS|RCS)$/, readdir (SCRIPTDIR) ); + closedir (SCRIPTDIR); + foreach $dir (@dirs) + { + next if ($dir =~ /^(\..*|CVS|RCS)$/ || ! -d "$scriptpath/$dir"); + push (@rmdirs, $dir); + mkdir ("$workpath/$dir", 0777) + || &error ("Couldn't mkdir $workpath/$dir: $!\n"); + opendir (SCRIPTDIR, "$scriptpath/$dir") + || &error ("Couldn't opendir $scriptpath/$dir: $!\n"); + @files = grep (!/^(\..*|CVS|RCS|.*~)$/, readdir (SCRIPTDIR) ); + closedir (SCRIPTDIR); + foreach $test (@files) + { + -d $test and next; + push (@TESTS, "$dir/$test"); + } + } + } + + if (@TESTS == 0) + { + &error ("\nNo tests in $scriptpath, and none were specified.\n"); + } + + print "\n"; + + &run_each_test; + + foreach $dir (@rmdirs) + { + rmdir ("$workpath/$dir"); + } + + $| = 1; + + $categories_failed = $categories_run - $categories_passed; + $total_tests_failed = $total_tests_run - $total_tests_passed; + + if ($total_tests_failed) + { + print "\n$total_tests_failed Test"; + print "s" unless $total_tests_failed == 1; + print " in $categories_failed Categor"; + print ($categories_failed == 1 ? "y" : "ies"); + print " Failed (See .$diffext files in $workdir dir for details) :-(\n\n"; + return 0; + } + else + { + print "\n$total_tests_passed Test"; + print "s" unless $total_tests_passed == 1; + print " in $categories_passed Categor"; + print ($categories_passed == 1 ? "y" : "ies"); + print " Complete ... No Failures :-)\n\n"; + return 1; + } +} + +sub get_osname +{ + # Set up an initial value. In perl5 we can do it the easy way. + $osname = defined($^O) ? $^O : ''; + + # Find a path to Perl + + # See if the filesystem supports long file names with multiple + # dots. DOS doesn't. + $short_filenames = 0; + (open (TOUCHFD, "> fancy.file.name") && close (TOUCHFD)) + || ($short_filenames = 1); + unlink ("fancy.file.name") || ($short_filenames = 1); + + if (! $short_filenames) { + # Thanks go to meyering@cs.utexas.edu (Jim Meyering) for suggesting a + # better way of doing this. (We used to test for existence of a /mnt + # dir, but that apparently fails on an SGI Indigo (whatever that is).) + # Because perl on VOS translates /'s to >'s, we need to test for + # VOSness rather than testing for Unixness (ie, try > instead of /). + + mkdir (".ostest", 0777) || &error ("Couldn't create .ostest: $!\n", 1); + open (TOUCHFD, "> .ostest>ick") && close (TOUCHFD); + chdir (".ostest") || &error ("Couldn't chdir to .ostest: $!\n", 1); + } + + if (! $short_filenames && -f "ick") + { + $osname = "vos"; + $vos = 1; + $pathsep = ">"; + } + else + { + # the following is regrettably knarly, but it seems to be the only way + # to not get ugly error messages if uname can't be found. + # Hmmm, BSD/OS 2.0's uname -a is excessively verbose. Let's try it + # with switches first. + eval "chop (\$osname = `sh -c 'uname -nmsr 2>&1'`)"; + if ($osname =~ /not found/i) + { + $osname = "(something posixy with no uname)"; + } + elsif ($@ ne "" || $?) + { + eval "chop (\$osname = `sh -c 'uname -a 2>&1'`)"; + if ($@ ne "" || $?) + { + $osname = "(something posixy)"; + } + } + $vos = 0; + $pathsep = "/"; + } + + if (! $short_filenames) { + chdir ("..") || &error ("Couldn't chdir to ..: $!\n", 1); + unlink (".ostest>ick"); + rmdir (".ostest") || &error ("Couldn't rmdir .ostest: $!\n", 1); + } +} + +sub parse_command_line +{ + @argv = @_; + + # use @ARGV if no args were passed in + + if (@argv == 0) + { + @argv = @ARGV; + } + + # look at each option; if we don't recognize it, maybe the suite-specific + # command line parsing code will... + + while (@argv) + { + $option = shift @argv; + if ($option =~ /^-debug$/i) + { + print "\nDEBUG ON\n"; + $debug = 1; + } + elsif ($option =~ /^-usage$/i) + { + &print_usage; + exit 0; + } + elsif ($option =~ /^-(h|help)$/i) + { + &print_help; + exit 0; + } + elsif ($option =~ /^-profile$/i) + { + $profile = 1; + } + elsif ($option =~ /^-verbose$/i) + { + $verbose = 1; + } + elsif ($option =~ /^-detail$/i) + { + $detail = 1; + $verbose = 1; + } + elsif ($option =~ /^-keep$/i) + { + $keep = 1; + } + elsif (&valid_option($option)) + { + # The suite-defined subroutine takes care of the option + } + elsif ($option =~ /^-/) + { + print "Invalid option: $option\n"; + &print_usage; + exit 0; + } + else # must be the name of a test + { + $option =~ s/\.pl$//; + push(@TESTS,$option); + } + } +} + +sub max +{ + local($num) = shift @_; + local($newnum); + + while (@_) + { + $newnum = shift @_; + if ($newnum > $num) + { + $num = $newnum; + } + } + + return $num; +} + +sub print_centered +{ + local($width, $string) = @_; + local($pad); + + if (length ($string)) + { + $pad = " " x ( ($width - length ($string) + 1) / 2); + print "$pad$string"; + } +} + +sub print_banner +{ + local($info); + local($line); + local($len); + + $info = "Running tests for $testee on $osname\n"; # $testee is suite-defined + $len = &max (length ($line), length ($testee_version), + length ($banner_info), 73) + 5; + $line = ("-" x $len) . "\n"; + if ($len < 78) + { + $len = 78; + } + + &print_centered ($len, $line); + &print_centered ($len, $info); + &print_centered ($len, $testee_version); # suite-defined + &print_centered ($len, $banner_info); # suite-defined + &print_centered ($len, $line); + print "\n"; +} + +sub run_each_test +{ + $categories_run = 0; + + foreach $testname (sort @TESTS) + { + ++$categories_run; + $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 = '.'; + } + $log_filename = "$testpath.$logext"; + $diff_filename = "$testpath.$diffext"; + $base_filename = "$testpath.$baseext"; + $run_filename = "$testpath.$runext"; + $tmp_filename = "$testpath.$tmpfilesuffix"; + + &setup_for_test; # suite-defined + + $output = "........................................................ "; + + substr($output,0,length($testname)) = "$testname "; + + print $output; + + # Run the actual test! + $tests_run = 0; + $tests_passed = 0; + + $code = do $perl_testname; + + $total_tests_run += $tests_run; + $total_tests_passed += $tests_passed; + + # How did it go? + if (!defined($code)) + { + $suite_passed = 0; + if (length ($@)) { + warn "\n*** Test died ($testname): $@\n"; + } else { + warn "\n*** Couldn't run $perl_testname\n"; + } + } + elsif ($code == -1) { + $suite_passed = 0; + } + elsif ($code != 1 && $code != -1) { + $suite_passed = 0; + warn "\n*** Test returned $code\n"; + } + + if ($suite_passed) { + ++$categories_passed; + $status = "ok ($tests_passed passed)"; + 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) ); + } + } + elsif (!defined $code || $code > 0) { + $status = "FAILED ($tests_passed/$tests_run passed)"; + } + elsif ($code < 0) { + $status = "N/A"; + --$categories_run; + } + + # If the verbose option has been specified, then a short description + # of each test is printed before displaying the results of each test + # describing WHAT is being tested. + + if ($verbose) + { + if ($detail) + { + print "\nWHAT IS BEING TESTED\n"; + print "--------------------"; + } + print "\n\n$description\n\n"; + } + + # If the detail option has been specified, then the details of HOW + # the test is testing what it says it is testing in the verbose output + # will be displayed here before the results of the test are displayed. + + if ($detail) + { + print "\nHOW IT IS TESTED\n"; + print "----------------"; + print "\n\n$details\n\n"; + } + + print "$status\n"; + } +} + +# If the keep flag is not set, this subroutine deletes all filenames that +# are sent to it. + +sub rmfiles +{ + local(@files) = @_; + + if (!$keep) + { + return (unlink @files); + } + + return 1; +} + +sub print_standard_usage +{ + local($plname,@moreusage) = @_; + local($line); + + print "usage:\t$plname [testname] [-verbose] [-detail] [-keep]\n"; + print "\t\t\t[-profile] [-usage] [-help] [-debug]\n"; + foreach (@moreusage) { + print "\t\t\t$_\n"; + } +} + +sub print_standard_help +{ + local(@morehelp) = @_; + local($line); + local($tline); + local($t) = " "; + + $line = "Test Driver For $testee"; + print "$line\n"; + $line = "=" x length ($line); + print "$line\n"; + + &print_usage; + + print "\ntestname\n" + . "${t}You may, if you wish, run only ONE test if you know the name\n" + . "${t}of that test and specify this name anywhere on the command\n" + . "${t}line. Otherwise ALL existing tests in the scripts directory\n" + . "${t}will be run.\n" + . "-verbose\n" + . "${t}If this option is given, a description of every test is\n" + . "${t}displayed before the test is run. (Not all tests may have\n" + . "${t}descriptions at this time)\n" + . "-detail\n" + . "${t}If this option is given, a detailed description of every\n" + . "${t}test is displayed before the test is run. (Not all tests\n" + . "${t}have descriptions at this time)\n" + . "-profile\n" + . "${t}If this option is given, then the profile file\n" + . "${t}is added to other profiles every time $testee is run.\n" + . "${t}This option only works on VOS at this time.\n" + . "-keep\n" + . "${t}You may give this option if you DO NOT want ANY\n" + . "${t}of the files generated by the tests to be deleted. \n" + . "${t}Without this option, all files generated by the test will\n" + . "${t}be deleted IF THE TEST PASSES.\n" + . "-debug\n" + . "${t}Use this option if you would like to see all of the system\n" + . "${t}calls issued and their return status while running the tests\n" + . "${t}This can be helpful if you're having a problem adding a test\n" + . "${t}to the suite, or if the test fails!\n"; + + foreach $line (@morehelp) + { + $tline = $line; + if (substr ($tline, 0, 1) eq "\t") + { + substr ($tline, 0, 1) = $t; + } + print "$tline\n"; + } +} + +####################################################################### +########### Generic Test Driver Subroutines ########### +####################################################################### + +sub get_caller +{ + local($depth); + local($package); + local($filename); + local($linenum); + + $depth = defined ($_[0]) ? $_[0] : 1; + ($package, $filename, $linenum) = caller ($depth + 1); + return "$filename: $linenum"; +} + +sub error +{ + local($message) = $_[0]; + local($caller) = &get_caller (1); + + if (defined ($_[1])) + { + $caller = &get_caller ($_[1] + 1) . " -> $caller"; + } + + die "$caller: $message"; +} + +sub compare_output +{ + local($answer,$logfile) = @_; + local($slurp, $answer_matched) = ('', 0); + + print "Comparing Output ........ " if $debug; + + $slurp = &read_file_into_string ($logfile); + + # For make, get rid of any time skew error before comparing--too bad this + # has to go into the "generic" driver code :-/ + $slurp =~ s/^.*modification time .*in the future.*\n//gm; + $slurp =~ s/^.*Clock skew detected.*\n//gm; + + ++$tests_run; + + if ($slurp eq $answer) { + $answer_matched = 1; + } else { + # See if it is a slash or CRLF problem + local ($answer_mod, $slurp_mod) = ($answer, $slurp); + + $answer_mod =~ tr,\\,/,; + $answer_mod =~ s,\r\n,\n,gs; + + $slurp_mod =~ tr,\\,/,; + $slurp_mod =~ s,\r\n,\n,gs; + + $answer_matched = ($slurp_mod eq $answer_mod); + + # If it still doesn't match, see if the answer might be a regex. + if (!$answer_matched && $answer =~ m,^/(.+)/$,) { + $answer_matched = ($slurp =~ /$1/); + if (!$answer_matched && $answer_mod =~ m,^/(.+)/$,) { + $answer_matched = ($slurp_mod =~ /$1/); + } + } + } + + if ($answer_matched && $test_passed) + { + print "ok\n" if $debug; + ++$tests_passed; + return 1; + } + + if (! $answer_matched) { + print "DIFFERENT OUTPUT\n" if $debug; + + &create_file (&get_basefile, $answer); + &create_file (&get_runfile, $command_string); + + print "\nCreating Difference File ...\n" if $debug; + + # Create the difference file + + local($command) = "diff -c " . &get_basefile . " " . $logfile; + &run_command_with_output(&get_difffile,$command); + } else { + &rmfiles (); + } + + $suite_passed = 0; + return 0; +} + +sub read_file_into_string +{ + local($filename) = @_; + local($oldslash) = $/; + + undef $/; + + open (RFISFILE, $filename) || return ""; + local ($slurp) = <RFISFILE>; + close (RFISFILE); + + $/ = $oldslash; + + return $slurp; +} + +sub attach_default_output +{ + local ($filename) = @_; + local ($code); + + if ($vos) + { + $code = system "++attach_default_output_hack $filename"; + $code == -2 || &error ("adoh death\n", 1); + return 1; + } + + open ("SAVEDOS" . $default_output_stack_level . "out", ">&STDOUT") + || &error ("ado: $! duping STDOUT\n", 1); + open ("SAVEDOS" . $default_output_stack_level . "err", ">&STDERR") + || &error ("ado: $! duping STDERR\n", 1); + + open (STDOUT, "> " . $filename) + || &error ("ado: $filename: $!\n", 1); + open (STDERR, ">&STDOUT") + || &error ("ado: $filename: $!\n", 1); + + $default_output_stack_level++; +} + +# close the current stdout/stderr, and restore the previous ones from +# the "stack." + +sub detach_default_output +{ + local ($code); + + if ($vos) + { + $code = system "++detach_default_output_hack"; + $code == -2 || &error ("ddoh death\n", 1); + return 1; + } + + if (--$default_output_stack_level < 0) + { + &error ("default output stack has flown under!\n", 1); + } + + close (STDOUT); + close (STDERR); + + open (STDOUT, ">&SAVEDOS" . $default_output_stack_level . "out") + || &error ("ddo: $! duping STDOUT\n", 1); + open (STDERR, ">&SAVEDOS" . $default_output_stack_level . "err") + || &error ("ddo: $! duping STDERR\n", 1); + + close ("SAVEDOS" . $default_output_stack_level . "out") + || &error ("ddo: $! closing SCSDOSout\n", 1); + close ("SAVEDOS" . $default_output_stack_level . "err") + || &error ("ddo: $! closing SAVEDOSerr\n", 1); +} + +# This runs a command without any debugging info. +sub _run_command +{ + my $code; + + # We reset this before every invocation. On Windows I think there is only + # one environment, not one per process, so I think that variables set in + # test scripts might leak into subsequent tests if this isn't reset--??? + resetENV(); + + eval { + local $SIG{ALRM} = sub { die "timeout\n"; }; + alarm $test_timeout; + $code = system(@_); + alarm 0; + }; + if ($@) { + # The eval failed. If it wasn't SIGALRM then die. + $@ eq "timeout\n" or die; + + # Timed out. Resend the alarm to our process group to kill the children. + $SIG{ALRM} = 'IGNORE'; + kill -14, $$; + $code = 14; + } + + return $code; +} + +# run one command (passed as a list of arg 0 - n), returning 0 on success +# and nonzero on failure. + +sub run_command +{ + print "\nrun_command: @_\n" if $debug; + my $code = _run_command(@_); + print "run_command returned $code.\n" if $debug; + + return $code; +} + +# run one command (passed as a list of arg 0 - n, with arg 0 being the +# second arg to this routine), returning 0 on success and non-zero on failure. +# The first arg to this routine is a filename to connect to the stdout +# & stderr of the child process. + +sub run_command_with_output +{ + my $filename = shift; + + print "\nrun_command_with_output($filename,$runname): @_\n" if $debug; + &attach_default_output ($filename); + my $code = _run_command(@_); + &detach_default_output; + print "run_command_with_output returned $code.\n" if $debug; + + return $code; +} + +# performs the equivalent of an "rm -rf" on the first argument. Like +# rm, if the path ends in /, leaves the (now empty) directory; otherwise +# deletes it, too. + +sub remove_directory_tree +{ + local ($targetdir) = @_; + local ($nuketop) = 1; + local ($ch); + + $ch = substr ($targetdir, length ($targetdir) - 1); + if ($ch eq "/" || $ch eq $pathsep) + { + $targetdir = substr ($targetdir, 0, length ($targetdir) - 1); + $nuketop = 0; + } + + if (! -e $targetdir) + { + return 1; + } + + &remove_directory_tree_inner ("RDT00", $targetdir) || return 0; + if ($nuketop) + { + rmdir $targetdir || return 0; + } + + return 1; +} + +sub remove_directory_tree_inner +{ + local ($dirhandle, $targetdir) = @_; + local ($object); + local ($subdirhandle); + + opendir ($dirhandle, $targetdir) || return 0; + $subdirhandle = $dirhandle; + $subdirhandle++; + while ($object = readdir ($dirhandle)) + { + if ($object =~ /^(\.\.?|CVS|RCS)$/) + { + next; + } + + $object = "$targetdir$pathsep$object"; + lstat ($object); + + if (-d _ && &remove_directory_tree_inner ($subdirhandle, $object)) + { + rmdir $object || return 0; + } + else + { + unlink $object || return 0; + } + } + closedir ($dirhandle); + return 1; +} + +# We used to use this behavior for this function: +# +#sub touch +#{ +# local (@filenames) = @_; +# local ($now) = time; +# local ($file); +# +# foreach $file (@filenames) +# { +# utime ($now, $now, $file) +# || (open (TOUCHFD, ">> $file") && close (TOUCHFD)) +# || &error ("Couldn't touch $file: $!\n", 1); +# } +# return 1; +#} +# +# But this behaves badly on networked filesystems where the time is +# skewed, because it sets the time of the file based on the _local_ +# host. Normally when you modify a file, it's the _remote_ host that +# determines the modtime, based on _its_ clock. So, instead, now we open +# the file and write something into it to force the remote host to set +# the modtime correctly according to its clock. +# + +sub touch +{ + local ($file); + + foreach $file (@_) { + (open(T, ">> $file") && print(T "\n") && close(T)) + || &error("Couldn't touch $file: $!\n", 1); + } +} + +# Touch with a time offset. To DTRT, call touch() then use stat() to get the +# access/mod time for each file and apply the offset. + +sub utouch +{ + local ($off) = shift; + local ($file); + + &touch(@_); + + local (@s) = stat($_[0]); + + utime($s[8]+$off, $s[9]+$off, @_); +} + +# open a file, write some stuff to it, and close it. + +sub create_file +{ + local ($filename, @lines) = @_; + + open (CF, "> $filename") || &error ("Couldn't open $filename: $!\n", 1); + foreach $line (@lines) + { + print CF $line; + } + close (CF); +} + +# create a directory tree described by an associative array, wherein each +# key is a relative pathname (using slashes) and its associated value is +# one of: +# DIR indicates a directory +# FILE:contents indicates a file, which should contain contents +\n +# LINK:target indicates a symlink, pointing to $basedir/target +# The first argument is the dir under which the structure will be created +# (the dir will be made and/or cleaned if necessary); the second argument +# is the associative array. + +sub create_dir_tree +{ + local ($basedir, %dirtree) = @_; + local ($path); + + &remove_directory_tree ("$basedir"); + mkdir ($basedir, 0777) || &error ("Couldn't mkdir $basedir: $!\n", 1); + + foreach $path (sort keys (%dirtree)) + { + if ($dirtree {$path} =~ /^DIR$/) + { + mkdir ("$basedir/$path", 0777) + || &error ("Couldn't mkdir $basedir/$path: $!\n", 1); + } + elsif ($dirtree {$path} =~ /^FILE:(.*)$/) + { + &create_file ("$basedir/$path", $1 . "\n"); + } + elsif ($dirtree {$path} =~ /^LINK:(.*)$/) + { + symlink ("$basedir/$1", "$basedir/$path") + || &error ("Couldn't symlink $basedir/$path -> $basedir/$1: $!\n", 1); + } + else + { + &error ("Bogus dirtree type: \"$dirtree{$path}\"\n", 1); + } + } + if ($just_setup_tree) + { + die "Tree is setup...\n"; + } +} + +# compare a directory tree with an associative array in the format used +# by create_dir_tree, above. +# The first argument is the dir under which the structure should be found; +# the second argument is the associative array. + +sub compare_dir_tree +{ + local ($basedir, %dirtree) = @_; + local ($path); + local ($i); + local ($bogus) = 0; + local ($contents); + local ($target); + local ($fulltarget); + local ($found); + local (@files); + local (@allfiles); + + opendir (DIR, $basedir) || &error ("Couldn't open $basedir: $!\n", 1); + @allfiles = grep (!/^(\.\.?|CVS|RCS)$/, readdir (DIR) ); + closedir (DIR); + if ($debug) + { + print "dirtree: (%dirtree)\n$basedir: (@allfiles)\n"; + } + + foreach $path (sort keys (%dirtree)) + { + if ($debug) + { + print "Checking $path ($dirtree{$path}).\n"; + } + + $found = 0; + foreach $i (0 .. $#allfiles) + { + if ($allfiles[$i] eq $path) + { + splice (@allfiles, $i, 1); # delete it + if ($debug) + { + print " Zapped $path; files now (@allfiles).\n"; + } + lstat ("$basedir/$path"); + $found = 1; + last; + } + } + + if (!$found) + { + print "compare_dir_tree: $path does not exist.\n"; + $bogus = 1; + next; + } + + if ($dirtree {$path} =~ /^DIR$/) + { + if (-d _ && opendir (DIR, "$basedir/$path") ) + { + @files = readdir (DIR); + closedir (DIR); + @files = grep (!/^(\.\.?|CVS|RCS)$/ && ($_ = "$path/$_"), @files); + push (@allfiles, @files); + if ($debug) + { + print " Read in $path; new files (@files).\n"; + } + } + else + { + print "compare_dir_tree: $path is not a dir.\n"; + $bogus = 1; + } + } + elsif ($dirtree {$path} =~ /^FILE:(.*)$/) + { + if (-l _ || !-f _) + { + print "compare_dir_tree: $path is not a file.\n"; + $bogus = 1; + next; + } + + if ($1 ne "*") + { + $contents = &read_file_into_string ("$basedir/$path"); + if ($contents ne "$1\n") + { + print "compare_dir_tree: $path contains wrong stuff." + . " Is:\n$contentsShould be:\n$1\n"; + $bogus = 1; + } + } + } + elsif ($dirtree {$path} =~ /^LINK:(.*)$/) + { + $target = $1; + if (!-l _) + { + print "compare_dir_tree: $path is not a link.\n"; + $bogus = 1; + next; + } + + $contents = readlink ("$basedir/$path"); + $contents =~ tr/>/\//; + $fulltarget = "$basedir/$target"; + $fulltarget =~ tr/>/\//; + if (!($contents =~ /$fulltarget$/)) + { + if ($debug) + { + $target = $fulltarget; + } + print "compare_dir_tree: $path should be link to $target, " + . "not $contents.\n"; + $bogus = 1; + } + } + else + { + &error ("Bogus dirtree type: \"$dirtree{$path}\"\n", 1); + } + } + + if ($debug) + { + print "leftovers: (@allfiles).\n"; + } + + foreach $file (@allfiles) + { + print "compare_dir_tree: $file should not exist.\n"; + $bogus = 1; + } + + return !$bogus; +} + +# this subroutine generates the numeric suffix used to keep tmp filenames, +# log filenames, etc., unique. If the number passed in is 1, then a null +# string is returned; otherwise, we return ".n", where n + 1 is the number +# we were given. + +sub num_suffix +{ + local($num) = @_; + + if (--$num > 0) { + return "$extext$num"; + } + + return ""; +} + +# This subroutine returns a log filename with a number appended to +# the end corresponding to how many logfiles have been created in the +# current running test. An optional parameter may be passed (0 or 1). +# If a 1 is passed, then it does NOT increment the logfile counter +# and returns the name of the latest logfile. If either no parameter +# is passed at all or a 0 is passed, then the logfile counter is +# incremented and the new name is returned. + +sub get_logfile +{ + local($no_increment) = @_; + + $num_of_logfiles += !$no_increment; + + return ($log_filename . &num_suffix ($num_of_logfiles)); +} + +# This subroutine returns a base (answer) filename with a number +# appended to the end corresponding to how many logfiles (and thus +# base files) have been created in the current running test. +# NO PARAMETERS ARE PASSED TO THIS SUBROUTINE. + +sub get_basefile +{ + return ($base_filename . &num_suffix ($num_of_logfiles)); +} + +# This subroutine returns a difference filename with a number appended +# to the end corresponding to how many logfiles (and thus diff files) +# have been created in the current running test. + +sub get_difffile +{ + return ($diff_filename . &num_suffix ($num_of_logfiles)); +} + +# This subroutine returns a command filename with a number appended +# to the end corresponding to how many logfiles (and thus command files) +# have been created in the current running test. + +sub get_runfile +{ + return ($run_filename . &num_suffix ($num_of_logfiles)); +} + +# just like logfile, only a generic tmp filename for use by the test. +# they are automatically cleaned up unless -keep was used, or the test fails. +# Pass an argument of 1 to return the same filename as the previous call. + +sub get_tmpfile +{ + local($no_increment) = @_; + + $num_of_tmpfiles += !$no_increment; + + return ($tmp_filename . &num_suffix ($num_of_tmpfiles)); +} + +1; |