VirtualBox

source: kBuild/branches/GNU/src/gmake/tests/test_driver.pl@ 54

Last change on this file since 54 was 53, checked in by bird, 21 years ago

Initial revision

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

© 2024 Oracle Support Privacy / Do Not Sell My Info Terms of Use Trademark Policy Automated Access Etiquette