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