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