tests/test_driver.pl

   1 #!/usr/bin/perl
   2 # -*-perl-*-
   3 #
   4 # Modification history:
   5 # Written 91-12-02 through 92-01-01 by Stephen McGee.
   6 # Modified 92-02-11 through 92-02-22 by Chris Arthur to further generalize.
   7 #
   8 # Copyright (C) 1991-2022 Free Software Foundation, Inc.
   9 # This file is part of GNU Make.
  10 #
  11 # GNU Make is free software; you can redistribute it and/or modify it under
  12 # the terms of the GNU General Public License as published by the Free Software
  13 # Foundation; either version 3 of the License, or (at your option) any later
  14 # version.
  15 #
  16 # GNU Make is distributed in the hope that it will be useful, but WITHOUT ANY
  17 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  18 # FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  19 # details.
  20 #
  21 # You should have received a copy of the GNU General Public License along with
  22 # this program.  If not, see <https://www.gnu.org/licenses/>.
  23
  24
  25 # Test driver routines used by a number of test suites, including
  26 # those for SCS, make, roll_dir, and scan_deps (?).
  27 #
  28 # this routine controls the whole mess; each test suite sets up a few
  29 # variables and then calls &toplevel, which does all the real work.
  30
  31 # $Id$
  32
  33 use Config;
  34 use Cwd;
  35 use File::Spec;
  36 use File::Temp;
  37
  38 # The number of test categories we've run
  39 $categories_run = 0;
  40 # The number of test categroies that have passed
  41 $categories_passed = 0;
  42 # The total number of individual tests that have been run
  43 $total_tests_run = 0;
  44 # The total number of individual tests that have passed
  45 $total_tests_passed = 0;
  46 # The number of tests in this category that have been run
  47 $tests_run = 0;
  48 # The number of tests in this category that have passed
  49 $tests_passed = 0;
  50
  51 $port_type = undef;
  52 $osname = undef;
  53 $vos = undef;
  54 $pathsep = undef;
  55
  56 # Yeesh.  This whole test environment is such a hack!
  57 $test_passed = 1;
  58
  59 # Timeout in seconds.  If the test takes longer than this we'll fail it.
  60 # This is to prevent hung tests.
  61 $test_timeout = 60;
  62
  63 $diff_name = undef;
  64
  65 # Path to Perl
  66 $perl_name = $^X;
  67 if ($^O ne 'VMS') {
  68     $perl_name .= $Config{_exe} unless $perl_name =~ m/$Config{_exe}$/i;
  69 }
  70
  71 sub which {
  72   my $cmd = $_[0];
  73
  74   # Poor man's File::Which
  75   my ($v,$d,$f) = File::Spec->splitpath($cmd);
  76   if ($d) {
  77     # The command has a pathname so don't look for it in PATH.
  78     # Use forward-slashes even on Windows, else it fails in recipes.
  79     (-f $cmd and -x _) or return undef;
  80     $cmd =~ tr,\\,/,;
  81     return $cmd;
  82   }
  83
  84   my @ext;
  85   if ($port_type eq 'UNIX' || $port_type eq 'VMS-DCL') {
  86     @ext = ('');
  87   } else {
  88     @ext = index($f, '.') == -1 ? () : ('');
  89     push @ext, split /;/, $ENV{PATHEXT};
  90   }
  91
  92   foreach my $dir (File::Spec->path()) {
  93     foreach my $e (@ext) {
  94       my $p = File::Spec->catfile($dir, "$cmd$e");
  95       (-f $p and -x _) or next;
  96       # Use forward-slashes even on Windows, else it fails in recipes.
  97       $p =~ tr,\\,/,;
  98       return $p;
  99     }
 100   }
 101   return undef;
 102 }
 103
 104 # %makeENV is the cleaned-out environment.  Tests must not modify it.
 105 my %makeENV = ();
 106
 107 sub vms_get_process_logicals {
 108   # Sorry for the long note here, but to keep this test running on
 109   # VMS, it is needed to be understood.
 110   #
 111   # Perl on VMS by default maps the %ENV array to the system wide logical
 112   # name table.
 113   #
 114   # This is a very large dynamically changing table.
 115   # On Linux, this would be the equivalent of a table that contained
 116   # every mount point, temporary pipe, and symbolic link on every
 117   # file system.  You normally do not have permission to clear or replace it,
 118   # and if you did, the results would be catastrophic.
 119   #
 120   # On VMS, added/changed %ENV items show up in the process logical
 121   # name table.  So to track changes, a copy of it needs to be captured.
 122
 123   my $raw_output = `show log/process/access_mode=supervisor`;
 124   my @raw_output_lines = split('\n',$raw_output);
 125   my %log_hash;
 126   foreach my $line (@raw_output_lines) {
 127     if ($line =~ /^\s+"([A-Za-z\$_]+)"\s+=\s+"(.+)"$/) {
 128       $log_hash{$1} = $2;
 129     }
 130   }
 131   return \%log_hash
 132 }
 133
 134 # %origENV is the caller's original environment
 135 if ($^O ne 'VMS') {
 136   %origENV = %ENV;
 137 } else {
 138   my $proc_env = vms_get_process_logicals;
 139   %origENV = %{$proc_env};
 140 }
 141
 142 sub resetENV
 143 {
 144   # We used to say "%ENV = ();" but this doesn't work in Perl 5.000
 145   # through Perl 5.004.  It was fixed in Perl 5.004_01, but we don't
 146   # want to require that here, so just delete each one individually.
 147
 148   if ($^O ne 'VMS') {
 149     foreach $v (keys %ENV) {
 150       delete $ENV{$v};
 151     }
 152
 153     %ENV = %makeENV;
 154   } else {
 155     my $proc_env = vms_get_process_logicals();
 156     my %delta = %{$proc_env};
 157     foreach my $v (keys %delta) {
 158       if (exists $origENV{$v}) {
 159         if ($origENV{$v} ne $delta{$v}) {
 160           $ENV{$v} = $origENV{$v};
 161         }
 162       } else {
 163         delete $ENV{$v};
 164       }
 165     }
 166   }
 167 }
 168
 169 # Returns a string-ified version of cmd which is a value provided to exec()
 170 # so it can either be a ref of a list or a string.
 171 sub cmd2str
 172 {
 173     my $cmd = $_[0];
 174     if (!ref($cmd)) {
 175         return $cmd;
 176     }
 177
 178     my @c;
 179     foreach (@$cmd) {
 180         if (/[][#;"*?&|<>(){}\$`^~!]/) {
 181             s/\'/\'\\'\'/g;
 182             push @c, "'$_'";
 183         } else {
 184             push @c, $_;
 185         }
 186     }
 187     return join(' ', @c);
 188 }
 189
 190 sub toplevel
 191 {
 192   %origENV = %ENV unless $^O eq 'VMS';
 193
 194   # Pull in benign variables from the user's environment
 195
 196   foreach (# POSIX-specific things
 197            'TZ', 'TMPDIR', 'HOME', 'USER', 'LOGNAME', 'PATH',
 198            'LD_LIBRARY_PATH',
 199            # *SAN things
 200            'ASAN_OPTIONS', 'UBSAN_OPTIONS', 'LSAN_OPTIONS',
 201            # Purify things
 202            'PURIFYOPTIONS',
 203            # Windows-specific things
 204            'Path', 'SystemRoot', 'TEMP', 'TMP', 'USERPROFILE', 'PATHEXT',
 205            # DJGPP-specific things
 206            'DJDIR', 'DJGPP', 'SHELL', 'COMSPEC', 'HOSTNAME', 'LFN',
 207            'FNCASE', '387', 'EMU387', 'GROUP'
 208           ) {
 209     $makeENV{$_} = $ENV{$_} if $ENV{$_};
 210   }
 211
 212   # Make sure our compares are not foiled by locale differences
 213
 214   $makeENV{LC_ALL} = 'C';
 215   $makeENV{LANG} = 'C';
 216   $makeENV{LANGUAGE} = 'C';
 217
 218   $| = 1;                     # unbuffered output
 219
 220   $debug = 0;                 # debug flag
 221   $profile = 0;               # profiling flag
 222   $verbose = 0;               # verbose mode flag
 223   $detail = 0;                # detailed verbosity
 224   $keep = 0;                  # keep temp files around
 225   $workdir = "work";          # The directory where the test will start running
 226   $tempdir = "_tmp";          # A temporary directory
 227   $scriptdir = "scripts";     # The directory where we find the test scripts
 228   $tmpfilesuffix = "t";       # the suffix used on tmpfiles
 229   $default_output_stack_level = 0;  # used by attach_default_output, etc.
 230   $default_input_stack_level = 0;   # used by attach_default_input, etc.
 231   $cwd = ".";                 # don't we wish we knew
 232   $cwdslash = "";             # $cwd . $pathsep, but "" rather than "./"
 233
 234   &get_osname;  # sets $osname, $vos, $pathsep, and $short_filenames
 235
 236   $perl_name = which($perl_name);
 237
 238   # See if we have a diff
 239   $diff_name = which('diff');
 240   if (!$diff_name) {
 241       print "No diff found; differences will not be shown\n";
 242   }
 243
 244   &set_defaults;  # suite-defined
 245
 246   &parse_command_line (@ARGV);
 247
 248   print "OS name = '$osname'\n" if $debug;
 249
 250   $temppath = File::Spec->rel2abs($tempdir);
 251
 252   if (-d $temppath) {
 253     print "Clearing $temppath...\n";
 254     &remove_directory_tree("$temppath/")
 255       or &error ("Couldn't wipe out $temppath: $!\n");
 256   } else {
 257     mkdir ($temppath, 0777) or error ("Cannot mkdir $temppath: $!\n");
 258   }
 259
 260   # This is used by POSIX systems
 261   $makeENV{TMPDIR} = $temppath;
 262
 263   # These are used on Windows
 264   $makeENV{TMP} = $temppath;
 265   $makeENV{TEMP} = $temppath;
 266
 267   # Replace the environment with the new one
 268   resetENV();
 269
 270   $workpath = "$cwdslash$workdir";
 271   $scriptpath = "$cwdslash$scriptdir";
 272
 273   &set_more_defaults;  # suite-defined
 274
 275   &print_banner;
 276
 277   if ($osname eq 'VMS' && $cwdslash eq "") {
 278     # Porting this script to VMS revealed a small bug in opendir() not
 279     # handling search lists correctly when the directory only exists in
 280     # one of the logical_devices.  Need to find the first directory in
 281     # the search list, as that is where things will be written to.
 282     my @dirs = split('/', $cwdpath);
 283
 284     my $logical_device = $ENV{$dirs[1]};
 285     if ($logical_device =~ /([A-Za-z0-9_]+):(:?.+:)+/) {
 286       # A search list was found.  Grab the first logical device
 287       # and use it instead of the search list.
 288       $dirs[1]=$1;
 289       my $lcl_pwd = join('/', @dirs);
 290       $workpath = $lcl_pwd . '/' . $workdir
 291     }
 292   }
 293
 294   if (-d $workpath) {
 295     print "Clearing $workpath...\n";
 296     &remove_directory_tree("$workpath/")
 297       or &error ("Couldn't wipe out $workpath: $!\n");
 298   } else {
 299     mkdir ($workpath, 0777) or &error ("Cannot mkdir $workpath: $!\n");
 300   }
 301
 302   if (!-d $scriptpath) {
 303     &error ("Failed to find $scriptpath containing perl test scripts.\n");
 304   }
 305
 306   if (@TESTS) {
 307     print "Making work dirs...\n";
 308     foreach $test (@TESTS) {
 309       if ($test =~ /^([^\/]+)\//) {
 310         $dir = $1;
 311         push (@rmdirs, $dir);
 312         -d "$workpath/$dir"
 313             or mkdir ("$workpath/$dir", 0777)
 314             or &error ("Couldn't mkdir $workpath/$dir: $!\n");
 315       }
 316     }
 317   } else {
 318     print "Finding tests...\n";
 319     opendir (SCRIPTDIR, $scriptpath)
 320         or &error ("Couldn't opendir $scriptpath: $!\n");
 321     @dirs = grep (!/^(\..*|CVS|RCS)$/, readdir (SCRIPTDIR) );
 322     closedir (SCRIPTDIR);
 323     foreach my $dir (@dirs) {
 324       next if ($dir =~ /^(\..*|CVS|RCS)$/ || ! -d "$scriptpath/$dir");
 325       push (@rmdirs, $dir);
 326       # VMS can have overlaid file systems, so directories may repeat.
 327       next if -d "$workpath/$dir";
 328       mkdir ("$workpath/$dir", 0777)
 329           or &error ("Couldn't mkdir $workpath/$dir: $!\n");
 330       opendir (SCRIPTDIR, "$scriptpath/$dir")
 331           or &error ("Couldn't opendir $scriptpath/$dir: $!\n");
 332       @files = grep (!/^(\..*|CVS|RCS|.*~)$/, readdir (SCRIPTDIR) );
 333       closedir (SCRIPTDIR);
 334       foreach my $test (@files) {
 335         -d $test and next;
 336         push (@TESTS, "$dir/$test");
 337       }
 338     }
 339   }
 340
 341   if (@TESTS == 0) {
 342     &error ("\nNo tests in $scriptpath, and none were specified.\n");
 343   }
 344
 345   print "\n";
 346
 347   run_all_tests();
 348
 349   foreach my $dir (@rmdirs) {
 350     rmdir ("$workpath/$dir");
 351   }
 352
 353   rmdir ($temppath);
 354
 355   $| = 1;
 356
 357   $categories_failed = $categories_run - $categories_passed;
 358   $total_tests_failed = $total_tests_run - $total_tests_passed;
 359
 360   if ($total_tests_failed) {
 361     print "\n$total_tests_failed Test";
 362     print "s" unless $total_tests_failed == 1;
 363     print " in $categories_failed Categor";
 364     print ($categories_failed == 1 ? "y" : "ies");
 365     print " Failed (See .$diffext* files in $workdir dir for details) :-(\n\n";
 366     return 0;
 367   }
 368
 369   print "\n$total_tests_passed Test";
 370   print "s" unless $total_tests_passed == 1;
 371   print " in $categories_passed Categor";
 372   print ($categories_passed == 1 ? "y" : "ies");
 373   print " Complete ... No Failures :-)\n\n";
 374   return 1;
 375 }
 376
 377 sub get_osname
 378 {
 379   # Set up an initial value.  In perl5 we can do it the easy way.
 380   $osname = defined($^O) ? $^O : '';
 381   $vos = 0;
 382   $pathsep = "/";
 383
 384   # find the type of the port.  We do this up front to have a single
 385   # point of change if it needs to be tweaked.
 386   #
 387   # This is probably not specific enough.
 388   #
 389   if ($osname =~ /MSWin32/i || $osname =~ /Windows/i
 390       || $osname =~ /MINGW32/i || $osname =~ /CYGWIN_NT/i) {
 391     $port_type = 'W32';
 392   }
 393   # Bleah, the osname is so variable on DOS.  This kind of bites.
 394   # Well, as far as I can tell if we check for some text at the
 395   # beginning of the line with either no spaces or a single space, then
 396   # a D, then either "OS", "os", or "ev" and a space.  That should
 397   # match and be pretty specific.
 398   elsif ($osname =~ /^([^ ]*|[^ ]* [^ ]*)D(OS|os|ev) /) {
 399     $port_type = 'DOS';
 400   }
 401   # Check for OS/2
 402   elsif ($osname =~ m%OS/2%) {
 403     $port_type = 'OS/2';
 404   }
 405
 406   # VMS has a GNV Unix mode or a DCL mode.
 407   # The SHELL environment variable should not be defined in VMS-DCL mode.
 408   elsif ($osname eq 'VMS' && !defined $ENV{"SHELL"}) {
 409     $port_type = 'VMS-DCL';
 410   }
 411   # Everything else, right now, is UNIX.  Note that we should integrate
 412   # the VOS support into this as well and get rid of $vos; we'll do
 413   # that next time.
 414   else {
 415     $port_type = 'UNIX';
 416   }
 417
 418   if ($osname eq 'VMS') {
 419     return;
 420   }
 421
 422   # Find a path to Perl
 423
 424   # See if the filesystem supports long file names with multiple
 425   # dots.  DOS doesn't.
 426   $short_filenames = 0;
 427   (open (TOUCHFD, "> fancy.file.name") and close (TOUCHFD))
 428       or $short_filenames = 1;
 429   unlink ("fancy.file.name") or $short_filenames = 1;
 430
 431   if (! $short_filenames) {
 432     # Thanks go to meyering@cs.utexas.edu (Jim Meyering) for suggesting a
 433     # better way of doing this.  (We used to test for existence of a /mnt
 434     # dir, but that apparently fails on an SGI Indigo (whatever that is).)
 435     # Because perl on VOS translates /'s to >'s, we need to test for
 436     # VOSness rather than testing for Unixness (ie, try > instead of /).
 437
 438     mkdir (".ostest", 0777) or &error ("Couldn't create .ostest: $!\n", 1);
 439     open (TOUCHFD, "> .ostest>ick") and close (TOUCHFD);
 440     chdir (".ostest") or &error ("Couldn't chdir to .ostest: $!\n", 1);
 441   }
 442
 443   if (! $short_filenames && -f "ick") {
 444     $osname = "vos";
 445     $vos = 1;
 446     $pathsep = ">";
 447
 448   } elsif ($osname eq '') {
 449     # the following is regrettably gnarly, but it seems to be the only way
 450     # to not get ugly error messages if uname can't be found.
 451     # Hmmm, BSD/OS 2.0's uname -a is excessively verbose.  Let's try it
 452     # with switches first.
 453     eval "chop (\$osname = `sh -c 'uname -nmsr 2>&1'`)";
 454     if ($osname =~ /not found/i) {
 455       $osname = "(something posixy with no uname)";
 456
 457     } elsif ($@ ne "" || $?) {
 458       eval "chop (\$osname = `sh -c 'uname -a 2>&1'`)";
 459       if ($@ ne "" || $?) {
 460         $osname = "(something posixy)";
 461       }
 462     }
 463   }
 464
 465   if (! $short_filenames) {
 466     chdir ("..") or &error ("Couldn't chdir to ..: $!\n", 1);
 467     unlink (".ostest>ick");
 468     rmdir (".ostest") or &error ("Couldn't rmdir .ostest: $!\n", 1);
 469   }
 470 }
 471
 472 sub parse_command_line
 473 {
 474   @argv = @_;
 475
 476   # use @ARGV if no args were passed in
 477
 478   if (@argv == 0) {
 479     @argv = @ARGV;
 480   }
 481
 482   # look at each option; if we don't recognize it, maybe the suite-specific
 483   # command line parsing code will...
 484
 485   while (@argv) {
 486     $option = shift @argv;
 487     if ($option =~ /^-usage$/i) {
 488       &print_usage;
 489       exit 0;
 490     }
 491     if ($option =~ /^-(h|help)$/i) {
 492       &print_help;
 493       exit 0;
 494     }
 495
 496     if ($option =~ /^-debug$/i) {
 497       print "\nDEBUG ON\n";
 498       $debug = 1;
 499
 500     } elsif ($option =~ /^-profile$/i) {
 501       $profile = 1;
 502
 503     } elsif ($option =~ /^-verbose$/i) {
 504       $verbose = 1;
 505
 506     } elsif ($option =~ /^-detail$/i) {
 507       $detail = 1;
 508       $verbose = 1;
 509
 510     } elsif ($option =~ /^-keep$/i) {
 511       $keep = 1;
 512
 513     } elsif (&valid_option($option)) {
 514       # The suite-defined subroutine takes care of the option
 515
 516     } elsif ($option =~ /^-/) {
 517       print "Invalid option: $option\n";
 518       &print_usage;
 519       exit 0;
 520
 521     } else { # must be the name of a test
 522       $option =~ s/\.pl$//;
 523       push(@TESTS,$option);
 524     }
 525   }
 526 }
 527
 528 sub max
 529 {
 530   my $num = shift @_;
 531   my $newnum;
 532
 533   while (@_) {
 534     $newnum = shift @_;
 535     if ($newnum > $num) {
 536       $num = $newnum;
 537     }
 538   }
 539
 540   return $num;
 541 }
 542
 543 sub print_centered
 544 {
 545   my ($width, $string) = @_;
 546
 547   if (length ($string)) {
 548     my $pad = " " x ( ($width - length ($string) + 1) / 2);
 549     print "$pad$string";
 550   }
 551 }
 552
 553 sub print_banner
 554 {
 555   # $testee is suite-defined
 556   my $info = "Running tests for $testee on $osname";
 557   my $len = &max (length($info), length($testee_version), 77) + 2;
 558   my $line = ("-" x $len) . "\n";
 559
 560   &print_centered ($len, $line);
 561   &print_centered ($len, $info."\n");
 562   &print_centered ($len, $testee_version);
 563   &print_centered ($len, $line);
 564   print "\n";
 565 }
 566
 567 sub run_all_tests
 568 {
 569   # Make sure we always run the tests from the current directory
 570   unshift(@INC, cwd());
 571
 572   $categories_run = 0;
 573
 574   # Make a copy of STDIN so we can reset it
 575   open(INCOPY, "<&STDIN");
 576
 577   # Leave enough space in the extensions to append a number, even
 578   # though it needs to fit into 8+3 limits.
 579   if ($short_filenames) {
 580     $logext = 'l';
 581     $diffext = 'd';
 582     $baseext = 'b';
 583     $runext = 'r';
 584     $extext = '';
 585   } else {
 586     $logext = 'log';
 587     $diffext = 'diff';
 588     $baseext = 'base';
 589     $runext = 'run';
 590     $extext = '.';
 591   }
 592
 593   $lasttest = '';
 594   # $testname is published
 595   foreach $testname (sort @TESTS) {
 596     # Skip duplicates on VMS caused by logical name search lists.
 597     next if $testname eq $lasttest;
 598
 599     $lasttest = $testname;
 600     $suite_passed = 1;       # reset by test on failure
 601     $num_of_logfiles = 0;
 602     $num_of_tmpfiles = 0;
 603     $description = "";
 604     $details = "";
 605     $old_makefile = undef;
 606     $testname =~ s/^$scriptpath$pathsep//;
 607     $perl_testname = "$scriptpath$pathsep$testname";
 608     $testname =~ s/(\.pl|\.perl)$//;
 609     $testpath = "$workpath$pathsep$testname";
 610     $extext = '_' if $^O eq 'VMS';
 611     $log_filename = "$testpath.$logext";
 612     $diff_filename = "$testpath.$diffext";
 613     $base_filename = "$testpath.$baseext";
 614     $run_filename = "$testpath.$runext";
 615     $tmp_filename = "$testpath.$tmpfilesuffix";
 616
 617     -f $perl_testname or die "Invalid test: $testname\n\n";
 618
 619     setup_for_test();
 620
 621     $output = "........................................................ ";
 622
 623     substr($output, 0, length($testname)) = "$testname ";
 624
 625     print $output;
 626
 627     $tests_run = 0;
 628     $tests_passed = 0;
 629
 630     # Run the test!
 631     $code = do $perl_testname;
 632
 633     # Reset STDIN from the copy in case it was changed
 634     open(STDIN, "<&INCOPY");
 635
 636     ++$categories_run;
 637     $total_tests_run += $tests_run;
 638     $total_tests_passed += $tests_passed;
 639
 640     # How did it go?
 641     if (!defined($code)) {
 642       # Failed to parse or called die
 643       if (length ($@)) {
 644         warn "\n*** Test died ($testname): $@\n";
 645       } else {
 646         warn "\n*** Couldn't parse $perl_testname\n";
 647       }
 648       $status = "FAILED ($tests_passed/$tests_run passed)";
 649
 650     } elsif ($code == -1) {
 651       # Skipped... not supported
 652       $status = "N/A";
 653       --$categories_run;
 654
 655     } elsif ($code != 1) {
 656       # Bad result... this shouldn't really happen.  Usually means that
 657       # the suite forgot to end with "1;".
 658       warn "\n*** Test returned $code\n";
 659       $status = "FAILED ($tests_passed/$tests_run passed)";
 660
 661     } elsif ($tests_run == 0) {
 662       # Nothing was done!!
 663       $status = "FAILED (no tests found!)";
 664
 665     } elsif ($tests_run > $tests_passed) {
 666       # Lose!
 667       $status = "FAILED ($tests_passed/$tests_run passed)";
 668
 669     } else {
 670       # Win!
 671       ++$categories_passed;
 672       $status = "ok     ($tests_passed passed)";
 673
 674       # Clean up
 675       for ($i = $num_of_tmpfiles; $i; $i--) {
 676         rmfiles($tmp_filename . num_suffix($i));
 677       }
 678       for ($i = $num_of_logfiles ? $num_of_logfiles : 1; $i; $i--) {
 679         rmfiles($log_filename . num_suffix($i));
 680         rmfiles($base_filename . num_suffix($i));
 681       }
 682     }
 683
 684     # If the verbose option has been specified, then a short description
 685     # of each test is printed before displaying the results of each test
 686     # describing WHAT is being tested.
 687
 688     if ($verbose) {
 689       if ($detail) {
 690         print "\nWHAT IS BEING TESTED\n";
 691         print "--------------------";
 692       }
 693       print "\n\n$description\n\n";
 694     }
 695
 696     # If the detail option has been specified, then the details of HOW
 697     # the test is testing what it says it is testing in the verbose output
 698     # will be displayed here before the results of the test are displayed.
 699
 700     if ($detail) {
 701       print "\nHOW IT IS TESTED\n";
 702       print "----------------";
 703       print "\n\n$details\n\n";
 704     }
 705
 706     print "$status\n";
 707   }
 708
 709   close(INCOPY);
 710 }
 711
 712 # If the keep flag is not set, this subroutine deletes all filenames that
 713 # are sent to it.
 714
 715 sub rmfiles
 716 {
 717   my (@files) = @_;
 718
 719   if (!$keep) {
 720     return (unlink @files);
 721   }
 722
 723   return 1;
 724 }
 725
 726 sub print_standard_usage
 727 {
 728   my ($plname, @moreusage) = @_;
 729
 730   print "usage:\t$plname [testname] [-verbose] [-detail] [-keep]\n";
 731   print "\t\t\t[-profile] [-usage] [-help] [-debug]\n";
 732   foreach (@moreusage) {
 733     print "\t\t\t$_\n";
 734   }
 735 }
 736
 737 sub print_standard_help
 738 {
 739   my (@morehelp) = @_;
 740   my $t = "      ";
 741
 742   my $line = "Test Driver For $testee";
 743   print "$line\n";
 744   $line = "=" x length ($line);
 745   print "$line\n";
 746
 747   print_usage();
 748
 749   print "\ntestname\n"
 750       . "${t}You may, if you wish, run only ONE test if you know the name\n"
 751       . "${t}of that test and specify this name anywhere on the command\n"
 752       . "${t}line.  Otherwise ALL existing tests in the scripts directory\n"
 753       . "${t}will be run.\n"
 754       . "-verbose\n"
 755       . "${t}If this option is given, a description of every test is\n"
 756       . "${t}displayed before the test is run. (Not all tests may have\n"
 757       . "${t}descriptions at this time)\n"
 758       . "-detail\n"
 759       . "${t}If this option is given, a detailed description of every\n"
 760       . "${t}test is displayed before the test is run. (Not all tests\n"
 761       . "${t}have descriptions at this time)\n"
 762       . "-profile\n"
 763       . "${t}If this option is given, then the profile file\n"
 764       . "${t}is added to other profiles every time $testee is run.\n"
 765       . "${t}This option only works on VOS at this time.\n"
 766       . "-keep\n"
 767       . "${t}You may give this option if you DO NOT want ANY\n"
 768       . "${t}of the files generated by the tests to be deleted. \n"
 769       . "${t}Without this option, all files generated by the test will\n"
 770       . "${t}be deleted IF THE TEST PASSES.\n"
 771       . "-debug\n"
 772       . "${t}Use this option if you would like to see all of the system\n"
 773       . "${t}calls issued and their return status while running the tests\n"
 774       . "${t}This can be helpful if you're having a problem adding a test\n"
 775       . "${t}to the suite, or if the test fails!\n";
 776
 777   foreach $line (@morehelp) {
 778     my $tline = $line;
 779     if (substr ($tline, 0, 1) eq "\t") {
 780       substr ($tline, 0, 1) = $t;
 781     }
 782     print "$tline\n";
 783   }
 784 }
 785
 786 #######################################################################
 787 ###########         Generic Test Driver Subroutines         ###########
 788 #######################################################################
 789
 790 sub get_caller
 791 {
 792   my $depth = defined ($_[0]) ? $_[0] : 1;
 793   my ($pkg, $filename, $linenum) = caller ($depth + 1);
 794   return "$filename: $linenum";
 795 }
 796
 797 sub error
 798 {
 799   my $message = $_[0];
 800   my $caller = &get_caller (1);
 801
 802   if (defined ($_[1])) {
 803     $caller = &get_caller ($_[1] + 1) . " -> $caller";
 804   }
 805
 806   die "$caller: $message";
 807 }
 808
 809 my %old_tempfiles = ();
 810
 811 sub compare_output
 812 {
 813   my ($answer, $logfile) = @_;
 814   my ($slurp, $answer_matched, $extra) = ('', 0, 0);
 815
 816   ++$tests_run;
 817
 818   my @tf = ();
 819   foreach my $file (glob(File::Spec->catfile($temppath, "*"))) {
 820     if (!exists $old_tempfiles{$file}) {
 821       push @tf, $file;
 822       $old_tempfiles{$file} = 1;
 823     }
 824   }
 825   if (@tf) {
 826     open (LOGFILE, '>>', $logfile) or die "Cannot open log file $logfile: $!\n";
 827     print LOGFILE "Leftover temporary files: @tf\n";
 828     close (LOGFILE);
 829     $extra = 1;
 830   }
 831
 832   if (! defined $answer) {
 833     print "Ignoring output ........ " if $debug;
 834     $answer_matched = 1;
 835   } else {
 836     print "Comparing output ........ " if $debug;
 837
 838     $slurp = &read_file_into_string ($logfile);
 839
 840     # For make, get rid of any time skew error before comparing--too bad this
 841     # has to go into the "generic" driver code :-/
 842     $slurp =~ s/^.*modification time .*in the future.*\n//gm;
 843     $slurp =~ s/^.*Clock skew detected.*\n//gm;
 844
 845     if ($slurp eq $answer) {
 846         $answer_matched = 1;
 847     } else {
 848       # See if it is a slash or CRLF problem
 849       my ($answer_mod, $slurp_mod) = ($answer, $slurp);
 850
 851       $answer_mod =~ tr,\\,/,;
 852       $answer_mod =~ s,\r\n,\n,gs;
 853
 854       $slurp_mod =~ tr,\\,/,;
 855       $slurp_mod =~ s,\r\n,\n,gs;
 856
 857       $answer_matched = ($slurp_mod eq $answer_mod);
 858
 859       if (!$answer_matched && $^O eq 'VMS') {
 860
 861         # VMS has extra blank lines in output sometimes.
 862         # Ticket #41760
 863         if (!$answer_matched) {
 864           $slurp_mod =~ s/\n\n+/\n/gm;
 865           $slurp_mod =~ s/\A\n+//g;
 866           $answer_matched = ($slurp_mod eq $answer_mod);
 867         }
 868
 869         # VMS adding a "Waiting for unfinished jobs..."
 870         # Remove it for now to see what else is going on.
 871         if (!$answer_matched) {
 872           $slurp_mod =~ s/^.+\*\*\* Waiting for unfinished jobs.+$//m;
 873           $slurp_mod =~ s/\n\n/\n/gm;
 874           $slurp_mod =~ s/^\n+//gm;
 875           $answer_matched = ($slurp_mod eq $answer_mod);
 876         }
 877
 878         # VMS wants target device to exist or generates an error,
 879         # Some test tagets look like VMS devices and trip this.
 880         if (!$answer_matched) {
 881           $slurp_mod =~ s/^.+\: no such device or address.*$//gim;
 882           $slurp_mod =~ s/\n\n/\n/gm;
 883           $slurp_mod =~ s/^\n+//gm;
 884           $answer_matched = ($slurp_mod eq $answer_mod);
 885         }
 886
 887         # VMS error message has a different case
 888         if (!$answer_matched) {
 889           $slurp_mod =~ s/no such file /No such file /gm;
 890           $answer_matched = ($slurp_mod eq $answer_mod);
 891         }
 892
 893         # VMS is putting comas instead of spaces in output
 894         if (!$answer_matched) {
 895           $slurp_mod =~ s/,/ /gm;
 896           $answer_matched = ($slurp_mod eq $answer_mod);
 897         }
 898
 899         # VMS Is sometimes adding extra leading spaces to output?
 900         if (!$answer_matched) {
 901            my $slurp_mod = $slurp_mod;
 902            $slurp_mod =~ s/^ +//gm;
 903            $answer_matched = ($slurp_mod eq $answer_mod);
 904         }
 905
 906         # VMS port not handling POSIX encoded child status
 907         # Translate error case it for now.
 908         if (!$answer_matched) {
 909           $slurp_mod =~ s/0x1035a00a/1/gim;
 910           $answer_matched = 1 if $slurp_mod =~ /\Q$answer_mod\E/i;
 911
 912         }
 913         if (!$answer_matched) {
 914           $slurp_mod =~ s/0x1035a012/2/gim;
 915           $answer_matched = ($slurp_mod eq $answer_mod);
 916         }
 917
 918         # Tests are using a UNIX null command, temp hack
 919         # until this can be handled by the VMS port.
 920         # ticket # 41761
 921         if (!$answer_matched) {
 922           $slurp_mod =~ s/^.+DCL-W-NOCOMD.*$//gim;
 923           $slurp_mod =~ s/\n\n+/\n/gm;
 924           $slurp_mod =~ s/^\n+//gm;
 925           $answer_matched = ($slurp_mod eq $answer_mod);
 926         }
 927         # Tests are using exit 0;
 928         # this generates a warning that should stop the make, but does not
 929         if (!$answer_matched) {
 930           $slurp_mod =~ s/^.+NONAME-W-NOMSG.*$//gim;
 931           $slurp_mod =~ s/\n\n+/\n/gm;
 932           $slurp_mod =~ s/^\n+//gm;
 933           $answer_matched = ($slurp_mod eq $answer_mod);
 934         }
 935
 936         # VMS is sometimes adding single quotes to output?
 937         if (!$answer_matched) {
 938           my $noq_slurp_mod = $slurp_mod;
 939           $noq_slurp_mod =~ s/\'//gm;
 940           $answer_matched = ($noq_slurp_mod eq $answer_mod);
 941
 942           # And missing an extra space in output
 943           if (!$answer_matched) {
 944             $noq_answer_mod = $answer_mod;
 945             $noq_answer_mod =~ s/\h\h+/ /gm;
 946             $answer_matched = ($noq_slurp_mod eq $noq_answer_mod);
 947           }
 948
 949           # VMS adding ; to end of some lines.
 950           if (!$answer_matched) {
 951             $noq_slurp_mod =~ s/;\n/\n/gm;
 952             $answer_matched = ($noq_slurp_mod eq $noq_answer_mod);
 953           }
 954
 955           # VMS adding trailing space to end of some quoted lines.
 956           if (!$answer_matched) {
 957             $noq_slurp_mod =~ s/\h+\n/\n/gm;
 958             $answer_matched = ($noq_slurp_mod eq $noq_answer_mod);
 959           }
 960
 961           # And VMS missing leading blank line
 962           if (!$answer_matched) {
 963             $noq_answer_mod =~ s/\A\n//g;
 964             $answer_matched = ($noq_slurp_mod eq $noq_answer_mod);
 965           }
 966
 967           # Unix double quotes showing up as single quotes on VMS.
 968           if (!$answer_matched) {
 969             $noq_answer_mod =~ s/\"//g;
 970             $answer_matched = ($noq_slurp_mod eq $noq_answer_mod);
 971           }
 972         }
 973       }
 974
 975       # If it still doesn't match, see if the answer might be a regex.
 976       if (!$answer_matched && $answer =~ m,^/(.+)/$,) {
 977         $answer_matched = ($slurp =~ /$1/);
 978         if (!$answer_matched && $answer_mod =~ m,^/(.+)/$,) {
 979             $answer_matched = ($slurp_mod =~ /$1/);
 980         }
 981       }
 982     }
 983   }
 984
 985   if ($keep || ! $answer_matched) {
 986     &create_file(&get_basefile, $answer);
 987     &create_file(&get_runfile, $command_string);
 988   }
 989
 990   if ($answer_matched && $test_passed && !$extra) {
 991     print "ok\n" if $debug;
 992     ++$tests_passed;
 993     return 1;
 994   }
 995
 996   if (! $answer_matched) {
 997     print "DIFFERENT OUTPUT\n" if $debug;
 998
 999     print "\nCreating Difference File ...\n" if $debug;
1000
1001     # Create the difference file
1002     my $base = get_basefile();
1003     if ($diff_name) {
1004         my $command = "$diff_name -c $base $logfile";
1005         &run_command_with_output(get_difffile(), $command);
1006     } else {
1007         create_file(get_difffile(), "Log file $logfile differs from base file $base\n");
1008     }
1009   }
1010
1011   return 0;
1012 }
1013
1014 sub read_file_into_string
1015 {
1016   my ($filename) = @_;
1017   my $oldslash = $/;
1018   undef $/;
1019
1020   open (RFISFILE, '<', $filename) or return "";
1021   my $slurp = <RFISFILE>;
1022   close (RFISFILE);
1023
1024   $/ = $oldslash;
1025
1026   return $slurp;
1027 }
1028
1029 my @OUTSTACK = ();
1030 my @ERRSTACK = ();
1031
1032 sub attach_default_output
1033 {
1034   my ($filename) = @_;
1035
1036   if ($vos)
1037   {
1038     my $code = system "++attach_default_output_hack $filename";
1039     $code == -2 or &error ("ado death\n", 1);
1040     return 1;
1041   }
1042
1043   my $dup = undef;
1044   open($dup, '>&', STDOUT) or error("ado: $! duping STDOUT\n", 1);
1045   push @OUTSTACK, $dup;
1046
1047   $dup = undef;
1048   open($dup, '>&', STDERR) or error("ado: $! duping STDERR\n", 1);
1049   push @ERRSTACK, $dup;
1050
1051   open(STDOUT, '>', $filename) or error("ado: $filename: $!\n", 1);
1052   open(STDERR, ">&STDOUT") or error("ado: $filename: $!\n", 1);
1053 }
1054
1055 # close the current stdout/stderr, and restore the previous ones from
1056 # the "stack."
1057
1058 sub detach_default_output
1059 {
1060   if ($vos)
1061   {
1062     my $code = system "++detach_default_output_hack";
1063     $code == -2 or &error ("ddoh death\n", 1);
1064     return 1;
1065   }
1066
1067   @OUTSTACK or error("default output stack has flown under!\n", 1);
1068
1069   close(STDOUT);
1070   close(STDERR) unless $^O eq 'VMS';
1071
1072
1073   open (STDOUT, '>&', pop @OUTSTACK) or error("ddo: $! duping STDOUT\n", 1);
1074   open (STDERR, '>&', pop @ERRSTACK) or error("ddo: $! duping STDERR\n", 1);
1075 }
1076
1077 sub _run_with_timeout
1078 {
1079   my $code;
1080   if ($^O eq 'VMS') {
1081     #local $SIG{ALRM} = sub {
1082     #    my $e = $ERRSTACK[0];
1083     #    print $e "\nTest timed out after $test_timeout seconds\n";
1084     #    die "timeout\n";
1085     #};
1086     #alarm $test_timeout;
1087     system(@_);
1088     #alarm 0;
1089     my $severity = ${^CHILD_ERROR_NATIVE} & 7;
1090     $code = 0;
1091     if (($severity & 1) == 0) {
1092       $code = 512;
1093     }
1094
1095     # Get the vms status.
1096     my $vms_code = ${^CHILD_ERROR_NATIVE};
1097
1098     # Remove the print status bit
1099     $vms_code &= ~0x10000000;
1100
1101     # Posix code translation.
1102     if (($vms_code & 0xFFFFF000) == 0x35a000) {
1103       $code = (($vms_code & 0xFFF) >> 3) * 256;
1104     }
1105
1106   } elsif ($port_type eq 'W32') {
1107     my $pid = system(1, @_);
1108     $pid > 0 or die "Cannot execute $_[0]\n";
1109     local $SIG{ALRM} = sub {
1110       my $e = $ERRSTACK[0];
1111       print $e "\nTest timed out after $test_timeout seconds\n";
1112       kill -9, $pid;
1113       die "timeout\n";
1114     };
1115     alarm $test_timeout;
1116     my $r = waitpid($pid, 0);
1117     alarm 0;
1118     $r == -1 and die "No such pid: $pid\n";
1119     # This shouldn't happen since we wait forever or timeout via SIGALRM
1120     $r == 0 and die "No process exited.\n";
1121     $code = $?;
1122
1123   } else {
1124     my $pid = fork();
1125     if (! $pid) {
1126       exec(@_) or die "exec: Cannot execute $_[0]: $!\n";
1127     }
1128     local $SIG{ALRM} = sub {
1129       my $e = $ERRSTACK[0];
1130       print $e "\nTest timed out after $test_timeout seconds\n";
1131       # Resend the alarm to our process group to kill the children.
1132       $SIG{ALRM} = 'IGNORE';
1133       kill -14, $$;
1134       die "timeout\n";
1135     };
1136     alarm $test_timeout;
1137     my $r = waitpid($pid, 0);
1138     alarm 0;
1139     $r == -1 and die "No such pid: $pid\n";
1140     # This shouldn't happen since we wait forever or timeout via SIGALRM
1141     $r == 0 and die "No process exited.\n";
1142     $code = $?;
1143   }
1144
1145   return $code;
1146 }
1147
1148 # This runs a command without any debugging info.
1149 sub _run_command
1150 {
1151   my $orig = $SIG{ALRM};
1152   my $code = eval { _run_with_timeout(@_); };
1153   $SIG{ALRM} = $orig;
1154
1155   # Reset then environment so that it's clean for the next test.
1156   resetENV();
1157
1158   if ($@) {
1159     # The eval failed.  If it wasn't SIGALRM then die.
1160     $@ eq "timeout\n" or die "Command failed: $@";
1161     $code = 14;
1162   }
1163
1164   return $code;
1165 }
1166
1167 # run one command (passed as a list of arg 0 - n), returning 0 on success
1168 # and nonzero on failure.
1169
1170 sub run_command
1171 {
1172   print "\nrun_command: @_\n" if $debug;
1173   my $code = _run_command(@_);
1174   print "run_command returned $code.\n" if $debug;
1175   print "vms status = ${^CHILD_ERROR_NATIVE}\n" if $debug and $^O eq 'VMS';
1176   return $code;
1177 }
1178
1179 # run one command (passed as a list of arg 0 - n, with arg 0 being the
1180 # second arg to this routine), returning 0 on success and non-zero on failure.
1181 # The first arg to this routine is a filename to connect to the stdout
1182 # & stderr of the child process.
1183
1184 sub run_command_with_output
1185 {
1186   my $filename = shift;
1187
1188   print "\nrun_command_with_output($filename,$runname): @_\n" if $debug;
1189   &attach_default_output ($filename);
1190   my $code = eval { _run_command(@_) };
1191   my $err = $@;
1192   &detach_default_output;
1193
1194   $err and die $err;
1195
1196   print "run_command_with_output returned $code.\n" if $debug;
1197   print "vms status = ${^CHILD_ERROR_NATIVE}\n" if $debug and $^O eq 'VMS';
1198   return $code;
1199 }
1200
1201 # performs the equivalent of an "rm -rf" on the first argument.  Like
1202 # rm, if the path ends in /, leaves the (now empty) directory; otherwise
1203 # deletes it, too.
1204
1205 sub remove_directory_tree
1206 {
1207   my ($targetdir) = @_;
1208   my ($nuketop) = 1;
1209
1210   my $ch = substr ($targetdir, length ($targetdir) - 1);
1211   if ($ch eq "/" || $ch eq $pathsep) {
1212     $targetdir = substr ($targetdir, 0, length ($targetdir) - 1);
1213     $nuketop = 0;
1214   }
1215
1216   -e $targetdir or return 1;
1217
1218   &remove_directory_tree_inner ("RDT00", $targetdir) or return 0;
1219   if ($nuketop && !rmdir ($targetdir)) {
1220     print "Cannot remove $targetdir: $!\n";
1221     return 0;
1222   }
1223
1224   return 1;
1225 }
1226
1227 sub remove_directory_tree_inner
1228 {
1229   my ($dirhandle, $targetdir) = @_;
1230
1231   opendir ($dirhandle, $targetdir) or return 0;
1232   my $subdirhandle = $dirhandle;
1233   $subdirhandle++;
1234   while (my $object = readdir ($dirhandle)) {
1235     $object =~ /^(\.\.?|CVS|RCS)$/ and next;
1236     $object = "$targetdir$pathsep$object";
1237
1238     lstat ($object);
1239     if (-d _ && &remove_directory_tree_inner ($subdirhandle, $object)) {
1240       if (!rmdir($object)) {
1241         print "Cannot remove $object: $!\n";
1242         return 0;
1243       }
1244     } else {
1245       if ($^O ne 'VMS') {
1246         if (!unlink $object) {
1247           print "Cannot unlink $object: $!\n";
1248           return 0;
1249         }
1250       } else {
1251         # VMS can have multiple versions of a file.
1252         1 while unlink $object;
1253       }
1254     }
1255   }
1256   closedir ($dirhandle);
1257   return 1;
1258 }
1259
1260 # We used to use this behavior for this function:
1261 #
1262 #sub touch
1263 #{
1264 #  my (@filenames) = @_;
1265 #  my $now = time;
1266 #
1267 #  foreach my $file (@filenames) {
1268 #    utime ($now, $now, $file)
1269 #          or (open (TOUCHFD, ">> $file") and close (TOUCHFD))
1270 #               or &error ("Couldn't touch $file: $!\n", 1);
1271 #  }
1272 #  return 1;
1273 #}
1274 #
1275 # But this behaves badly on networked filesystems where the time is
1276 # skewed, because it sets the time of the file based on the _local_
1277 # host.  Normally when you modify a file, it's the _remote_ host that
1278 # determines the modtime, based on _its_ clock.  So, instead, now we open
1279 # the file and write something into it to force the remote host to set
1280 # the modtime correctly according to its clock.
1281 #
1282
1283 sub touch
1284 {
1285   foreach my $file (@_) {
1286     (open(T, '>>', $file) and print(T "\n") and close(T))
1287         or &error("Couldn't touch $file: $!\n", 1);
1288   }
1289
1290   return @_;
1291 }
1292
1293 # Touch with a time offset.  To DTRT, call touch() then use stat() to get the
1294 # access/mod time for each file and apply the offset.
1295
1296 sub utouch
1297 {
1298   my $off = shift;
1299
1300   &touch(@_);
1301
1302   foreach my $f (@_) {
1303       my @s = stat($f);
1304       utime($s[8]+$off, $s[9]+$off, $f);
1305   }
1306
1307   return @_;
1308 }
1309
1310 # open a file, write some stuff to it, and close it.
1311
1312 sub create_file
1313 {
1314   my ($filename, @lines) = @_;
1315
1316   open (CF, "> $filename") or &error ("Couldn't open $filename: $!\n", 1);
1317   foreach $line (@lines) {
1318     print CF $line;
1319   }
1320   close (CF);
1321 }
1322
1323 # create a directory tree described by an associative array, wherein each
1324 # key is a relative pathname (using slashes) and its associated value is
1325 # one of:
1326 #    DIR            indicates a directory
1327 #    FILE:contents  indicates a file, which should contain contents +\n
1328 #    LINK:target    indicates a symlink, pointing to $basedir/target
1329 # The first argument is the dir under which the structure will be created
1330 # (the dir will be made and/or cleaned if necessary); the second argument
1331 # is the associative array.
1332
1333 sub create_dir_tree
1334 {
1335   my ($basedir, %dirtree) = @_;
1336
1337   &remove_directory_tree ("$basedir");
1338   mkdir ($basedir, 0777) or &error ("Couldn't mkdir $basedir: $!\n", 1);
1339
1340   foreach my $path (sort keys (%dirtree)) {
1341     if ($dirtree {$path} =~ /^DIR$/) {
1342       mkdir ("$basedir/$path", 0777)
1343           or &error ("Couldn't mkdir $basedir/$path: $!\n", 1);
1344
1345     } elsif ($dirtree {$path} =~ /^FILE:(.*)$/) {
1346       &create_file ("$basedir/$path", $1 . "\n");
1347
1348     } elsif ($dirtree {$path} =~ /^LINK:(.*)$/) {
1349       symlink ("$basedir/$1", "$basedir/$path")
1350           or &error ("Couldn't symlink $basedir/$path -> $basedir/$1: $!\n", 1);
1351
1352     } else {
1353       &error ("Bogus dirtree type: \"$dirtree{$path}\"\n", 1);
1354     }
1355   }
1356   if ($just_setup_tree) {
1357     die "Tree is setup...\n";
1358   }
1359 }
1360
1361 # compare a directory tree with an associative array in the format used
1362 # by create_dir_tree, above.
1363 # The first argument is the dir under which the structure should be found;
1364 # the second argument is the associative array.
1365
1366 sub compare_dir_tree
1367 {
1368   my ($basedir, %dirtree) = @_;
1369   my $bogus = 0;
1370
1371   opendir (DIR, $basedir) or &error ("Couldn't open $basedir: $!\n", 1);
1372   my @allfiles = grep (!/^(\.\.?|CVS|RCS)$/, readdir (DIR) );
1373   closedir (DIR);
1374   if ($debug) {
1375     print "dirtree: (%dirtree)\n$basedir: (@allfiles)\n";
1376   }
1377
1378   foreach my $path (sort keys (%dirtree))
1379   {
1380     if ($debug) {
1381       print "Checking $path ($dirtree{$path}).\n";
1382     }
1383
1384     my $found = 0;
1385     foreach my $i (0 .. $#allfiles) {
1386       if ($allfiles[$i] eq $path) {
1387         splice (@allfiles, $i, 1);  # delete it
1388         if ($debug) {
1389           print "     Zapped $path; files now (@allfiles).\n";
1390         }
1391         lstat ("$basedir/$path");
1392         $found = 1;
1393         last;
1394       }
1395     }
1396
1397     if (!$found) {
1398       print "compare_dir_tree: $path does not exist.\n";
1399       $bogus = 1;
1400       next;
1401     }
1402
1403     if ($dirtree {$path} =~ /^DIR$/) {
1404       if (-d _ && opendir (DIR, "$basedir/$path") ) {
1405         my @files = readdir (DIR);
1406         closedir (DIR);
1407         @files = grep (!/^(\.\.?|CVS|RCS)$/ && ($_ = "$path/$_"), @files);
1408         push (@allfiles, @files);
1409         if ($debug)
1410         {
1411           print "     Read in $path; new files (@files).\n";
1412         }
1413
1414       } else {
1415         print "compare_dir_tree: $path is not a dir.\n";
1416         $bogus = 1;
1417       }
1418
1419     } elsif ($dirtree {$path} =~ /^FILE:(.*)$/) {
1420       if (-l _ || !-f _) {
1421         print "compare_dir_tree: $path is not a file.\n";
1422         $bogus = 1;
1423         next;
1424       }
1425
1426       if ($1 ne "*") {
1427         my $contents = &read_file_into_string ("$basedir/$path");
1428         if ($contents ne "$1\n") {
1429           print "compare_dir_tree: $path contains wrong stuff."
1430               . "  Is:\n$contentsShould be:\n$1\n";
1431           $bogus = 1;
1432         }
1433       }
1434
1435     } elsif ($dirtree {$path} =~ /^LINK:(.*)$/) {
1436       my $target = $1;
1437       if (!-l _) {
1438         print "compare_dir_tree: $path is not a link.\n";
1439         $bogus = 1;
1440         next;
1441       }
1442
1443       my $contents = readlink ("$basedir/$path");
1444       $contents =~ tr/>/\//;
1445       my $fulltarget = "$basedir/$target";
1446       $fulltarget =~ tr/>/\//;
1447       if (!($contents =~ /$fulltarget$/)) {
1448         if ($debug) {
1449           $target = $fulltarget;
1450         }
1451         print "compare_dir_tree: $path should be link to $target, "
1452             . "not $contents.\n";
1453         $bogus = 1;
1454       }
1455
1456     } else {
1457       &error ("Bogus dirtree type: \"$dirtree{$path}\"\n", 1);
1458     }
1459   }
1460
1461   if ($debug) {
1462     print "leftovers: (@allfiles).\n";
1463   }
1464
1465   foreach my $file (@allfiles) {
1466     print "compare_dir_tree: $file should not exist.\n";
1467     $bogus = 1;
1468   }
1469
1470   return !$bogus;
1471 }
1472
1473 # this subroutine generates the numeric suffix used to keep tmp filenames,
1474 # log filenames, etc., unique.  If the number passed in is 1, then a null
1475 # string is returned; otherwise, we return ".n", where n + 1 is the number
1476 # we were given.
1477
1478 sub num_suffix
1479 {
1480   my ($num) = @_;
1481   if (--$num > 0) {
1482     return "$extext$num";
1483   }
1484
1485   return "";
1486 }
1487
1488 # This subroutine returns a log filename with a number appended to
1489 # the end corresponding to how many logfiles have been created in the
1490 # current running test.  An optional parameter may be passed (0 or 1).
1491 # If a 1 is passed, then it does NOT increment the logfile counter
1492 # and returns the name of the latest logfile.  If either no parameter
1493 # is passed at all or a 0 is passed, then the logfile counter is
1494 # incremented and the new name is returned.
1495
1496 sub get_logfile
1497 {
1498   my ($no_increment) = @_;
1499
1500   $num_of_logfiles += !$no_increment;
1501
1502   return ($log_filename . &num_suffix ($num_of_logfiles));
1503 }
1504
1505 # This subroutine returns a base (answer) filename with a number
1506 # appended to the end corresponding to how many logfiles (and thus
1507 # base files) have been created in the current running test.
1508 # NO PARAMETERS ARE PASSED TO THIS SUBROUTINE.
1509
1510 sub get_basefile
1511 {
1512   return ($base_filename . &num_suffix ($num_of_logfiles));
1513 }
1514
1515 # This subroutine returns a difference filename with a number appended
1516 # to the end corresponding to how many logfiles (and thus diff files)
1517 # have been created in the current running test.
1518
1519 sub get_difffile
1520 {
1521   return ($diff_filename . &num_suffix ($num_of_logfiles));
1522 }
1523
1524 # This subroutine returns a command filename with a number appended
1525 # to the end corresponding to how many logfiles (and thus command files)
1526 # have been created in the current running test.
1527
1528 sub get_runfile
1529 {
1530   return ($run_filename . &num_suffix ($num_of_logfiles));
1531 }
1532
1533 # just like logfile, only a generic tmp filename for use by the test.
1534 # they are automatically cleaned up unless -keep was used, or the test fails.
1535 # Pass an argument of 1 to return the same filename as the previous call.
1536
1537 sub get_tmpfile
1538 {
1539   my ($no_increment) = @_;
1540
1541   $num_of_tmpfiles += !$no_increment;
1542
1543   return ($tmp_filename . &num_suffix ($num_of_tmpfiles));
1544 }
1545
1546 1;