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
62sub 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
78sub 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
226sub get_osname
227{
228  # Set up an initial value.  In perl5 we can do it the easy way.
229  #
230  $osname = defined($^O) ? $^O : '';
231
232  # See if the filesystem supports long file names with multiple
233  # dots.  DOS doesn't.
234  $short_filenames = 0;
235  (open (TOUCHFD, "> fancy.file.name") && close (TOUCHFD))
236      || ($short_filenames = 1);
237  unlink ("fancy.file.name") || ($short_filenames = 1);
238
239  if (! $short_filenames) {
240    # Thanks go to meyering@cs.utexas.edu (Jim Meyering) for suggesting a
241    # better way of doing this.  (We used to test for existence of a /mnt
242    # dir, but that apparently fails on an SGI Indigo (whatever that is).)
243    # Because perl on VOS translates /'s to >'s, we need to test for
244    # VOSness rather than testing for Unixness (ie, try > instead of /).
245
246    mkdir (".ostest", 0777) || &error ("Couldn't create .ostest: $!\n", 1);
247    open (TOUCHFD, "> .ostest>ick") && close (TOUCHFD);
248    chdir (".ostest") || &error ("Couldn't chdir to .ostest: $!\n", 1);
249  }
250
251  if (! $short_filenames && -f "ick")
252  {
253    $osname = "vos";
254    $vos = 1;
255    $pathsep = ">";
256  }
257  else
258  {
259    # the following is regrettably knarly, but it seems to be the only way
260    # to not get ugly error messages if uname can't be found.
261    # Hmmm, BSD/OS 2.0's uname -a is excessively verbose.  Let's try it
262    # with switches first.
263    eval "chop (\$osname = `sh -c 'uname -nmsr 2>&1'`)";
264    if ($osname =~ /not found/i)
265    {
266	$osname = "(something unixy with no uname)";
267    }
268    elsif ($@ ne "" || $?)
269    {
270        eval "chop (\$osname = `sh -c 'uname -a 2>&1'`)";
271        if ($@ ne "" || $?)
272        {
273	    $osname = "(something unixy)";
274	}
275    }
276    $vos = 0;
277    $pathsep = "/";
278  }
279
280  if (! $short_filenames) {
281    chdir ("..") || &error ("Couldn't chdir to ..: $!\n", 1);
282    unlink (".ostest>ick");
283    rmdir (".ostest") || &error ("Couldn't rmdir .ostest: $!\n", 1);
284  }
285}
286
287sub 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
354sub 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
371sub 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
383sub 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
406sub 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
529sub rmfiles
530{
531  local(@files) = @_;
532
533  if (!$keep)
534  {
535    return (unlink @files);
536  }
537
538  return 1;
539}
540
541sub 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
555sub 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
612sub 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
624sub 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
637sub 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
692sub 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
708sub 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
736sub 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
769sub 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
790sub 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
813sub 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
840sub 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
897sub 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
910sub 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
924sub 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
946sub 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
986sub 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
1126sub 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
1145sub 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
1159sub 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
1168sub 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
1177sub 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
11861;
1187