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 = 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 = 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//g;
 592   $slurp =~ s/\n.*modification time in the future.*//g;
 593   $slurp =~ s/^.*Clock skew detected.*\n//g;
 594   $slurp =~ s/\n.*Clock skew detected.*//g;
 595
 596   if ($slurp eq $answer)
 597   {
 598     if ($debug)
 599     {
 600       print "ok\n";
 601     }
 602     return 1;
 603   }
 604   else
 605   {
 606     if ($debug)
 607     {
 608       print "DIFFERENT OUTPUT\n";
 609     }
 610     $test_passed = 0;
 611     &create_file (&get_basefile, $answer);
 612
 613     if ($debug)
 614     {
 615       print "\nCreating Difference File ...\n";
 616     }
 617     # Create the difference file
 618     local($command) = "diff -c " . &get_basefile . " " . $logfile;
 619     &run_command_with_output(&get_difffile,$command);
 620
 621     return 0;
 622   }
 623 }
 624
 625 sub read_file_into_string
 626 {
 627   local($filename) = @_;
 628   local($oldslash) = $/;
 629
 630   undef $/;
 631
 632   open (RFISFILE, $filename) || return "";
 633   local ($slurp) = <RFISFILE>;
 634   close (RFISFILE);
 635
 636   $/ = $oldslash;
 637
 638   return $slurp;
 639 }
 640
 641 sub attach_default_output
 642 {
 643   local ($filename) = @_;
 644   local ($code);
 645
 646   if ($vos)
 647   {
 648     $code = system "++attach_default_output_hack $filename";
 649     $code == -2 || &error ("adoh death\n", 1);
 650     return 1;
 651   }
 652
 653   open ("SAVEDOS" . $default_output_stack_level . "out", ">&STDOUT")
 654         || &error ("ado: $! duping STDOUT\n", 1);
 655   open ("SAVEDOS" . $default_output_stack_level . "err", ">&STDERR")
 656         || &error ("ado: $! duping STDERR\n", 1);
 657
 658   open (STDOUT, "> " . $filename)
 659         || &error ("ado: $filename: $!\n", 1);
 660   open (STDERR, ">&STDOUT")
 661         || &error ("ado: $filename: $!\n", 1);
 662
 663   $default_output_stack_level++;
 664 }
 665
 666 # close the current stdout/stderr, and restore the previous ones from
 667 # the "stack."
 668
 669 sub detach_default_output
 670 {
 671   local ($code);
 672
 673   if ($vos)
 674   {
 675     $code = system "++detach_default_output_hack";
 676     $code == -2 || &error ("ddoh death\n", 1);
 677     return 1;
 678   }
 679
 680   if (--$default_output_stack_level < 0)
 681   {
 682     &error ("default output stack has flown under!\n", 1);
 683   }
 684
 685   close (STDOUT);
 686   close (STDERR);
 687
 688   open (STDOUT, ">&SAVEDOS" . $default_output_stack_level . "out")
 689         || &error ("ddo: $! duping STDOUT\n", 1);
 690   open (STDERR, ">&SAVEDOS" . $default_output_stack_level . "err")
 691         || &error ("ddo: $! duping STDERR\n", 1);
 692
 693   close ("SAVEDOS" . $default_output_stack_level . "out")
 694         || &error ("ddo: $! closing SCSDOSout\n", 1);
 695   close ("SAVEDOS" . $default_output_stack_level . "err")
 696          || &error ("ddo: $! closing SAVEDOSerr\n", 1);
 697 }
 698
 699 # run one command (passed as a list of arg 0 - n), returning 0 on success
 700 # and nonzero on failure.
 701
 702 sub run_command
 703 {
 704   local ($code);
 705
 706   if ($debug)
 707   {
 708     print "\nrun_command: @_\n";
 709     $code = system @_;
 710     print "run_command: \"@_\" returned $code.\n";
 711     return $code;
 712   }
 713
 714   return system @_;
 715 }
 716
 717 # run one command (passed as a list of arg 0 - n, with arg 0 being the
 718 # second arg to this routine), returning 0 on success and non-zero on failure.
 719 # The first arg to this routine is a filename to connect to the stdout
 720 # & stderr of the child process.
 721
 722 sub run_command_with_output
 723 {
 724   local ($filename) = shift;
 725   local ($code);
 726
 727   &attach_default_output ($filename);
 728   $code = system @_;
 729   &detach_default_output;
 730   if ($debug)
 731   {
 732     print "run_command_with_output: \"@_\" returned $code.\n";
 733   }
 734
 735   return $code;
 736 }
 737
 738 # performs the equivalent of an "rm -rf" on the first argument.  Like
 739 # rm, if the path ends in /, leaves the (now empty) directory; otherwise
 740 # deletes it, too.
 741
 742 sub remove_directory_tree
 743 {
 744   local ($targetdir) = @_;
 745   local ($nuketop) = 1;
 746   local ($ch);
 747
 748   $ch = substr ($targetdir, length ($targetdir) - 1);
 749   if ($ch eq "/" || $ch eq $pathsep)
 750   {
 751     $targetdir = substr ($targetdir, 0, length ($targetdir) - 1);
 752     $nuketop = 0;
 753   }
 754
 755   if (! -e $targetdir)
 756   {
 757     return 1;
 758   }
 759
 760   &remove_directory_tree_inner ("RDT00", $targetdir) || return 0;
 761   if ($nuketop)
 762   {
 763     rmdir $targetdir || return 0;
 764   }
 765
 766   return 1;
 767 }
 768
 769 sub remove_directory_tree_inner
 770 {
 771   local ($dirhandle, $targetdir) = @_;
 772   local ($object);
 773   local ($subdirhandle);
 774
 775   opendir ($dirhandle, $targetdir) || return 0;
 776   $subdirhandle = $dirhandle;
 777   $subdirhandle++;
 778   while ($object = readdir ($dirhandle))
 779   {
 780     if ($object eq "." || $object eq "..")
 781     {
 782       next;
 783     }
 784
 785     $object = "$targetdir$pathsep$object";
 786     lstat ($object);
 787
 788     if (-d _ && &remove_directory_tree_inner ($subdirhandle, $object))
 789     {
 790       rmdir $object || return 0;
 791     }
 792     else
 793     {
 794       unlink $object || return 0;
 795     }
 796   }
 797   closedir ($dirhandle);
 798   return 1;
 799 }
 800
 801 # We used to use this behavior for this function:
 802 #
 803 #sub touch
 804 #{
 805 #  local (@filenames) = @_;
 806 #  local ($now) = time;
 807 #  local ($file);
 808 #
 809 #  foreach $file (@filenames)
 810 #  {
 811 #    utime ($now, $now, $file)
 812 #          || (open (TOUCHFD, ">> $file") && close (TOUCHFD))
 813 #               || &error ("Couldn't touch $file: $!\n", 1);
 814 #  }
 815 #  return 1;
 816 #}
 817 #
 818 # But this behaves badly on networked filesystems where the time is
 819 # skewed, because it sets the time of the file based on the _local_
 820 # host.  Normally when you modify a file, it's the _remote_ host that
 821 # determines the modtime, based on _its_ clock.  So, instead, now we open
 822 # the file and write something into it to force the remote host to set
 823 # the modtime correctly according to its clock.
 824 #
 825
 826 sub touch
 827 {
 828   local (@filenames) = @_;
 829   local ($file);
 830
 831   foreach $file (@filenames) {
 832     (open(T, ">> $file") && print(T "\n") && close(T))
 833         || &error("Couldn't touch $file: $!\n", 1);
 834   }
 835 }
 836
 837 # open a file, write some stuff to it, and close it.
 838
 839 sub create_file
 840 {
 841   local ($filename, @lines) = @_;
 842
 843   open (CF, "> $filename") || &error ("Couldn't open $filename: $!\n", 1);
 844   foreach $line (@lines)
 845   {
 846     print CF $line;
 847   }
 848   close (CF);
 849 }
 850
 851 # create a directory tree described by an associative array, wherein each
 852 # key is a relative pathname (using slashes) and its associated value is
 853 # one of:
 854 #    DIR            indicates a directory
 855 #    FILE:contents  indicates a file, which should contain contents +\n
 856 #    LINK:target    indicates a symlink, pointing to $basedir/target
 857 # The first argument is the dir under which the structure will be created
 858 # (the dir will be made and/or cleaned if necessary); the second argument
 859 # is the associative array.
 860
 861 sub create_dir_tree
 862 {
 863   local ($basedir, %dirtree) = @_;
 864   local ($path);
 865
 866   &remove_directory_tree ("$basedir");
 867   mkdir ($basedir, 0777) || &error ("Couldn't mkdir $basedir: $!\n", 1);
 868
 869   foreach $path (sort keys (%dirtree))
 870   {
 871     if ($dirtree {$path} =~ /^DIR$/)
 872     {
 873       mkdir ("$basedir/$path", 0777)
 874                || &error ("Couldn't mkdir $basedir/$path: $!\n", 1);
 875     }
 876     elsif ($dirtree {$path} =~ /^FILE:(.*)$/)
 877     {
 878       &create_file ("$basedir/$path", $1 . "\n");
 879     }
 880     elsif ($dirtree {$path} =~ /^LINK:(.*)$/)
 881     {
 882       symlink ("$basedir/$1", "$basedir/$path")
 883         || &error ("Couldn't symlink $basedir/$path -> $basedir/$1: $!\n", 1);
 884     }
 885     else
 886     {
 887       &error ("Bogus dirtree type: \"$dirtree{$path}\"\n", 1);
 888     }
 889   }
 890   if ($just_setup_tree)
 891   {
 892     die "Tree is setup...\n";
 893   }
 894 }
 895
 896 # compare a directory tree with an associative array in the format used
 897 # by create_dir_tree, above.
 898 # The first argument is the dir under which the structure should be found;
 899 # the second argument is the associative array.
 900
 901 sub compare_dir_tree
 902 {
 903   local ($basedir, %dirtree) = @_;
 904   local ($path);
 905   local ($i);
 906   local ($bogus) = 0;
 907   local ($contents);
 908   local ($target);
 909   local ($fulltarget);
 910   local ($found);
 911   local (@files);
 912   local (@allfiles);
 913
 914   opendir (DIR, $basedir) || &error ("Couldn't open $basedir: $!\n", 1);
 915   @allfiles = grep (!/^\.\.?$/, readdir (DIR) );
 916   closedir (DIR);
 917   if ($debug)
 918   {
 919     print "dirtree: (%dirtree)\n$basedir: (@allfiles)\n";
 920   }
 921
 922   foreach $path (sort keys (%dirtree))
 923   {
 924     if ($debug)
 925     {
 926       print "Checking $path ($dirtree{$path}).\n";
 927     }
 928
 929     $found = 0;
 930     foreach $i (0 .. $#allfiles)
 931     {
 932       if ($allfiles[$i] eq $path)
 933       {
 934         splice (@allfiles, $i, 1);  # delete it
 935         if ($debug)
 936         {
 937           print "     Zapped $path; files now (@allfiles).\n";
 938         }
 939         lstat ("$basedir/$path");
 940         $found = 1;
 941         last;
 942       }
 943     }
 944
 945     if (!$found)
 946     {
 947       print "compare_dir_tree: $path does not exist.\n";
 948       $bogus = 1;
 949       next;
 950     }
 951
 952     if ($dirtree {$path} =~ /^DIR$/)
 953     {
 954       if (-d _ && opendir (DIR, "$basedir/$path") )
 955       {
 956         @files = readdir (DIR);
 957         closedir (DIR);
 958         @files = grep (!/^\.\.?$/ && ($_ = "$path/$_"), @files);
 959         push (@allfiles, @files);
 960         if ($debug)
 961         {
 962           print "     Read in $path; new files (@files).\n";
 963         }
 964       }
 965       else
 966       {
 967         print "compare_dir_tree: $path is not a dir.\n";
 968         $bogus = 1;
 969       }
 970     }
 971     elsif ($dirtree {$path} =~ /^FILE:(.*)$/)
 972     {
 973       if (-l _ || !-f _)
 974       {
 975         print "compare_dir_tree: $path is not a file.\n";
 976         $bogus = 1;
 977         next;
 978       }
 979
 980       if ($1 ne "*")
 981       {
 982         $contents = &read_file_into_string ("$basedir/$path");
 983         if ($contents ne "$1\n")
 984         {
 985           print "compare_dir_tree: $path contains wrong stuff."
 986               . "  Is:\n$contentsShould be:\n$1\n";
 987           $bogus = 1;
 988         }
 989       }
 990     }
 991     elsif ($dirtree {$path} =~ /^LINK:(.*)$/)
 992     {
 993       $target = $1;
 994       if (!-l _)
 995       {
 996         print "compare_dir_tree: $path is not a link.\n";
 997         $bogus = 1;
 998         next;
 999       }
1000
1001       $contents = readlink ("$basedir/$path");
1002       $contents =~ tr/>/\//;
1003       $fulltarget = "$basedir/$target";
1004       $fulltarget =~ tr/>/\//;
1005       if (!($contents =~ /$fulltarget$/))
1006       {
1007         if ($debug)
1008         {
1009           $target = $fulltarget;
1010         }
1011         print "compare_dir_tree: $path should be link to $target, "
1012             . "not $contents.\n";
1013         $bogus = 1;
1014       }
1015     }
1016     else
1017     {
1018       &error ("Bogus dirtree type: \"$dirtree{$path}\"\n", 1);
1019     }
1020   }
1021
1022   if ($debug)
1023   {
1024     print "leftovers: (@allfiles).\n";
1025   }
1026
1027   foreach $file (@allfiles)
1028   {
1029     print "compare_dir_tree: $file should not exist.\n";
1030     $bogus = 1;
1031   }
1032
1033   return !$bogus;
1034 }
1035
1036 # this subroutine generates the numeric suffix used to keep tmp filenames,
1037 # log filenames, etc., unique.  If the number passed in is 1, then a null
1038 # string is returned; otherwise, we return ".n", where n + 1 is the number
1039 # we were given.
1040
1041 sub num_suffix
1042 {
1043   local($num) = @_;
1044
1045   if (--$num > 0) {
1046     return "$extext$num";
1047   }
1048
1049   return "";
1050 }
1051
1052 # This subroutine returns a log filename with a number appended to
1053 # the end corresponding to how many logfiles have been created in the
1054 # current running test.  An optional parameter may be passed (0 or 1).
1055 # If a 1 is passed, then it does NOT increment the logfile counter
1056 # and returns the name of the latest logfile.  If either no parameter
1057 # is passed at all or a 0 is passed, then the logfile counter is
1058 # incremented and the new name is returned.
1059
1060 sub get_logfile
1061 {
1062   local($no_increment) = @_;
1063
1064   $num_of_logfiles += !$no_increment;
1065
1066   return ($log_filename . &num_suffix ($num_of_logfiles));
1067 }
1068
1069 # This subroutine returns a base (answer) filename with a number
1070 # appended to the end corresponding to how many logfiles (and thus
1071 # base files) have been created in the current running test.
1072 # NO PARAMETERS ARE PASSED TO THIS SUBROUTINE.
1073
1074 sub get_basefile
1075 {
1076   return ($base_filename . &num_suffix ($num_of_logfiles));
1077 }
1078
1079 # This subroutine returns a difference filename with a number appended
1080 # to the end corresponding to how many logfiles (and thus diff files)
1081 # have been created in the current running test.
1082
1083 sub get_difffile
1084 {
1085   return ($diff_filename . &num_suffix ($num_of_logfiles));
1086 }
1087
1088 # just like logfile, only a generic tmp filename for use by the test.
1089 # they are automatically cleaned up unless -keep was used, or the test fails.
1090 # Pass an argument of 1 to return the same filename as the previous call.
1091
1092 sub get_tmpfile
1093 {
1094   local($no_increment) = @_;
1095
1096   $num_of_tmpfiles += !$no_increment;
1097
1098   return ($tmp_filename . &num_suffix ($num_of_tmpfiles));
1099 }
1100
1101 1;