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, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   9 # 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
  10 # This file is part of GNU Make.
  11 #
  12 # GNU Make is free software; you can redistribute it and/or modify it under
  13 # the terms of the GNU General Public License as published by the Free Software
  14 # Foundation; either version 3 of the License, or (at your option) any later
  15 # version.
  16 #
  17 # GNU Make is distributed in the hope that it will be useful, but WITHOUT ANY
  18 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  19 # FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  20 # details.
  21 #
  22 # You should have received a copy of the GNU General Public License along with
  23 # this program.  If not, see <http://www.gnu.org/licenses/>.
  24
  25
  26 # Test driver routines used by a number of test suites, including
  27 # those for SCS, make, roll_dir, and scan_deps (?).
  28 #
  29 # this routine controls the whole mess; each test suite sets up a few
  30 # variables and then calls &toplevel, which does all the real work.
  31
  32 # $Id: test_driver.pl,v 1.25 2009/06/10 02:21:13 psmith Exp $
  33
  34
  35 # The number of test categories we've run
  36 $categories_run = 0;
  37 # The number of test categroies that have passed
  38 $categories_passed = 0;
  39 # The total number of individual tests that have been run
  40 $total_tests_run = 0;
  41 # The total number of individual tests that have passed
  42 $total_tests_passed = 0;
  43 # The number of tests in this category that have been run
  44 $tests_run = 0;
  45 # The number of tests in this category that have passed
  46 $tests_passed = 0;
  47
  48
  49 # Yeesh.  This whole test environment is such a hack!
  50 $test_passed = 1;
  51
  52
  53 # Timeout in seconds.  If the test takes longer than this we'll fail it.
  54 $test_timeout = 5;
  55
  56
  57 # %makeENV is the cleaned-out environment.
  58 %makeENV = ();
  59
  60 # %extraENV are any extra environment variables the tests might want to set.
  61 # These are RESET AFTER EVERY TEST!
  62 %extraENV = ();
  63
  64 # %origENV is the caller's original environment
  65 %origENV = %ENV;
  66
  67 sub resetENV
  68 {
  69   # We used to say "%ENV = ();" but this doesn't work in Perl 5.000
  70   # through Perl 5.004.  It was fixed in Perl 5.004_01, but we don't
  71   # want to require that here, so just delete each one individually.
  72   foreach $v (keys %ENV) {
  73     delete $ENV{$v};
  74   }
  75
  76   %ENV = %makeENV;
  77   foreach $v (keys %extraENV) {
  78     $ENV{$v} = $extraENV{$v};
  79     delete $extraENV{$v};
  80   }
  81 }
  82
  83 sub toplevel
  84 {
  85   # Pull in benign variables from the user's environment
  86
  87   foreach (# UNIX-specific things
  88            'TZ', 'TMPDIR', 'HOME', 'USER', 'LOGNAME', 'PATH',
  89            # Purify things
  90            'PURIFYOPTIONS',
  91            # Windows NT-specific stuff
  92            'Path', 'SystemRoot',
  93            # DJGPP-specific stuff
  94            'DJDIR', 'DJGPP', 'SHELL', 'COMSPEC', 'HOSTNAME', 'LFN',
  95            'FNCASE', '387', 'EMU387', 'GROUP'
  96           ) {
  97     $makeENV{$_} = $ENV{$_} if $ENV{$_};
  98   }
  99
 100   # Make sure our compares are not foiled by locale differences
 101
 102   $makeENV{LC_ALL} = 'C';
 103
 104   # Replace the environment with the new one
 105   #
 106   %origENV = %ENV;
 107
 108   resetENV();
 109
 110   $| = 1;                     # unbuffered output
 111
 112   $debug = 0;                 # debug flag
 113   $profile = 0;               # profiling flag
 114   $verbose = 0;               # verbose mode flag
 115   $detail = 0;                # detailed verbosity
 116   $keep = 0;                  # keep temp files around
 117   $workdir = "work";          # The directory where the test will start running
 118   $scriptdir = "scripts";     # The directory where we find the test scripts
 119   $tmpfilesuffix = "t";       # the suffix used on tmpfiles
 120   $default_output_stack_level = 0;  # used by attach_default_output, etc.
 121   $default_input_stack_level = 0;   # used by attach_default_input, etc.
 122   $cwd = ".";                 # don't we wish we knew
 123   $cwdslash = "";             # $cwd . $pathsep, but "" rather than "./"
 124
 125   &get_osname;  # sets $osname, $vos, $pathsep, and $short_filenames
 126
 127   &set_defaults;  # suite-defined
 128
 129   &parse_command_line (@ARGV);
 130
 131   print "OS name = `$osname'\n" if $debug;
 132
 133   $workpath = "$cwdslash$workdir";
 134   $scriptpath = "$cwdslash$scriptdir";
 135
 136   &set_more_defaults;  # suite-defined
 137
 138   &print_banner;
 139
 140   if (-d $workpath)
 141   {
 142     print "Clearing $workpath...\n";
 143     &remove_directory_tree("$workpath/")
 144           || &error ("Couldn't wipe out $workpath\n");
 145   }
 146   else
 147   {
 148     mkdir ($workpath, 0777) || &error ("Couldn't mkdir $workpath: $!\n");
 149   }
 150
 151   if (!-d $scriptpath)
 152   {
 153     &error ("Failed to find $scriptpath containing perl test scripts.\n");
 154   }
 155
 156   if (@TESTS)
 157   {
 158     print "Making work dirs...\n";
 159     foreach $test (@TESTS)
 160     {
 161       if ($test =~ /^([^\/]+)\//)
 162       {
 163         $dir = $1;
 164         push (@rmdirs, $dir);
 165         -d "$workpath/$dir"
 166            || mkdir ("$workpath/$dir", 0777)
 167            || &error ("Couldn't mkdir $workpath/$dir: $!\n");
 168       }
 169     }
 170   }
 171   else
 172   {
 173     print "Finding tests...\n";
 174     opendir (SCRIPTDIR, $scriptpath)
 175         || &error ("Couldn't opendir $scriptpath: $!\n");
 176     @dirs = grep (!/^(\..*|CVS|RCS)$/, readdir (SCRIPTDIR) );
 177     closedir (SCRIPTDIR);
 178     foreach $dir (@dirs)
 179     {
 180       next if ($dir =~ /^(\..*|CVS|RCS)$/ || ! -d "$scriptpath/$dir");
 181       push (@rmdirs, $dir);
 182       mkdir ("$workpath/$dir", 0777)
 183            || &error ("Couldn't mkdir $workpath/$dir: $!\n");
 184       opendir (SCRIPTDIR, "$scriptpath/$dir")
 185           || &error ("Couldn't opendir $scriptpath/$dir: $!\n");
 186       @files = grep (!/^(\..*|CVS|RCS|.*~)$/, readdir (SCRIPTDIR) );
 187       closedir (SCRIPTDIR);
 188       foreach $test (@files)
 189       {
 190         -d $test and next;
 191         push (@TESTS, "$dir/$test");
 192       }
 193     }
 194   }
 195
 196   if (@TESTS == 0)
 197   {
 198     &error ("\nNo tests in $scriptpath, and none were specified.\n");
 199   }
 200
 201   print "\n";
 202
 203   &run_each_test;
 204
 205   foreach $dir (@rmdirs)
 206   {
 207     rmdir ("$workpath/$dir");
 208   }
 209
 210   $| = 1;
 211
 212   $categories_failed = $categories_run - $categories_passed;
 213   $total_tests_failed = $total_tests_run - $total_tests_passed;
 214
 215   if ($total_tests_failed)
 216   {
 217     print "\n$total_tests_failed Test";
 218     print "s" unless $total_tests_failed == 1;
 219     print " in $categories_failed Categor";
 220     print ($categories_failed == 1 ? "y" : "ies");
 221     print " Failed (See .$diffext files in $workdir dir for details) :-(\n\n";
 222     return 0;
 223   }
 224   else
 225   {
 226     print "\n$total_tests_passed Test";
 227     print "s" unless $total_tests_passed == 1;
 228     print " in $categories_passed Categor";
 229     print ($categories_passed == 1 ? "y" : "ies");
 230     print " Complete ... No Failures :-)\n\n";
 231     return 1;
 232   }
 233 }
 234
 235 sub get_osname
 236 {
 237   # Set up an initial value.  In perl5 we can do it the easy way.
 238   #
 239   $osname = defined($^O) ? $^O : '';
 240
 241   # See if the filesystem supports long file names with multiple
 242   # dots.  DOS doesn't.
 243   $short_filenames = 0;
 244   (open (TOUCHFD, "> fancy.file.name") && close (TOUCHFD))
 245       || ($short_filenames = 1);
 246   unlink ("fancy.file.name") || ($short_filenames = 1);
 247
 248   if (! $short_filenames) {
 249     # Thanks go to meyering@cs.utexas.edu (Jim Meyering) for suggesting a
 250     # better way of doing this.  (We used to test for existence of a /mnt
 251     # dir, but that apparently fails on an SGI Indigo (whatever that is).)
 252     # Because perl on VOS translates /'s to >'s, we need to test for
 253     # VOSness rather than testing for Unixness (ie, try > instead of /).
 254
 255     mkdir (".ostest", 0777) || &error ("Couldn't create .ostest: $!\n", 1);
 256     open (TOUCHFD, "> .ostest>ick") && close (TOUCHFD);
 257     chdir (".ostest") || &error ("Couldn't chdir to .ostest: $!\n", 1);
 258   }
 259
 260   if (! $short_filenames && -f "ick")
 261   {
 262     $osname = "vos";
 263     $vos = 1;
 264     $pathsep = ">";
 265   }
 266   else
 267   {
 268     # the following is regrettably knarly, but it seems to be the only way
 269     # to not get ugly error messages if uname can't be found.
 270     # Hmmm, BSD/OS 2.0's uname -a is excessively verbose.  Let's try it
 271     # with switches first.
 272     eval "chop (\$osname = `sh -c 'uname -nmsr 2>&1'`)";
 273     if ($osname =~ /not found/i)
 274     {
 275         $osname = "(something unixy with no uname)";
 276     }
 277     elsif ($@ ne "" || $?)
 278     {
 279         eval "chop (\$osname = `sh -c 'uname -a 2>&1'`)";
 280         if ($@ ne "" || $?)
 281         {
 282             $osname = "(something unixy)";
 283         }
 284     }
 285     $vos = 0;
 286     $pathsep = "/";
 287   }
 288
 289   if (! $short_filenames) {
 290     chdir ("..") || &error ("Couldn't chdir to ..: $!\n", 1);
 291     unlink (".ostest>ick");
 292     rmdir (".ostest") || &error ("Couldn't rmdir .ostest: $!\n", 1);
 293   }
 294 }
 295
 296 sub parse_command_line
 297 {
 298   @argv = @_;
 299
 300   # use @ARGV if no args were passed in
 301
 302   if (@argv == 0)
 303   {
 304     @argv = @ARGV;
 305   }
 306
 307   # look at each option; if we don't recognize it, maybe the suite-specific
 308   # command line parsing code will...
 309
 310   while (@argv)
 311   {
 312     $option = shift @argv;
 313     if ($option =~ /^-debug$/i)
 314     {
 315       print "\nDEBUG ON\n";
 316       $debug = 1;
 317     }
 318     elsif ($option =~ /^-usage$/i)
 319     {
 320       &print_usage;
 321       exit 0;
 322     }
 323     elsif ($option =~ /^-(h|help)$/i)
 324     {
 325       &print_help;
 326       exit 0;
 327     }
 328     elsif ($option =~ /^-profile$/i)
 329     {
 330       $profile = 1;
 331     }
 332     elsif ($option =~ /^-verbose$/i)
 333     {
 334       $verbose = 1;
 335     }
 336     elsif ($option =~ /^-detail$/i)
 337     {
 338       $detail = 1;
 339       $verbose = 1;
 340     }
 341     elsif ($option =~ /^-keep$/i)
 342     {
 343       $keep = 1;
 344     }
 345     elsif (&valid_option($option))
 346     {
 347       # The suite-defined subroutine takes care of the option
 348     }
 349     elsif ($option =~ /^-/)
 350     {
 351       print "Invalid option: $option\n";
 352       &print_usage;
 353       exit 0;
 354     }
 355     else # must be the name of a test
 356     {
 357       $option =~ s/\.pl$//;
 358       push(@TESTS,$option);
 359     }
 360   }
 361 }
 362
 363 sub max
 364 {
 365   local($num) = shift @_;
 366   local($newnum);
 367
 368   while (@_)
 369   {
 370     $newnum = shift @_;
 371     if ($newnum > $num)
 372     {
 373       $num = $newnum;
 374     }
 375   }
 376
 377   return $num;
 378 }
 379
 380 sub print_centered
 381 {
 382   local($width, $string) = @_;
 383   local($pad);
 384
 385   if (length ($string))
 386   {
 387     $pad = " " x ( ($width - length ($string) + 1) / 2);
 388     print "$pad$string";
 389   }
 390 }
 391
 392 sub print_banner
 393 {
 394   local($info);
 395   local($line);
 396   local($len);
 397
 398   $info = "Running tests for $testee on $osname\n";  # $testee is suite-defined
 399   $len = &max (length ($line), length ($testee_version),
 400                length ($banner_info), 73) + 5;
 401   $line = ("-" x $len) . "\n";
 402   if ($len < 78)
 403   {
 404     $len = 78;
 405   }
 406
 407   &print_centered ($len, $line);
 408   &print_centered ($len, $info);
 409   &print_centered ($len, $testee_version);  # suite-defined
 410   &print_centered ($len, $banner_info);     # suite-defined
 411   &print_centered ($len, $line);
 412   print "\n";
 413 }
 414
 415 sub run_each_test
 416 {
 417   $categories_run = 0;
 418
 419   foreach $testname (sort @TESTS)
 420   {
 421     ++$categories_run;
 422     $suite_passed = 1;       # reset by test on failure
 423     $num_of_logfiles = 0;
 424     $num_of_tmpfiles = 0;
 425     $description = "";
 426     $details = "";
 427     $old_makefile = undef;
 428     $testname =~ s/^$scriptpath$pathsep//;
 429     $perl_testname = "$scriptpath$pathsep$testname";
 430     $testname =~ s/(\.pl|\.perl)$//;
 431     $testpath = "$workpath$pathsep$testname";
 432     # Leave enough space in the extensions to append a number, even
 433     # though it needs to fit into 8+3 limits.
 434     if ($short_filenames) {
 435       $logext = 'l';
 436       $diffext = 'd';
 437       $baseext = 'b';
 438       $runext = 'r';
 439       $extext = '';
 440     } else {
 441       $logext = 'log';
 442       $diffext = 'diff';
 443       $baseext = 'base';
 444       $runext = 'run';
 445       $extext = '.';
 446     }
 447     $log_filename = "$testpath.$logext";
 448     $diff_filename = "$testpath.$diffext";
 449     $base_filename = "$testpath.$baseext";
 450     $run_filename = "$testpath.$runext";
 451     $tmp_filename = "$testpath.$tmpfilesuffix";
 452
 453     &setup_for_test;          # suite-defined
 454
 455     $output = "........................................................ ";
 456
 457     substr($output,0,length($testname)) = "$testname ";
 458
 459     print $output;
 460
 461     # Run the actual test!
 462     $tests_run = 0;
 463     $tests_passed = 0;
 464     $code = do $perl_testname;
 465
 466     $total_tests_run += $tests_run;
 467     $total_tests_passed += $tests_passed;
 468
 469     # How did it go?
 470     if (!defined($code))
 471     {
 472       $suite_passed = 0;
 473       if (length ($@)) {
 474         warn "\n*** Test died ($testname): $@\n";
 475       } else {
 476         warn "\n*** Couldn't run $perl_testname\n";
 477       }
 478     }
 479     elsif ($code == -1) {
 480       $suite_passed = 0;
 481     }
 482     elsif ($code != 1 && $code != -1) {
 483       $suite_passed = 0;
 484       warn "\n*** Test returned $code\n";
 485     }
 486
 487     if ($suite_passed) {
 488       ++$categories_passed;
 489       $status = "ok     ($tests_passed passed)";
 490       for ($i = $num_of_tmpfiles; $i; $i--)
 491       {
 492         &rmfiles ($tmp_filename . &num_suffix ($i) );
 493       }
 494
 495       for ($i = $num_of_logfiles ? $num_of_logfiles : 1; $i; $i--)
 496       {
 497         &rmfiles ($log_filename . &num_suffix ($i) );
 498         &rmfiles ($base_filename . &num_suffix ($i) );
 499       }
 500     }
 501     elsif (!defined $code || $code > 0) {
 502       $status = "FAILED ($tests_passed/$tests_run passed)";
 503     }
 504     elsif ($code < 0) {
 505       $status = "N/A";
 506       --$categories_run;
 507     }
 508
 509     # If the verbose option has been specified, then a short description
 510     # of each test is printed before displaying the results of each test
 511     # describing WHAT is being tested.
 512
 513     if ($verbose)
 514     {
 515       if ($detail)
 516       {
 517         print "\nWHAT IS BEING TESTED\n";
 518         print "--------------------";
 519       }
 520       print "\n\n$description\n\n";
 521     }
 522
 523     # If the detail option has been specified, then the details of HOW
 524     # the test is testing what it says it is testing in the verbose output
 525     # will be displayed here before the results of the test are displayed.
 526
 527     if ($detail)
 528     {
 529       print "\nHOW IT IS TESTED\n";
 530       print "----------------";
 531       print "\n\n$details\n\n";
 532     }
 533
 534     print "$status\n";
 535   }
 536 }
 537
 538 # If the keep flag is not set, this subroutine deletes all filenames that
 539 # are sent to it.
 540
 541 sub rmfiles
 542 {
 543   local(@files) = @_;
 544
 545   if (!$keep)
 546   {
 547     return (unlink @files);
 548   }
 549
 550   return 1;
 551 }
 552
 553 sub print_standard_usage
 554 {
 555   local($plname,@moreusage) = @_;
 556   local($line);
 557
 558   print "usage:\t$plname [testname] [-verbose] [-detail] [-keep]\n";
 559   print "\t\t\t[-profile] [-usage] [-help] [-debug]\n";
 560   foreach (@moreusage) {
 561     print "\t\t\t$_\n";
 562   }
 563 }
 564
 565 sub print_standard_help
 566 {
 567   local(@morehelp) = @_;
 568   local($line);
 569   local($tline);
 570   local($t) = "      ";
 571
 572   $line = "Test Driver For $testee";
 573   print "$line\n";
 574   $line = "=" x length ($line);
 575   print "$line\n";
 576
 577   &print_usage;
 578
 579   print "\ntestname\n"
 580       . "${t}You may, if you wish, run only ONE test if you know the name\n"
 581       . "${t}of that test and specify this name anywhere on the command\n"
 582       . "${t}line.  Otherwise ALL existing tests in the scripts directory\n"
 583       . "${t}will be run.\n"
 584       . "-verbose\n"
 585       . "${t}If this option is given, a description of every test is\n"
 586       . "${t}displayed before the test is run. (Not all tests may have\n"
 587       . "${t}descriptions at this time)\n"
 588       . "-detail\n"
 589       . "${t}If this option is given, a detailed description of every\n"
 590       . "${t}test is displayed before the test is run. (Not all tests\n"
 591       . "${t}have descriptions at this time)\n"
 592       . "-profile\n"
 593       . "${t}If this option is given, then the profile file\n"
 594       . "${t}is added to other profiles every time $testee is run.\n"
 595       . "${t}This option only works on VOS at this time.\n"
 596       . "-keep\n"
 597       . "${t}You may give this option if you DO NOT want ANY\n"
 598       . "${t}of the files generated by the tests to be deleted. \n"
 599       . "${t}Without this option, all files generated by the test will\n"
 600       . "${t}be deleted IF THE TEST PASSES.\n"
 601       . "-debug\n"
 602       . "${t}Use this option if you would like to see all of the system\n"
 603       . "${t}calls issued and their return status while running the tests\n"
 604       . "${t}This can be helpful if you're having a problem adding a test\n"
 605       . "${t}to the suite, or if the test fails!\n";
 606
 607   foreach $line (@morehelp)
 608   {
 609     $tline = $line;
 610     if (substr ($tline, 0, 1) eq "\t")
 611     {
 612       substr ($tline, 0, 1) = $t;
 613     }
 614     print "$tline\n";
 615   }
 616 }
 617
 618 #######################################################################
 619 ###########         Generic Test Driver Subroutines         ###########
 620 #######################################################################
 621
 622 sub get_caller
 623 {
 624   local($depth);
 625   local($package);
 626   local($filename);
 627   local($linenum);
 628
 629   $depth = defined ($_[0]) ? $_[0] : 1;
 630   ($package, $filename, $linenum) = caller ($depth + 1);
 631   return "$filename: $linenum";
 632 }
 633
 634 sub error
 635 {
 636   local($message) = $_[0];
 637   local($caller) = &get_caller (1);
 638
 639   if (defined ($_[1]))
 640   {
 641     $caller = &get_caller ($_[1] + 1) . " -> $caller";
 642   }
 643
 644   die "$caller: $message";
 645 }
 646
 647 sub compare_output
 648 {
 649   local($answer,$logfile) = @_;
 650   local($slurp, $answer_matched) = ('', 0);
 651
 652   print "Comparing Output ........ " if $debug;
 653
 654   $slurp = &read_file_into_string ($logfile);
 655
 656   # For make, get rid of any time skew error before comparing--too bad this
 657   # has to go into the "generic" driver code :-/
 658   $slurp =~ s/^.*modification time .*in the future.*\n//gm;
 659   $slurp =~ s/^.*Clock skew detected.*\n//gm;
 660
 661   ++$tests_run;
 662
 663   if ($slurp eq $answer) {
 664     $answer_matched = 1;
 665   } else {
 666     # See if it is a slash or CRLF problem
 667     local ($answer_mod, $slurp_mod) = ($answer, $slurp);
 668
 669     $answer_mod =~ tr,\\,/,;
 670     $answer_mod =~ s,\r\n,\n,gs;
 671
 672     $slurp_mod =~ tr,\\,/,;
 673     $slurp_mod =~ s,\r\n,\n,gs;
 674
 675     $answer_matched = ($slurp_mod eq $answer_mod);
 676
 677     # If it still doesn't match, see if the answer might be a regex.
 678     if (!$answer_matched && $answer =~ m,^/(.+)/$,) {
 679       $answer_matched = ($slurp =~ /$1/);
 680       if (!$answer_matched && $answer_mod =~ m,^/(.+)/$,) {
 681           $answer_matched = ($slurp_mod =~ /$1/);
 682       }
 683     }
 684   }
 685
 686   if ($answer_matched && $test_passed)
 687   {
 688     print "ok\n" if $debug;
 689     ++$tests_passed;
 690     return 1;
 691   }
 692
 693   if (! $answer_matched) {
 694     print "DIFFERENT OUTPUT\n" if $debug;
 695
 696     &create_file (&get_basefile, $answer);
 697     &create_file (&get_runfile, $command_string);
 698
 699     print "\nCreating Difference File ...\n" if $debug;
 700
 701     # Create the difference file
 702
 703     local($command) = "diff -c " . &get_basefile . " " . $logfile;
 704     &run_command_with_output(&get_difffile,$command);
 705   } else {
 706       &rmfiles ();
 707   }
 708
 709   $suite_passed = 0;
 710   return 0;
 711 }
 712
 713 sub read_file_into_string
 714 {
 715   local($filename) = @_;
 716   local($oldslash) = $/;
 717
 718   undef $/;
 719
 720   open (RFISFILE, $filename) || return "";
 721   local ($slurp) = <RFISFILE>;
 722   close (RFISFILE);
 723
 724   $/ = $oldslash;
 725
 726   return $slurp;
 727 }
 728
 729 sub attach_default_output
 730 {
 731   local ($filename) = @_;
 732   local ($code);
 733
 734   if ($vos)
 735   {
 736     $code = system "++attach_default_output_hack $filename";
 737     $code == -2 || &error ("adoh death\n", 1);
 738     return 1;
 739   }
 740
 741   open ("SAVEDOS" . $default_output_stack_level . "out", ">&STDOUT")
 742         || &error ("ado: $! duping STDOUT\n", 1);
 743   open ("SAVEDOS" . $default_output_stack_level . "err", ">&STDERR")
 744         || &error ("ado: $! duping STDERR\n", 1);
 745
 746   open (STDOUT, "> " . $filename)
 747         || &error ("ado: $filename: $!\n", 1);
 748   open (STDERR, ">&STDOUT")
 749         || &error ("ado: $filename: $!\n", 1);
 750
 751   $default_output_stack_level++;
 752 }
 753
 754 # close the current stdout/stderr, and restore the previous ones from
 755 # the "stack."
 756
 757 sub detach_default_output
 758 {
 759   local ($code);
 760
 761   if ($vos)
 762   {
 763     $code = system "++detach_default_output_hack";
 764     $code == -2 || &error ("ddoh death\n", 1);
 765     return 1;
 766   }
 767
 768   if (--$default_output_stack_level < 0)
 769   {
 770     &error ("default output stack has flown under!\n", 1);
 771   }
 772
 773   close (STDOUT);
 774   close (STDERR);
 775
 776   open (STDOUT, ">&SAVEDOS" . $default_output_stack_level . "out")
 777         || &error ("ddo: $! duping STDOUT\n", 1);
 778   open (STDERR, ">&SAVEDOS" . $default_output_stack_level . "err")
 779         || &error ("ddo: $! duping STDERR\n", 1);
 780
 781   close ("SAVEDOS" . $default_output_stack_level . "out")
 782         || &error ("ddo: $! closing SCSDOSout\n", 1);
 783   close ("SAVEDOS" . $default_output_stack_level . "err")
 784          || &error ("ddo: $! closing SAVEDOSerr\n", 1);
 785 }
 786
 787 # This runs a command without any debugging info.
 788 sub _run_command
 789 {
 790   my $code;
 791
 792   # We reset this before every invocation.  On Windows I think there is only
 793   # one environment, not one per process, so I think that variables set in
 794   # test scripts might leak into subsequent tests if this isn't reset--???
 795   resetENV();
 796
 797   eval {
 798       local $SIG{ALRM} = sub { die "timeout\n"; };
 799       alarm $test_timeout;
 800       $code = system @_;
 801       alarm 0;
 802   };
 803   if ($@) {
 804       # The eval failed.  If it wasn't SIGALRM then die.
 805       $@ eq "timeout\n" or die;
 806
 807       # Timed out.  Resend the alarm to our process group to kill the children.
 808       $SIG{ALRM} = 'IGNORE';
 809       kill -14, $$;
 810       $code = 14;
 811   }
 812
 813   return $code;
 814 }
 815
 816 # run one command (passed as a list of arg 0 - n), returning 0 on success
 817 # and nonzero on failure.
 818
 819 sub run_command
 820 {
 821   print "\nrun_command: @_\n" if $debug;
 822   my $code = _run_command(@_);
 823   print "run_command returned $code.\n" if $debug;
 824
 825   return $code;
 826 }
 827
 828 # run one command (passed as a list of arg 0 - n, with arg 0 being the
 829 # second arg to this routine), returning 0 on success and non-zero on failure.
 830 # The first arg to this routine is a filename to connect to the stdout
 831 # & stderr of the child process.
 832
 833 sub run_command_with_output
 834 {
 835   my $filename = shift;
 836
 837   print "\nrun_command_with_output($filename,$runname): @_\n" if $debug;
 838   &attach_default_output ($filename);
 839   my $code = _run_command(@_);
 840   &detach_default_output;
 841   print "run_command_with_output returned $code.\n" if $debug;
 842
 843   return $code;
 844 }
 845
 846 # performs the equivalent of an "rm -rf" on the first argument.  Like
 847 # rm, if the path ends in /, leaves the (now empty) directory; otherwise
 848 # deletes it, too.
 849
 850 sub remove_directory_tree
 851 {
 852   local ($targetdir) = @_;
 853   local ($nuketop) = 1;
 854   local ($ch);
 855
 856   $ch = substr ($targetdir, length ($targetdir) - 1);
 857   if ($ch eq "/" || $ch eq $pathsep)
 858   {
 859     $targetdir = substr ($targetdir, 0, length ($targetdir) - 1);
 860     $nuketop = 0;
 861   }
 862
 863   if (! -e $targetdir)
 864   {
 865     return 1;
 866   }
 867
 868   &remove_directory_tree_inner ("RDT00", $targetdir) || return 0;
 869   if ($nuketop)
 870   {
 871     rmdir $targetdir || return 0;
 872   }
 873
 874   return 1;
 875 }
 876
 877 sub remove_directory_tree_inner
 878 {
 879   local ($dirhandle, $targetdir) = @_;
 880   local ($object);
 881   local ($subdirhandle);
 882
 883   opendir ($dirhandle, $targetdir) || return 0;
 884   $subdirhandle = $dirhandle;
 885   $subdirhandle++;
 886   while ($object = readdir ($dirhandle))
 887   {
 888     if ($object =~ /^(\.\.?|CVS|RCS)$/)
 889     {
 890       next;
 891     }
 892
 893     $object = "$targetdir$pathsep$object";
 894     lstat ($object);
 895
 896     if (-d _ && &remove_directory_tree_inner ($subdirhandle, $object))
 897     {
 898       rmdir $object || return 0;
 899     }
 900     else
 901     {
 902       unlink $object || return 0;
 903     }
 904   }
 905   closedir ($dirhandle);
 906   return 1;
 907 }
 908
 909 # We used to use this behavior for this function:
 910 #
 911 #sub touch
 912 #{
 913 #  local (@filenames) = @_;
 914 #  local ($now) = time;
 915 #  local ($file);
 916 #
 917 #  foreach $file (@filenames)
 918 #  {
 919 #    utime ($now, $now, $file)
 920 #          || (open (TOUCHFD, ">> $file") && close (TOUCHFD))
 921 #               || &error ("Couldn't touch $file: $!\n", 1);
 922 #  }
 923 #  return 1;
 924 #}
 925 #
 926 # But this behaves badly on networked filesystems where the time is
 927 # skewed, because it sets the time of the file based on the _local_
 928 # host.  Normally when you modify a file, it's the _remote_ host that
 929 # determines the modtime, based on _its_ clock.  So, instead, now we open
 930 # the file and write something into it to force the remote host to set
 931 # the modtime correctly according to its clock.
 932 #
 933
 934 sub touch
 935 {
 936   local ($file);
 937
 938   foreach $file (@_) {
 939     (open(T, ">> $file") && print(T "\n") && close(T))
 940         || &error("Couldn't touch $file: $!\n", 1);
 941   }
 942 }
 943
 944 # Touch with a time offset.  To DTRT, call touch() then use stat() to get the
 945 # access/mod time for each file and apply the offset.
 946
 947 sub utouch
 948 {
 949   local ($off) = shift;
 950   local ($file);
 951
 952   &touch(@_);
 953
 954   local (@s) = stat($_[0]);
 955
 956   utime($s[8]+$off, $s[9]+$off, @_);
 957 }
 958
 959 # open a file, write some stuff to it, and close it.
 960
 961 sub create_file
 962 {
 963   local ($filename, @lines) = @_;
 964
 965   open (CF, "> $filename") || &error ("Couldn't open $filename: $!\n", 1);
 966   foreach $line (@lines)
 967   {
 968     print CF $line;
 969   }
 970   close (CF);
 971 }
 972
 973 # create a directory tree described by an associative array, wherein each
 974 # key is a relative pathname (using slashes) and its associated value is
 975 # one of:
 976 #    DIR            indicates a directory
 977 #    FILE:contents  indicates a file, which should contain contents +\n
 978 #    LINK:target    indicates a symlink, pointing to $basedir/target
 979 # The first argument is the dir under which the structure will be created
 980 # (the dir will be made and/or cleaned if necessary); the second argument
 981 # is the associative array.
 982
 983 sub create_dir_tree
 984 {
 985   local ($basedir, %dirtree) = @_;
 986   local ($path);
 987
 988   &remove_directory_tree ("$basedir");
 989   mkdir ($basedir, 0777) || &error ("Couldn't mkdir $basedir: $!\n", 1);
 990
 991   foreach $path (sort keys (%dirtree))
 992   {
 993     if ($dirtree {$path} =~ /^DIR$/)
 994     {
 995       mkdir ("$basedir/$path", 0777)
 996                || &error ("Couldn't mkdir $basedir/$path: $!\n", 1);
 997     }
 998     elsif ($dirtree {$path} =~ /^FILE:(.*)$/)
 999     {
1000       &create_file ("$basedir/$path", $1 . "\n");
1001     }
1002     elsif ($dirtree {$path} =~ /^LINK:(.*)$/)
1003     {
1004       symlink ("$basedir/$1", "$basedir/$path")
1005         || &error ("Couldn't symlink $basedir/$path -> $basedir/$1: $!\n", 1);
1006     }
1007     else
1008     {
1009       &error ("Bogus dirtree type: \"$dirtree{$path}\"\n", 1);
1010     }
1011   }
1012   if ($just_setup_tree)
1013   {
1014     die "Tree is setup...\n";
1015   }
1016 }
1017
1018 # compare a directory tree with an associative array in the format used
1019 # by create_dir_tree, above.
1020 # The first argument is the dir under which the structure should be found;
1021 # the second argument is the associative array.
1022
1023 sub compare_dir_tree
1024 {
1025   local ($basedir, %dirtree) = @_;
1026   local ($path);
1027   local ($i);
1028   local ($bogus) = 0;
1029   local ($contents);
1030   local ($target);
1031   local ($fulltarget);
1032   local ($found);
1033   local (@files);
1034   local (@allfiles);
1035
1036   opendir (DIR, $basedir) || &error ("Couldn't open $basedir: $!\n", 1);
1037   @allfiles = grep (!/^(\.\.?|CVS|RCS)$/, readdir (DIR) );
1038   closedir (DIR);
1039   if ($debug)
1040   {
1041     print "dirtree: (%dirtree)\n$basedir: (@allfiles)\n";
1042   }
1043
1044   foreach $path (sort keys (%dirtree))
1045   {
1046     if ($debug)
1047     {
1048       print "Checking $path ($dirtree{$path}).\n";
1049     }
1050
1051     $found = 0;
1052     foreach $i (0 .. $#allfiles)
1053     {
1054       if ($allfiles[$i] eq $path)
1055       {
1056         splice (@allfiles, $i, 1);  # delete it
1057         if ($debug)
1058         {
1059           print "     Zapped $path; files now (@allfiles).\n";
1060         }
1061         lstat ("$basedir/$path");
1062         $found = 1;
1063         last;
1064       }
1065     }
1066
1067     if (!$found)
1068     {
1069       print "compare_dir_tree: $path does not exist.\n";
1070       $bogus = 1;
1071       next;
1072     }
1073
1074     if ($dirtree {$path} =~ /^DIR$/)
1075     {
1076       if (-d _ && opendir (DIR, "$basedir/$path") )
1077       {
1078         @files = readdir (DIR);
1079         closedir (DIR);
1080         @files = grep (!/^(\.\.?|CVS|RCS)$/ && ($_ = "$path/$_"), @files);
1081         push (@allfiles, @files);
1082         if ($debug)
1083         {
1084           print "     Read in $path; new files (@files).\n";
1085         }
1086       }
1087       else
1088       {
1089         print "compare_dir_tree: $path is not a dir.\n";
1090         $bogus = 1;
1091       }
1092     }
1093     elsif ($dirtree {$path} =~ /^FILE:(.*)$/)
1094     {
1095       if (-l _ || !-f _)
1096       {
1097         print "compare_dir_tree: $path is not a file.\n";
1098         $bogus = 1;
1099         next;
1100       }
1101
1102       if ($1 ne "*")
1103       {
1104         $contents = &read_file_into_string ("$basedir/$path");
1105         if ($contents ne "$1\n")
1106         {
1107           print "compare_dir_tree: $path contains wrong stuff."
1108               . "  Is:\n$contentsShould be:\n$1\n";
1109           $bogus = 1;
1110         }
1111       }
1112     }
1113     elsif ($dirtree {$path} =~ /^LINK:(.*)$/)
1114     {
1115       $target = $1;
1116       if (!-l _)
1117       {
1118         print "compare_dir_tree: $path is not a link.\n";
1119         $bogus = 1;
1120         next;
1121       }
1122
1123       $contents = readlink ("$basedir/$path");
1124       $contents =~ tr/>/\//;
1125       $fulltarget = "$basedir/$target";
1126       $fulltarget =~ tr/>/\//;
1127       if (!($contents =~ /$fulltarget$/))
1128       {
1129         if ($debug)
1130         {
1131           $target = $fulltarget;
1132         }
1133         print "compare_dir_tree: $path should be link to $target, "
1134             . "not $contents.\n";
1135         $bogus = 1;
1136       }
1137     }
1138     else
1139     {
1140       &error ("Bogus dirtree type: \"$dirtree{$path}\"\n", 1);
1141     }
1142   }
1143
1144   if ($debug)
1145   {
1146     print "leftovers: (@allfiles).\n";
1147   }
1148
1149   foreach $file (@allfiles)
1150   {
1151     print "compare_dir_tree: $file should not exist.\n";
1152     $bogus = 1;
1153   }
1154
1155   return !$bogus;
1156 }
1157
1158 # this subroutine generates the numeric suffix used to keep tmp filenames,
1159 # log filenames, etc., unique.  If the number passed in is 1, then a null
1160 # string is returned; otherwise, we return ".n", where n + 1 is the number
1161 # we were given.
1162
1163 sub num_suffix
1164 {
1165   local($num) = @_;
1166
1167   if (--$num > 0) {
1168     return "$extext$num";
1169   }
1170
1171   return "";
1172 }
1173
1174 # This subroutine returns a log filename with a number appended to
1175 # the end corresponding to how many logfiles have been created in the
1176 # current running test.  An optional parameter may be passed (0 or 1).
1177 # If a 1 is passed, then it does NOT increment the logfile counter
1178 # and returns the name of the latest logfile.  If either no parameter
1179 # is passed at all or a 0 is passed, then the logfile counter is
1180 # incremented and the new name is returned.
1181
1182 sub get_logfile
1183 {
1184   local($no_increment) = @_;
1185
1186   $num_of_logfiles += !$no_increment;
1187
1188   return ($log_filename . &num_suffix ($num_of_logfiles));
1189 }
1190
1191 # This subroutine returns a base (answer) filename with a number
1192 # appended to the end corresponding to how many logfiles (and thus
1193 # base files) have been created in the current running test.
1194 # NO PARAMETERS ARE PASSED TO THIS SUBROUTINE.
1195
1196 sub get_basefile
1197 {
1198   return ($base_filename . &num_suffix ($num_of_logfiles));
1199 }
1200
1201 # This subroutine returns a difference filename with a number appended
1202 # to the end corresponding to how many logfiles (and thus diff files)
1203 # have been created in the current running test.
1204
1205 sub get_difffile
1206 {
1207   return ($diff_filename . &num_suffix ($num_of_logfiles));
1208 }
1209
1210 # This subroutine returns a command filename with a number appended
1211 # to the end corresponding to how many logfiles (and thus command files)
1212 # have been created in the current running test.
1213
1214 sub get_runfile
1215 {
1216   return ($run_filename . &num_suffix ($num_of_logfiles));
1217 }
1218
1219 # just like logfile, only a generic tmp filename for use by the test.
1220 # they are automatically cleaned up unless -keep was used, or the test fails.
1221 # Pass an argument of 1 to return the same filename as the previous call.
1222
1223 sub get_tmpfile
1224 {
1225   local($no_increment) = @_;
1226
1227   $num_of_tmpfiles += !$no_increment;
1228
1229   return ($tmp_filename . &num_suffix ($num_of_tmpfiles));
1230 }
1231
1232 1;