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