diff options
Diffstat (limited to 'tests/test_driver.pl')
| -rw-r--r-- | tests/test_driver.pl | 1474 |
1 files changed, 1474 insertions, 0 deletions
diff --git a/tests/test_driver.pl b/tests/test_driver.pl new file mode 100644 index 0000000..91141eb --- /dev/null +++ b/tests/test_driver.pl @@ -0,0 +1,1474 @@ +#!/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-2014 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$ + + +# 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; +$test_timeout = 10 if $^O eq 'VMS'; + +# 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 = (); + +sub vms_get_process_logicals { + # Sorry for the long note here, but to keep this test running on + # VMS, it is needed to be understood. + # + # Perl on VMS by default maps the %ENV array to the system wide logical + # name table. + # + # This is a very large dynamically changing table. + # On Linux, this would be the equivalent of a table that contained + # every mount point, temporary pipe, and symbolic link on every + # file system. You normally do not have permission to clear or replace it, + # and if you did, the results would be catastrophic. + # + # On VMS, added/changed %ENV items show up in the process logical + # name table. So to track changes, a copy of it needs to be captured. + + my $raw_output = `show log/process/access_mode=supervisor`; + my @raw_output_lines = split('\n',$raw_output); + my %log_hash; + foreach my $line (@raw_output_lines) { + if ($line =~ /^\s+"([A-Za-z\$_]+)"\s+=\s+"(.+)"$/) { + $log_hash{$1} = $2; + } + } + return \%log_hash +} + +# %origENV is the caller's original environment +if ($^O ne 'VMS') { + %origENV = %ENV; +} else { + my $proc_env = vms_get_process_logicals; + %origENV = %{$proc_env}; +} + +sub resetENV +{ + # We used to say "%ENV = ();" but this doesn't work in Perl 5.000 + # through Perl 5.004. It was fixed in Perl 5.004_01, but we don't + # want to require that here, so just delete each one individually. + + if ($^O ne 'VMS') { + foreach $v (keys %ENV) { + delete $ENV{$v}; + } + + %ENV = %makeENV; + } else { + my $proc_env = vms_get_process_logicals(); + my %delta = %{$proc_env}; + foreach my $v (keys %delta) { + if (exists $origENV{$v}) { + if ($origENV{$v} ne $delta{$v}) { + $ENV{$v} = $origENV{$v}; + } + } else { + delete $ENV{$v}; + } + } + } + + 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', + 'LD_LIBRARY_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 unless $^O eq 'VMS'; + + 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 ($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 $logical_device = $ENV{$dirs[1]}; + if ($logical_device =~ /([A-Za-z0-9_]+):(:?.+:)+/) + { + # A search list was found. Grab the first logical device + # and use it instead of the search list. + $dirs[1]=$1; + my $lcl_pwd = join('/', @dirs); + $workpath = $lcl_pwd . '/' . $workdir + } + } + + if (-d $workpath) + { + print "Clearing $workpath...\n"; + &remove_directory_tree("$workpath/") + || &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); + # 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"); + 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_all_tests(); + + 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 : ''; + + if ($osname eq 'VMS') + { + $vos = 0; + $pathsep = "/"; + return; + } + + # Find a path to Perl + + # See if the filesystem supports long file names with multiple + # dots. DOS doesn't. + $short_filenames = 0; + (open (TOUCHFD, "> fancy.file.name") && 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_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"; + + setup_for_test(); + + $output = "........................................................ "; + + substr($output,0,length($testname)) = "$testname "; + + print $output; + + $tests_run = 0; + $tests_passed = 0; + + # Run the test! + $code = do $perl_testname; + + ++$categories_run; + $total_tests_run += $tests_run; + $total_tests_passed += $tests_passed; + + # How did it go? + if (!defined($code)) { + # Failed to parse or called die + if (length ($@)) { + warn "\n*** Test died ($testname): $@\n"; + } else { + warn "\n*** Couldn't parse $perl_testname\n"; + } + $status = "FAILED ($tests_passed/$tests_run passed)"; + } + + elsif ($code == -1) { + # Skipped... not supported + $status = "N/A"; + --$categories_run; + } + + elsif ($code != 1) { + # Bad result... this shouldn't really happen. Usually means that + # the suite forgot to end with "1;". + warn "\n*** Test returned $code\n"; + $status = "FAILED ($tests_passed/$tests_run passed)"; + } + + elsif ($tests_run == 0) { + # Nothing was done!! + $status = "FAILED (no tests found!)"; + } + + elsif ($tests_run > $tests_passed) { + # Lose! + $status = "FAILED ($tests_passed/$tests_run passed)"; + } + + else { + # Win! + ++$categories_passed; + $status = "ok ($tests_passed passed)"; + + # Clean up + for ($i = $num_of_tmpfiles; $i; $i--) { + rmfiles($tmp_filename . num_suffix($i)); + } + for ($i = $num_of_logfiles ? $num_of_logfiles : 1; $i; $i--) { + rmfiles($log_filename . num_suffix($i)); + rmfiles($base_filename . num_suffix($i)); + } + } + + # If the verbose option has been specified, then a short description + # of each test is printed before displaying the results of each test + # describing WHAT is being tested. + + if ($verbose) { + if ($detail) { + print "\nWHAT IS BEING TESTED\n"; + print "--------------------"; + } + print "\n\n$description\n\n"; + } + + # If the detail option has been specified, then the details of HOW + # the test is testing what it says it is testing in the verbose output + # will be displayed here before the results of the test are displayed. + + if ($detail) { + print "\nHOW IT IS TESTED\n"; + print "----------------"; + print "\n\n$details\n\n"; + } + + print "$status\n"; + } +} + +# If the keep flag is not set, this subroutine deletes all filenames that +# 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); + + ++$tests_run; + + if (! defined $answer) { + print "Ignoring output ........ " if $debug; + $answer_matched = 1; + } else { + print "Comparing Output ........ " if $debug; + + $slurp = &read_file_into_string ($logfile); + + # For make, get rid of any time skew error before comparing--too bad this + # has to go into the "generic" driver code :-/ + $slurp =~ s/^.*modification time .*in the future.*\n//gm; + $slurp =~ s/^.*Clock skew detected.*\n//gm; + + if ($slurp eq $answer) { + $answer_matched = 1; + } else { + # See if it is a slash or CRLF problem + 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 ($^O eq 'VMS') { + + # VMS has extra blank lines in output sometimes. + # Ticket #41760 + if (!$answer_matched) { + $slurp_mod =~ s/\n\n+/\n/gm; + $slurp_mod =~ s/\A\n+//g; + $answer_matched = ($slurp_mod eq $answer_mod); + } + + # VMS adding a "Waiting for unfinished jobs..." + # Remove it for now to see what else is going on. + if (!$answer_matched) { + $slurp_mod =~ s/^.+\*\*\* Waiting for unfinished jobs.+$//m; + $slurp_mod =~ s/\n\n/\n/gm; + $slurp_mod =~ s/^\n+//gm; + $answer_matched = ($slurp_mod eq $answer_mod); + } + + # VMS wants target device to exist or generates an error, + # Some test tagets look like VMS devices and trip this. + if (!$answer_matched) { + $slurp_mod =~ s/^.+\: no such device or address.*$//gim; + $slurp_mod =~ s/\n\n/\n/gm; + $slurp_mod =~ s/^\n+//gm; + $answer_matched = ($slurp_mod eq $answer_mod); + } + + # VMS error message has a different case + if (!$answer_matched) { + $slurp_mod =~ s/no such file /No such file /gm; + $answer_matched = ($slurp_mod eq $answer_mod); + } + + # VMS is putting comas instead of spaces in output + if (!$answer_matched) { + $slurp_mod =~ s/,/ /gm; + $answer_matched = ($slurp_mod eq $answer_mod); + } + + # VMS Is sometimes adding extra leading spaces to output? + if (!$answer_matched) { + my $slurp_mod = $slurp_mod; + $slurp_mod =~ s/^ +//gm; + $answer_matched = ($slurp_mod eq $answer_mod); + } + + # VMS port not handling POSIX encoded child status + # Translate error case it for now. + if (!$answer_matched) { + $slurp_mod =~ s/0x1035a00a/1/gim; + $answer_matched = 1 if $slurp_mod =~ /\Q$answer_mod\E/i; + + } + if (!$answer_matched) { + $slurp_mod =~ s/0x1035a012/2/gim; + $answer_matched = ($slurp_mod eq $answer_mod); + } + + # Tests are using a UNIX null command, temp hack + # until this can be handled by the VMS port. + # ticket # 41761 + if (!$answer_matched) { + $slurp_mod =~ s/^.+DCL-W-NOCOMD.*$//gim; + $slurp_mod =~ s/\n\n+/\n/gm; + $slurp_mod =~ s/^\n+//gm; + $answer_matched = ($slurp_mod eq $answer_mod); + } + # Tests are using exit 0; + # this generates a warning that should stop the make, but does not + if (!$answer_matched) { + $slurp_mod =~ s/^.+NONAME-W-NOMSG.*$//gim; + $slurp_mod =~ s/\n\n+/\n/gm; + $slurp_mod =~ s/^\n+//gm; + $answer_matched = ($slurp_mod eq $answer_mod); + } + + # VMS is sometimes adding single quotes to output? + if (!$answer_matched) { + my $noq_slurp_mod = $slurp_mod; + $noq_slurp_mod =~ s/\'//gm; + $answer_matched = ($noq_slurp_mod eq $answer_mod); + + # And missing an extra space in output + if (!$answer_matched) { + $noq_answer_mod = $answer_mod; + $noq_answer_mod =~ s/\h\h+/ /gm; + $answer_matched = ($noq_slurp_mod eq $noq_answer_mod); + } + + # VMS adding ; to end of some lines. + if (!$answer_matched) { + $noq_slurp_mod =~ s/;\n/\n/gm; + $answer_matched = ($noq_slurp_mod eq $noq_answer_mod); + } + + # VMS adding trailing space to end of some quoted lines. + if (!$answer_matched) { + $noq_slurp_mod =~ s/\h+\n/\n/gm; + $answer_matched = ($noq_slurp_mod eq $noq_answer_mod); + } + + # And VMS missing leading blank line + if (!$answer_matched) { + $noq_answer_mod =~ s/\A\n//g; + $answer_matched = ($noq_slurp_mod eq $noq_answer_mod); + } + + # Unix double quotes showing up as single quotes on VMS. + if (!$answer_matched) { + $noq_answer_mod =~ s/\"//g; + $answer_matched = ($noq_slurp_mod eq $noq_answer_mod); + } + } + } + + # If it still doesn't match, see if the answer might be a regex. + if (!$answer_matched && $answer =~ m,^/(.+)/$,) { + $answer_matched = ($slurp =~ /$1/); + if (!$answer_matched && $answer_mod =~ m,^/(.+)/$,) { + $answer_matched = ($slurp_mod =~ /$1/); + } + } + } + } + + if ($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); + } + + return 0; +} + +sub read_file_into_string +{ + local($filename) = @_; + local($oldslash) = $/; + + undef $/; + + open (RFISFILE, $filename) || return ""; + local ($slurp) = <RFISFILE>; + close (RFISFILE); + + $/ = $oldslash; + + return $slurp; +} + +my @OUTSTACK = (); +my @ERRSTACK = (); + +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; + } + + my $dup = undef; + open($dup, '>&', STDOUT) or error("ado: $! duping STDOUT\n", 1); + push @OUTSTACK, $dup; + + $dup = undef; + open($dup, '>&', STDERR) or error("ado: $! duping STDERR\n", 1); + push @ERRSTACK, $dup; + + open(STDOUT, '>', $filename) or error("ado: $filename: $!\n", 1); + open(STDERR, ">&STDOUT") or error("ado: $filename: $!\n", 1); +} + +# close the current stdout/stderr, and restore the previous ones from +# the "stack." + +sub detach_default_output +{ + local ($code); + + if ($vos) + { + $code = system "++detach_default_output_hack"; + $code == -2 || &error ("ddoh death\n", 1); + return 1; + } + + @OUTSTACK or error("default output stack has flown under!\n", 1); + + close(STDOUT); + close(STDERR) unless $^O eq 'VMS'; + + + open (STDOUT, '>&', pop @OUTSTACK) or error("ddo: $! duping STDOUT\n", 1); + open (STDERR, '>&', pop @ERRSTACK) or error("ddo: $! duping STDERR\n", 1); +} + +# 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 { + 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(@_); + my $severity = ${^CHILD_ERROR_NATIVE} & 7; + $code = 0; + if (($severity & 1) == 0) { + $code = 512; + } + + # Get the vms status. + my $vms_code = ${^CHILD_ERROR_NATIVE}; + + # Remove the print status bit + $vms_code &= ~0x10000000; + + # Posix code translation. + if (($vms_code & 0xFFFFF000) == 0x35a000) { + $code = (($vms_code & 0xFFF) >> 3) * 256; + } + } else { + my $pid = fork(); + if (! $pid) { + exec(@_) or die "Cannot execute $_[0]\n"; + } + local $SIG{ALRM} = sub { my $e = $ERRSTACK[0]; print $e "\nTest timed out after $test_timeout seconds\n"; die "timeout\n"; }; + alarm $test_timeout; + waitpid($pid, 0) > 0 or die "No such pid: $pid\n"; + $code = $?; + } + alarm 0; + }; + if ($@) { + # The eval failed. If it wasn't SIGALRM then die. + $@ eq "timeout\n" or die "Command failed: $@"; + + # 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; + print "vms status = ${^CHILD_ERROR_NATIVE}\n" if $debug and $^O eq 'VMS'; + return $code; +} + +# run one command (passed as a list of arg 0 - n, with arg 0 being the +# second arg to this routine), returning 0 on success and non-zero on failure. +# The first arg to this routine is a filename to connect to the stdout +# & stderr of the child process. + +sub run_command_with_output +{ + my $filename = shift; + + print "\nrun_command_with_output($filename,$runname): @_\n" if $debug; + &attach_default_output ($filename); + my $code = eval { _run_command(@_) }; + my $err = $@; + &detach_default_output; + + $err and die $err; + + print "run_command_with_output returned $code.\n" if $debug; + print "vms status = ${^CHILD_ERROR_NATIVE}\n" if $debug and $^O eq 'VMS'; + return $code; +} + +# performs the equivalent of an "rm -rf" on the first argument. Like +# rm, if the path ends in /, leaves the (now empty) directory; otherwise +# deletes it, too. + +sub remove_directory_tree +{ + 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 + { + if ($^O ne 'VMS') + { + unlink $object || return 0; + } + else + { + # VMS can have multiple versions of a file. + 1 while unlink $object; + } + } + } + closedir ($dirhandle); + return 1; +} + +# We used to use this behavior for this function: +# +#sub touch +#{ +# 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; |