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.26 2009/09/28 23:08:50 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
 465     $code = do $perl_testname;
 466
 467     $total_tests_run += $tests_run;
 468     $total_tests_passed += $tests_passed;
 469
 470     # How did it go?
 471     if (!defined($code))
 472     {
 473       $suite_passed = 0;
 474       if (length ($@)) {
 475         warn "\n*** Test died ($testname): $@\n";
 476       } else {
 477         warn "\n*** Couldn't run $perl_testname\n";
 478       }
 479     }
 480     elsif ($code == -1) {
 481       $suite_passed = 0;
 482     }
 483     elsif ($code != 1 && $code != -1) {
 484       $suite_passed = 0;
 485       warn "\n*** Test returned $code\n";
 486     }
 487
 488     if ($suite_passed) {
 489       ++$categories_passed;
 490       $status = "ok     ($tests_passed passed)";
 491       for ($i = $num_of_tmpfiles; $i; $i--)
 492       {
 493         &rmfiles ($tmp_filename . &num_suffix ($i) );
 494       }
 495
 496       for ($i = $num_of_logfiles ? $num_of_logfiles : 1; $i; $i--)
 497       {
 498         &rmfiles ($log_filename . &num_suffix ($i) );
 499         &rmfiles ($base_filename . &num_suffix ($i) );
 500       }
 501     }
 502     elsif (!defined $code || $code > 0) {
 503       $status = "FAILED ($tests_passed/$tests_run passed)";
 504     }
 505     elsif ($code < 0) {
 506       $status = "N/A";
 507       --$categories_run;
 508     }
 509
 510     # If the verbose option has been specified, then a short description
 511     # of each test is printed before displaying the results of each test
 512     # describing WHAT is being tested.
 513
 514     if ($verbose)
 515     {
 516       if ($detail)
 517       {
 518         print "\nWHAT IS BEING TESTED\n";
 519         print "--------------------";
 520       }
 521       print "\n\n$description\n\n";
 522     }
 523
 524     # If the detail option has been specified, then the details of HOW
 525     # the test is testing what it says it is testing in the verbose output
 526     # will be displayed here before the results of the test are displayed.
 527
 528     if ($detail)
 529     {
 530       print "\nHOW IT IS TESTED\n";
 531       print "----------------";
 532       print "\n\n$details\n\n";
 533     }
 534
 535     print "$status\n";
 536   }
 537 }
 538
 539 # If the keep flag is not set, this subroutine deletes all filenames that
 540 # are sent to it.
 541
 542 sub rmfiles
 543 {
 544   local(@files) = @_;
 545
 546   if (!$keep)
 547   {
 548     return (unlink @files);
 549   }
 550
 551   return 1;
 552 }
 553
 554 sub print_standard_usage
 555 {
 556   local($plname,@moreusage) = @_;
 557   local($line);
 558
 559   print "usage:\t$plname [testname] [-verbose] [-detail] [-keep]\n";
 560   print "\t\t\t[-profile] [-usage] [-help] [-debug]\n";
 561   foreach (@moreusage) {
 562     print "\t\t\t$_\n";
 563   }
 564 }
 565
 566 sub print_standard_help
 567 {
 568   local(@morehelp) = @_;
 569   local($line);
 570   local($tline);
 571   local($t) = "      ";
 572
 573   $line = "Test Driver For $testee";
 574   print "$line\n";
 575   $line = "=" x length ($line);
 576   print "$line\n";
 577
 578   &print_usage;
 579
 580   print "\ntestname\n"
 581       . "${t}You may, if you wish, run only ONE test if you know the name\n"
 582       . "${t}of that test and specify this name anywhere on the command\n"
 583       . "${t}line.  Otherwise ALL existing tests in the scripts directory\n"
 584       . "${t}will be run.\n"
 585       . "-verbose\n"
 586       . "${t}If this option is given, a description of every test is\n"
 587       . "${t}displayed before the test is run. (Not all tests may have\n"
 588       . "${t}descriptions at this time)\n"
 589       . "-detail\n"
 590       . "${t}If this option is given, a detailed description of every\n"
 591       . "${t}test is displayed before the test is run. (Not all tests\n"
 592       . "${t}have descriptions at this time)\n"
 593       . "-profile\n"
 594       . "${t}If this option is given, then the profile file\n"
 595       . "${t}is added to other profiles every time $testee is run.\n"
 596       . "${t}This option only works on VOS at this time.\n"
 597       . "-keep\n"
 598       . "${t}You may give this option if you DO NOT want ANY\n"
 599       . "${t}of the files generated by the tests to be deleted. \n"
 600       . "${t}Without this option, all files generated by the test will\n"
 601       . "${t}be deleted IF THE TEST PASSES.\n"
 602       . "-debug\n"
 603       . "${t}Use this option if you would like to see all of the system\n"
 604       . "${t}calls issued and their return status while running the tests\n"
 605       . "${t}This can be helpful if you're having a problem adding a test\n"
 606       . "${t}to the suite, or if the test fails!\n";
 607
 608   foreach $line (@morehelp)
 609   {
 610     $tline = $line;
 611     if (substr ($tline, 0, 1) eq "\t")
 612     {
 613       substr ($tline, 0, 1) = $t;
 614     }
 615     print "$tline\n";
 616   }
 617 }
 618
 619 #######################################################################
 620 ###########         Generic Test Driver Subroutines         ###########
 621 #######################################################################
 622
 623 sub get_caller
 624 {
 625   local($depth);
 626   local($package);
 627   local($filename);
 628   local($linenum);
 629
 630   $depth = defined ($_[0]) ? $_[0] : 1;
 631   ($package, $filename, $linenum) = caller ($depth + 1);
 632   return "$filename: $linenum";
 633 }
 634
 635 sub error
 636 {
 637   local($message) = $_[0];
 638   local($caller) = &get_caller (1);
 639
 640   if (defined ($_[1]))
 641   {
 642     $caller = &get_caller ($_[1] + 1) . " -> $caller";
 643   }
 644
 645   die "$caller: $message";
 646 }
 647
 648 sub compare_output
 649 {
 650   local($answer,$logfile) = @_;
 651   local($slurp, $answer_matched) = ('', 0);
 652
 653   print "Comparing Output ........ " if $debug;
 654
 655   $slurp = &read_file_into_string ($logfile);
 656
 657   # For make, get rid of any time skew error before comparing--too bad this
 658   # has to go into the "generic" driver code :-/
 659   $slurp =~ s/^.*modification time .*in the future.*\n//gm;
 660   $slurp =~ s/^.*Clock skew detected.*\n//gm;
 661
 662   ++$tests_run;
 663
 664   if ($slurp eq $answer) {
 665     $answer_matched = 1;
 666   } else {
 667     # See if it is a slash or CRLF problem
 668     local ($answer_mod, $slurp_mod) = ($answer, $slurp);
 669
 670     $answer_mod =~ tr,\\,/,;
 671     $answer_mod =~ s,\r\n,\n,gs;
 672
 673     $slurp_mod =~ tr,\\,/,;
 674     $slurp_mod =~ s,\r\n,\n,gs;
 675
 676     $answer_matched = ($slurp_mod eq $answer_mod);
 677
 678     # If it still doesn't match, see if the answer might be a regex.
 679     if (!$answer_matched && $answer =~ m,^/(.+)/$,) {
 680       $answer_matched = ($slurp =~ /$1/);
 681       if (!$answer_matched && $answer_mod =~ m,^/(.+)/$,) {
 682           $answer_matched = ($slurp_mod =~ /$1/);
 683       }
 684     }
 685   }
 686
 687   if ($answer_matched && $test_passed)
 688   {
 689     print "ok\n" if $debug;
 690     ++$tests_passed;
 691     return 1;
 692   }
 693
 694   if (! $answer_matched) {
 695     print "DIFFERENT OUTPUT\n" if $debug;
 696
 697     &create_file (&get_basefile, $answer);
 698     &create_file (&get_runfile, $command_string);
 699
 700     print "\nCreating Difference File ...\n" if $debug;
 701
 702     # Create the difference file
 703
 704     local($command) = "diff -c " . &get_basefile . " " . $logfile;
 705     &run_command_with_output(&get_difffile,$command);
 706   } else {
 707       &rmfiles ();
 708   }
 709
 710   $suite_passed = 0;
 711   return 0;
 712 }
 713
 714 sub read_file_into_string
 715 {
 716   local($filename) = @_;
 717   local($oldslash) = $/;
 718
 719   undef $/;
 720
 721   open (RFISFILE, $filename) || return "";
 722   local ($slurp) = <RFISFILE>;
 723   close (RFISFILE);
 724
 725   $/ = $oldslash;
 726
 727   return $slurp;
 728 }
 729
 730 sub attach_default_output
 731 {
 732   local ($filename) = @_;
 733   local ($code);
 734
 735   if ($vos)
 736   {
 737     $code = system "++attach_default_output_hack $filename";
 738     $code == -2 || &error ("adoh death\n", 1);
 739     return 1;
 740   }
 741
 742   open ("SAVEDOS" . $default_output_stack_level . "out", ">&STDOUT")
 743         || &error ("ado: $! duping STDOUT\n", 1);
 744   open ("SAVEDOS" . $default_output_stack_level . "err", ">&STDERR")
 745         || &error ("ado: $! duping STDERR\n", 1);
 746
 747   open (STDOUT, "> " . $filename)
 748         || &error ("ado: $filename: $!\n", 1);
 749   open (STDERR, ">&STDOUT")
 750         || &error ("ado: $filename: $!\n", 1);
 751
 752   $default_output_stack_level++;
 753 }
 754
 755 # close the current stdout/stderr, and restore the previous ones from
 756 # the "stack."
 757
 758 sub detach_default_output
 759 {
 760   local ($code);
 761
 762   if ($vos)
 763   {
 764     $code = system "++detach_default_output_hack";
 765     $code == -2 || &error ("ddoh death\n", 1);
 766     return 1;
 767   }
 768
 769   if (--$default_output_stack_level < 0)
 770   {
 771     &error ("default output stack has flown under!\n", 1);
 772   }
 773
 774   close (STDOUT);
 775   close (STDERR);
 776
 777   open (STDOUT, ">&SAVEDOS" . $default_output_stack_level . "out")
 778         || &error ("ddo: $! duping STDOUT\n", 1);
 779   open (STDERR, ">&SAVEDOS" . $default_output_stack_level . "err")
 780         || &error ("ddo: $! duping STDERR\n", 1);
 781
 782   close ("SAVEDOS" . $default_output_stack_level . "out")
 783         || &error ("ddo: $! closing SCSDOSout\n", 1);
 784   close ("SAVEDOS" . $default_output_stack_level . "err")
 785          || &error ("ddo: $! closing SAVEDOSerr\n", 1);
 786 }
 787
 788 # This runs a command without any debugging info.
 789 sub _run_command
 790 {
 791   my $code;
 792
 793   # We reset this before every invocation.  On Windows I think there is only
 794   # one environment, not one per process, so I think that variables set in
 795   # test scripts might leak into subsequent tests if this isn't reset--???
 796   resetENV();
 797
 798   eval {
 799       local $SIG{ALRM} = sub { die "timeout\n"; };
 800       alarm $test_timeout;
 801       $code = system @_;
 802       alarm 0;
 803   };
 804   if ($@) {
 805       # The eval failed.  If it wasn't SIGALRM then die.
 806       $@ eq "timeout\n" or die;
 807
 808       # Timed out.  Resend the alarm to our process group to kill the children.
 809       $SIG{ALRM} = 'IGNORE';
 810       kill -14, $$;
 811       $code = 14;
 812   }
 813
 814   return $code;
 815 }
 816
 817 # run one command (passed as a list of arg 0 - n), returning 0 on success
 818 # and nonzero on failure.
 819
 820 sub run_command
 821 {
 822   print "\nrun_command: @_\n" if $debug;
 823   my $code = _run_command(@_);
 824   print "run_command returned $code.\n" if $debug;
 825
 826   return $code;
 827 }
 828
 829 # run one command (passed as a list of arg 0 - n, with arg 0 being the
 830 # second arg to this routine), returning 0 on success and non-zero on failure.
 831 # The first arg to this routine is a filename to connect to the stdout
 832 # & stderr of the child process.
 833
 834 sub run_command_with_output
 835 {
 836   my $filename = shift;
 837
 838   print "\nrun_command_with_output($filename,$runname): @_\n" if $debug;
 839   &attach_default_output ($filename);
 840   my $code = _run_command(@_);
 841   &detach_default_output;
 842   print "run_command_with_output returned $code.\n" if $debug;
 843
 844   return $code;
 845 }
 846
 847 # performs the equivalent of an "rm -rf" on the first argument.  Like
 848 # rm, if the path ends in /, leaves the (now empty) directory; otherwise
 849 # deletes it, too.
 850
 851 sub remove_directory_tree
 852 {
 853   local ($targetdir) = @_;
 854   local ($nuketop) = 1;
 855   local ($ch);
 856
 857   $ch = substr ($targetdir, length ($targetdir) - 1);
 858   if ($ch eq "/" || $ch eq $pathsep)
 859   {
 860     $targetdir = substr ($targetdir, 0, length ($targetdir) - 1);
 861     $nuketop = 0;
 862   }
 863
 864   if (! -e $targetdir)
 865   {
 866     return 1;
 867   }
 868
 869   &remove_directory_tree_inner ("RDT00", $targetdir) || return 0;
 870   if ($nuketop)
 871   {
 872     rmdir $targetdir || return 0;
 873   }
 874
 875   return 1;
 876 }
 877
 878 sub remove_directory_tree_inner
 879 {
 880   local ($dirhandle, $targetdir) = @_;
 881   local ($object);
 882   local ($subdirhandle);
 883
 884   opendir ($dirhandle, $targetdir) || return 0;
 885   $subdirhandle = $dirhandle;
 886   $subdirhandle++;
 887   while ($object = readdir ($dirhandle))
 888   {
 889     if ($object =~ /^(\.\.?|CVS|RCS)$/)
 890     {
 891       next;
 892     }
 893
 894     $object = "$targetdir$pathsep$object";
 895     lstat ($object);
 896
 897     if (-d _ && &remove_directory_tree_inner ($subdirhandle, $object))
 898     {
 899       rmdir $object || return 0;
 900     }
 901     else
 902     {
 903       unlink $object || return 0;
 904     }
 905   }
 906   closedir ($dirhandle);
 907   return 1;
 908 }
 909
 910 # We used to use this behavior for this function:
 911 #
 912 #sub touch
 913 #{
 914 #  local (@filenames) = @_;
 915 #  local ($now) = time;
 916 #  local ($file);
 917 #
 918 #  foreach $file (@filenames)
 919 #  {
 920 #    utime ($now, $now, $file)
 921 #          || (open (TOUCHFD, ">> $file") && close (TOUCHFD))
 922 #               || &error ("Couldn't touch $file: $!\n", 1);
 923 #  }
 924 #  return 1;
 925 #}
 926 #
 927 # But this behaves badly on networked filesystems where the time is
 928 # skewed, because it sets the time of the file based on the _local_
 929 # host.  Normally when you modify a file, it's the _remote_ host that
 930 # determines the modtime, based on _its_ clock.  So, instead, now we open
 931 # the file and write something into it to force the remote host to set
 932 # the modtime correctly according to its clock.
 933 #
 934
 935 sub touch
 936 {
 937   local ($file);
 938
 939   foreach $file (@_) {
 940     (open(T, ">> $file") && print(T "\n") && close(T))
 941         || &error("Couldn't touch $file: $!\n", 1);
 942   }
 943 }
 944
 945 # Touch with a time offset.  To DTRT, call touch() then use stat() to get the
 946 # access/mod time for each file and apply the offset.
 947
 948 sub utouch
 949 {
 950   local ($off) = shift;
 951   local ($file);
 952
 953   &touch(@_);
 954
 955   local (@s) = stat($_[0]);
 956
 957   utime($s[8]+$off, $s[9]+$off, @_);
 958 }
 959
 960 # open a file, write some stuff to it, and close it.
 961
 962 sub create_file
 963 {
 964   local ($filename, @lines) = @_;
 965
 966   open (CF, "> $filename") || &error ("Couldn't open $filename: $!\n", 1);
 967   foreach $line (@lines)
 968   {
 969     print CF $line;
 970   }
 971   close (CF);
 972 }
 973
 974 # create a directory tree described by an associative array, wherein each
 975 # key is a relative pathname (using slashes) and its associated value is
 976 # one of:
 977 #    DIR            indicates a directory
 978 #    FILE:contents  indicates a file, which should contain contents +\n
 979 #    LINK:target    indicates a symlink, pointing to $basedir/target
 980 # The first argument is the dir under which the structure will be created
 981 # (the dir will be made and/or cleaned if necessary); the second argument
 982 # is the associative array.
 983
 984 sub create_dir_tree
 985 {
 986   local ($basedir, %dirtree) = @_;
 987   local ($path);
 988
 989   &remove_directory_tree ("$basedir");
 990   mkdir ($basedir, 0777) || &error ("Couldn't mkdir $basedir: $!\n", 1);
 991
 992   foreach $path (sort keys (%dirtree))
 993   {
 994     if ($dirtree {$path} =~ /^DIR$/)
 995     {
 996       mkdir ("$basedir/$path", 0777)
 997                || &error ("Couldn't mkdir $basedir/$path: $!\n", 1);
 998     }
 999     elsif ($dirtree {$path} =~ /^FILE:(.*)$/)
1000     {
1001       &create_file ("$basedir/$path", $1 . "\n");
1002     }
1003     elsif ($dirtree {$path} =~ /^LINK:(.*)$/)
1004     {
1005       symlink ("$basedir/$1", "$basedir/$path")
1006         || &error ("Couldn't symlink $basedir/$path -> $basedir/$1: $!\n", 1);
1007     }
1008     else
1009     {
1010       &error ("Bogus dirtree type: \"$dirtree{$path}\"\n", 1);
1011     }
1012   }
1013   if ($just_setup_tree)
1014   {
1015     die "Tree is setup...\n";
1016   }
1017 }
1018
1019 # compare a directory tree with an associative array in the format used
1020 # by create_dir_tree, above.
1021 # The first argument is the dir under which the structure should be found;
1022 # the second argument is the associative array.
1023
1024 sub compare_dir_tree
1025 {
1026   local ($basedir, %dirtree) = @_;
1027   local ($path);
1028   local ($i);
1029   local ($bogus) = 0;
1030   local ($contents);
1031   local ($target);
1032   local ($fulltarget);
1033   local ($found);
1034   local (@files);
1035   local (@allfiles);
1036
1037   opendir (DIR, $basedir) || &error ("Couldn't open $basedir: $!\n", 1);
1038   @allfiles = grep (!/^(\.\.?|CVS|RCS)$/, readdir (DIR) );
1039   closedir (DIR);
1040   if ($debug)
1041   {
1042     print "dirtree: (%dirtree)\n$basedir: (@allfiles)\n";
1043   }
1044
1045   foreach $path (sort keys (%dirtree))
1046   {
1047     if ($debug)
1048     {
1049       print "Checking $path ($dirtree{$path}).\n";
1050     }
1051
1052     $found = 0;
1053     foreach $i (0 .. $#allfiles)
1054     {
1055       if ($allfiles[$i] eq $path)
1056       {
1057         splice (@allfiles, $i, 1);  # delete it
1058         if ($debug)
1059         {
1060           print "     Zapped $path; files now (@allfiles).\n";
1061         }
1062         lstat ("$basedir/$path");
1063         $found = 1;
1064         last;
1065       }
1066     }
1067
1068     if (!$found)
1069     {
1070       print "compare_dir_tree: $path does not exist.\n";
1071       $bogus = 1;
1072       next;
1073     }
1074
1075     if ($dirtree {$path} =~ /^DIR$/)
1076     {
1077       if (-d _ && opendir (DIR, "$basedir/$path") )
1078       {
1079         @files = readdir (DIR);
1080         closedir (DIR);
1081         @files = grep (!/^(\.\.?|CVS|RCS)$/ && ($_ = "$path/$_"), @files);
1082         push (@allfiles, @files);
1083         if ($debug)
1084         {
1085           print "     Read in $path; new files (@files).\n";
1086         }
1087       }
1088       else
1089       {
1090         print "compare_dir_tree: $path is not a dir.\n";
1091         $bogus = 1;
1092       }
1093     }
1094     elsif ($dirtree {$path} =~ /^FILE:(.*)$/)
1095     {
1096       if (-l _ || !-f _)
1097       {
1098         print "compare_dir_tree: $path is not a file.\n";
1099         $bogus = 1;
1100         next;
1101       }
1102
1103       if ($1 ne "*")
1104       {
1105         $contents = &read_file_into_string ("$basedir/$path");
1106         if ($contents ne "$1\n")
1107         {
1108           print "compare_dir_tree: $path contains wrong stuff."
1109               . "  Is:\n$contentsShould be:\n$1\n";
1110           $bogus = 1;
1111         }
1112       }
1113     }
1114     elsif ($dirtree {$path} =~ /^LINK:(.*)$/)
1115     {
1116       $target = $1;
1117       if (!-l _)
1118       {
1119         print "compare_dir_tree: $path is not a link.\n";
1120         $bogus = 1;
1121         next;
1122       }
1123
1124       $contents = readlink ("$basedir/$path");
1125       $contents =~ tr/>/\//;
1126       $fulltarget = "$basedir/$target";
1127       $fulltarget =~ tr/>/\//;
1128       if (!($contents =~ /$fulltarget$/))
1129       {
1130         if ($debug)
1131         {
1132           $target = $fulltarget;
1133         }
1134         print "compare_dir_tree: $path should be link to $target, "
1135             . "not $contents.\n";
1136         $bogus = 1;
1137       }
1138     }
1139     else
1140     {
1141       &error ("Bogus dirtree type: \"$dirtree{$path}\"\n", 1);
1142     }
1143   }
1144
1145   if ($debug)
1146   {
1147     print "leftovers: (@allfiles).\n";
1148   }
1149
1150   foreach $file (@allfiles)
1151   {
1152     print "compare_dir_tree: $file should not exist.\n";
1153     $bogus = 1;
1154   }
1155
1156   return !$bogus;
1157 }
1158
1159 # this subroutine generates the numeric suffix used to keep tmp filenames,
1160 # log filenames, etc., unique.  If the number passed in is 1, then a null
1161 # string is returned; otherwise, we return ".n", where n + 1 is the number
1162 # we were given.
1163
1164 sub num_suffix
1165 {
1166   local($num) = @_;
1167
1168   if (--$num > 0) {
1169     return "$extext$num";
1170   }
1171
1172   return "";
1173 }
1174
1175 # This subroutine returns a log filename with a number appended to
1176 # the end corresponding to how many logfiles have been created in the
1177 # current running test.  An optional parameter may be passed (0 or 1).
1178 # If a 1 is passed, then it does NOT increment the logfile counter
1179 # and returns the name of the latest logfile.  If either no parameter
1180 # is passed at all or a 0 is passed, then the logfile counter is
1181 # incremented and the new name is returned.
1182
1183 sub get_logfile
1184 {
1185   local($no_increment) = @_;
1186
1187   $num_of_logfiles += !$no_increment;
1188
1189   return ($log_filename . &num_suffix ($num_of_logfiles));
1190 }
1191
1192 # This subroutine returns a base (answer) filename with a number
1193 # appended to the end corresponding to how many logfiles (and thus
1194 # base files) have been created in the current running test.
1195 # NO PARAMETERS ARE PASSED TO THIS SUBROUTINE.
1196
1197 sub get_basefile
1198 {
1199   return ($base_filename . &num_suffix ($num_of_logfiles));
1200 }
1201
1202 # This subroutine returns a difference filename with a number appended
1203 # to the end corresponding to how many logfiles (and thus diff files)
1204 # have been created in the current running test.
1205
1206 sub get_difffile
1207 {
1208   return ($diff_filename . &num_suffix ($num_of_logfiles));
1209 }
1210
1211 # This subroutine returns a command filename with a number appended
1212 # to the end corresponding to how many logfiles (and thus command files)
1213 # have been created in the current running test.
1214
1215 sub get_runfile
1216 {
1217   return ($run_filename . &num_suffix ($num_of_logfiles));
1218 }
1219
1220 # just like logfile, only a generic tmp filename for use by the test.
1221 # they are automatically cleaned up unless -keep was used, or the test fails.
1222 # Pass an argument of 1 to return the same filename as the previous call.
1223
1224 sub get_tmpfile
1225 {
1226   local($no_increment) = @_;
1227
1228   $num_of_tmpfiles += !$no_increment;
1229
1230   return ($tmp_filename . &num_suffix ($num_of_tmpfiles));
1231 }
1232
1233 1;