VirtualBox

source: kBuild/vendor/gnumake/current/tests/test_driver.pl

最後變更 在這個檔案是 3138,由 bird 提交於 7 年 前

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

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