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