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