| #!/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-2016 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; |
