tests/test_driver.pl

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