tests/test_driver.pl

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