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