Changeset 3140 for trunk/src/kmk/tests/test_driver.pl
- Timestamp:
- Mar 14, 2018, 10:28:10 PM (7 years ago)
- Location:
- trunk/src/kmk
- Files:
-
- 2 edited
-
. (modified) (1 prop)
-
tests/test_driver.pl (modified) (29 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/src/kmk
-
Property svn:mergeinfo
set to
/vendor/gnumake/current merged eligible
-
Property svn:mergeinfo
set to
-
trunk/src/kmk/tests/test_driver.pl
r2591 r3140 6 6 # Modified 92-02-11 through 92-02-22 by Chris Arthur to further generalize. 7 7 # 8 # Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 9 # 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software 10 # Foundation, Inc. 8 # Copyright (C) 1991-2016 Free Software Foundation, Inc. 11 9 # This file is part of GNU Make. 12 10 # … … 31 29 # variables and then calls &toplevel, which does all the real work. 32 30 33 # $Id : test_driver.pl,v 1.30 2010/07/28 05:39:50 psmith Exp$31 # $Id$ 34 32 35 33 … … 51 49 $test_passed = 1; 52 50 53 54 51 # Timeout in seconds. If the test takes longer than this we'll fail it. 55 52 $test_timeout = 5; 53 $test_timeout = 10 if $^O eq 'VMS'; 56 54 57 55 # Path to Perl … … 65 63 %extraENV = (); 66 64 65 sub 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 67 92 # %origENV is the caller's original environment 68 %origENV = %ENV; 93 if ($^O ne 'VMS') { 94 %origENV = %ENV; 95 } else { 96 my $proc_env = vms_get_process_logicals; 97 %origENV = %{$proc_env}; 98 } 69 99 70 100 sub resetENV … … 73 103 # through Perl 5.004. It was fixed in Perl 5.004_01, but we don't 74 104 # want to require that here, so just delete each one individually. 75 foreach $v (keys %ENV) { 76 delete $ENV{$v}; 77 } 78 79 %ENV = %makeENV; 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 80 126 foreach $v (keys %extraENV) { 81 127 $ENV{$v} = $extraENV{$v}; … … 90 136 foreach (# UNIX-specific things 91 137 'TZ', 'TMPDIR', 'HOME', 'USER', 'LOGNAME', 'PATH', 138 'LD_LIBRARY_PATH', 92 139 # Purify things 93 140 'PURIFYOPTIONS', … … 107 154 # Replace the environment with the new one 108 155 # 109 %origENV = %ENV ;156 %origENV = %ENV unless $^O eq 'VMS'; 110 157 111 158 resetENV(); … … 135 182 &parse_command_line (@ARGV); 136 183 137 print "OS name = `$osname'\n" if $debug;184 print "OS name = '$osname'\n" if $debug; 138 185 139 186 $workpath = "$cwdslash$workdir"; … … 143 190 144 191 &print_banner; 192 193 if ($osname eq 'VMS' && $cwdslash eq "") 194 { 195 # Porting this script to VMS revealed a small bug in opendir() not 196 # handling search lists correctly when the directory only exists in 197 # one of the logical_devices. Need to find the first directory in 198 # the search list, as that is where things will be written to. 199 my @dirs = split("/", $pwd); 200 201 my $logical_device = $ENV{$dirs[1]}; 202 if ($logical_device =~ /([A-Za-z0-9_]+):(:?.+:)+/) 203 { 204 # A search list was found. Grab the first logical device 205 # and use it instead of the search list. 206 $dirs[1]=$1; 207 my $lcl_pwd = join('/', @dirs); 208 $workpath = $lcl_pwd . '/' . $workdir 209 } 210 } 145 211 146 212 if (-d $workpath) … … 170 236 push (@rmdirs, $dir); 171 237 -d "$workpath/$dir" 172 238 || mkdir ("$workpath/$dir", 0777) 173 239 || &error ("Couldn't mkdir $workpath/$dir: $!\n"); 174 240 } … … 179 245 print "Finding tests...\n"; 180 246 opendir (SCRIPTDIR, $scriptpath) 181 247 || &error ("Couldn't opendir $scriptpath: $!\n"); 182 248 @dirs = grep (!/^(\..*|CVS|RCS)$/, readdir (SCRIPTDIR) ); 183 249 closedir (SCRIPTDIR); … … 186 252 next if ($dir =~ /^(\..*|CVS|RCS)$/ || ! -d "$scriptpath/$dir"); 187 253 push (@rmdirs, $dir); 254 # VMS can have overlayed file systems, so directories may repeat. 255 next if -d "$workpath/$dir"; 188 256 mkdir ("$workpath/$dir", 0777) 189 257 || &error ("Couldn't mkdir $workpath/$dir: $!\n"); 190 258 opendir (SCRIPTDIR, "$scriptpath/$dir") 191 259 || &error ("Couldn't opendir $scriptpath/$dir: $!\n"); 192 260 @files = grep (!/^(\..*|CVS|RCS|.*~)$/, readdir (SCRIPTDIR) ); 193 261 closedir (SCRIPTDIR); … … 195 263 { 196 264 -d $test and next; 197 265 push (@TESTS, "$dir/$test"); 198 266 } 199 267 } … … 207 275 print "\n"; 208 276 209 &run_each_test;277 run_all_tests(); 210 278 211 279 foreach $dir (@rmdirs) … … 225 293 print " in $categories_failed Categor"; 226 294 print ($categories_failed == 1 ? "y" : "ies"); 227 print " Failed (See .$diffext files in $workdir dir for details) :-(\n\n";295 print " Failed (See .$diffext* files in $workdir dir for details) :-(\n\n"; 228 296 return 0; 229 297 } … … 244 312 $osname = defined($^O) ? $^O : ''; 245 313 314 if ($osname eq 'VMS') 315 { 316 $vos = 0; 317 $pathsep = "/"; 318 return; 319 } 320 246 321 # Find a path to Perl 247 322 … … 280 355 if ($osname =~ /not found/i) 281 356 { 282 357 $osname = "(something posixy with no uname)"; 283 358 } 284 359 elsif ($@ ne "" || $?) … … 287 362 if ($@ ne "" || $?) 288 363 { 289 290 364 $osname = "(something posixy)"; 365 } 291 366 } 292 367 $vos = 0; … … 441 516 } 442 517 443 sub run_each_test 444 { 445 $categories_run = 0; 446 447 foreach $testname (sort @TESTS) 448 { 449 ++$categories_run; 450 $suite_passed = 1; # reset by test on failure 451 $num_of_logfiles = 0; 452 $num_of_tmpfiles = 0; 453 $description = ""; 454 $details = ""; 455 $old_makefile = undef; 456 $testname =~ s/^$scriptpath$pathsep//; 457 $perl_testname = "$scriptpath$pathsep$testname"; 458 $testname =~ s/(\.pl|\.perl)$//; 459 $testpath = "$workpath$pathsep$testname"; 460 # Leave enough space in the extensions to append a number, even 461 # though it needs to fit into 8+3 limits. 462 if ($short_filenames) { 463 $logext = 'l'; 464 $diffext = 'd'; 465 $baseext = 'b'; 466 $runext = 'r'; 467 $extext = ''; 468 } else { 469 $logext = 'log'; 470 $diffext = 'diff'; 471 $baseext = 'base'; 472 $runext = 'run'; 473 $extext = '.'; 474 } 475 $log_filename = "$testpath.$logext"; 476 $diff_filename = "$testpath.$diffext"; 477 $base_filename = "$testpath.$baseext"; 478 $run_filename = "$testpath.$runext"; 479 $tmp_filename = "$testpath.$tmpfilesuffix"; 480 481 &setup_for_test; # suite-defined 482 483 $output = "........................................................ "; 484 485 substr($output,0,length($testname)) = "$testname "; 486 487 print $output; 488 489 # Run the actual test! 490 $tests_run = 0; 491 $tests_passed = 0; 492 493 $code = do $perl_testname; 494 495 $total_tests_run += $tests_run; 496 $total_tests_passed += $tests_passed; 497 498 # How did it go? 499 if (!defined($code)) 500 { 501 $suite_passed = 0; 502 if (length ($@)) { 503 warn "\n*** Test died ($testname): $@\n"; 504 } else { 505 warn "\n*** Couldn't run $perl_testname\n"; 506 } 507 } 508 elsif ($code == -1) { 509 $suite_passed = 0; 510 } 511 elsif ($code != 1 && $code != -1) { 512 $suite_passed = 0; 513 warn "\n*** Test returned $code\n"; 514 } 515 516 if ($suite_passed) { 517 ++$categories_passed; 518 $status = "ok ($tests_passed passed)"; 519 for ($i = $num_of_tmpfiles; $i; $i--) 520 { 521 &rmfiles ($tmp_filename . &num_suffix ($i) ); 522 } 523 524 for ($i = $num_of_logfiles ? $num_of_logfiles : 1; $i; $i--) 525 { 526 &rmfiles ($log_filename . &num_suffix ($i) ); 527 &rmfiles ($base_filename . &num_suffix ($i) ); 528 } 529 } 530 elsif (!defined $code || $code > 0) { 531 $status = "FAILED ($tests_passed/$tests_run passed)"; 532 } 533 elsif ($code < 0) { 534 $status = "N/A"; 535 --$categories_run; 536 } 537 538 # If the verbose option has been specified, then a short description 539 # of each test is printed before displaying the results of each test 540 # describing WHAT is being tested. 541 542 if ($verbose) 543 { 544 if ($detail) 545 { 546 print "\nWHAT IS BEING TESTED\n"; 547 print "--------------------"; 548 } 549 print "\n\n$description\n\n"; 550 } 551 552 # If the detail option has been specified, then the details of HOW 553 # the test is testing what it says it is testing in the verbose output 554 # will be displayed here before the results of the test are displayed. 555 556 if ($detail) 557 { 558 print "\nHOW IT IS TESTED\n"; 559 print "----------------"; 560 print "\n\n$details\n\n"; 561 } 562 563 print "$status\n"; 564 } 518 sub run_all_tests 519 { 520 $categories_run = 0; 521 522 $lasttest = ''; 523 foreach $testname (sort @TESTS) { 524 # Skip duplicates on VMS caused by logical name search lists. 525 next if $testname eq $lasttest; 526 $lasttest = $testname; 527 $suite_passed = 1; # reset by test on failure 528 $num_of_logfiles = 0; 529 $num_of_tmpfiles = 0; 530 $description = ""; 531 $details = ""; 532 $old_makefile = undef; 533 $testname =~ s/^$scriptpath$pathsep//; 534 $perl_testname = "$scriptpath$pathsep$testname"; 535 $testname =~ s/(\.pl|\.perl)$//; 536 $testpath = "$workpath$pathsep$testname"; 537 # Leave enough space in the extensions to append a number, even 538 # though it needs to fit into 8+3 limits. 539 if ($short_filenames) { 540 $logext = 'l'; 541 $diffext = 'd'; 542 $baseext = 'b'; 543 $runext = 'r'; 544 $extext = ''; 545 } else { 546 $logext = 'log'; 547 $diffext = 'diff'; 548 $baseext = 'base'; 549 $runext = 'run'; 550 $extext = '.'; 551 } 552 $extext = '_' if $^O eq 'VMS'; 553 $log_filename = "$testpath.$logext"; 554 $diff_filename = "$testpath.$diffext"; 555 $base_filename = "$testpath.$baseext"; 556 $run_filename = "$testpath.$runext"; 557 $tmp_filename = "$testpath.$tmpfilesuffix"; 558 559 setup_for_test(); 560 561 $output = "........................................................ "; 562 563 substr($output,0,length($testname)) = "$testname "; 564 565 print $output; 566 567 $tests_run = 0; 568 $tests_passed = 0; 569 570 # Run the test! 571 $code = do $perl_testname; 572 573 ++$categories_run; 574 $total_tests_run += $tests_run; 575 $total_tests_passed += $tests_passed; 576 577 # How did it go? 578 if (!defined($code)) { 579 # Failed to parse or called die 580 if (length ($@)) { 581 warn "\n*** Test died ($testname): $@\n"; 582 } else { 583 warn "\n*** Couldn't parse $perl_testname\n"; 584 } 585 $status = "FAILED ($tests_passed/$tests_run passed)"; 586 } 587 588 elsif ($code == -1) { 589 # Skipped... not supported 590 $status = "N/A"; 591 --$categories_run; 592 } 593 594 elsif ($code != 1) { 595 # Bad result... this shouldn't really happen. Usually means that 596 # the suite forgot to end with "1;". 597 warn "\n*** Test returned $code\n"; 598 $status = "FAILED ($tests_passed/$tests_run passed)"; 599 } 600 601 elsif ($tests_run == 0) { 602 # Nothing was done!! 603 $status = "FAILED (no tests found!)"; 604 } 605 606 elsif ($tests_run > $tests_passed) { 607 # Lose! 608 $status = "FAILED ($tests_passed/$tests_run passed)"; 609 } 610 611 else { 612 # Win! 613 ++$categories_passed; 614 $status = "ok ($tests_passed passed)"; 615 616 # Clean up 617 for ($i = $num_of_tmpfiles; $i; $i--) { 618 rmfiles($tmp_filename . num_suffix($i)); 619 } 620 for ($i = $num_of_logfiles ? $num_of_logfiles : 1; $i; $i--) { 621 rmfiles($log_filename . num_suffix($i)); 622 rmfiles($base_filename . num_suffix($i)); 623 } 624 } 625 626 # If the verbose option has been specified, then a short description 627 # of each test is printed before displaying the results of each test 628 # describing WHAT is being tested. 629 630 if ($verbose) { 631 if ($detail) { 632 print "\nWHAT IS BEING TESTED\n"; 633 print "--------------------"; 634 } 635 print "\n\n$description\n\n"; 636 } 637 638 # If the detail option has been specified, then the details of HOW 639 # the test is testing what it says it is testing in the verbose output 640 # will be displayed here before the results of the test are displayed. 641 642 if ($detail) { 643 print "\nHOW IT IS TESTED\n"; 644 print "----------------"; 645 print "\n\n$details\n\n"; 646 } 647 648 print "$status\n"; 649 } 565 650 } 566 651 … … 679 764 local($slurp, $answer_matched) = ('', 0); 680 765 681 print "Comparing Output ........ " if $debug;682 683 $slurp = &read_file_into_string ($logfile);684 685 # For make, get rid of any time skew error before comparing--too bad this686 # has to go into the "generic" driver code :-/687 $slurp =~ s/^.*modification time .*in the future.*\n//gm;688 $slurp =~ s/^.*Clock skew detected.*\n//gm;689 690 766 ++$tests_run; 691 767 692 if ($slurp eq $answer) { 693 $answer_matched = 1; 768 if (! defined $answer) { 769 print "Ignoring output ........ " if $debug; 770 $answer_matched = 1; 694 771 } else { 695 # See if it is a slash or CRLF problem 696 local ($answer_mod, $slurp_mod) = ($answer, $slurp); 697 698 $answer_mod =~ tr,\\,/,; 699 $answer_mod =~ s,\r\n,\n,gs; 700 701 $slurp_mod =~ tr,\\,/,; 702 $slurp_mod =~ s,\r\n,\n,gs; 703 704 $answer_matched = ($slurp_mod eq $answer_mod); 705 706 # If it still doesn't match, see if the answer might be a regex. 707 if (!$answer_matched && $answer =~ m,^/(.+)/$,) { 708 $answer_matched = ($slurp =~ /$1/); 709 if (!$answer_matched && $answer_mod =~ m,^/(.+)/$,) { 710 $answer_matched = ($slurp_mod =~ /$1/); 772 print "Comparing Output ........ " if $debug; 773 774 $slurp = &read_file_into_string ($logfile); 775 776 # For make, get rid of any time skew error before comparing--too bad this 777 # has to go into the "generic" driver code :-/ 778 $slurp =~ s/^.*modification time .*in the future.*\n//gm; 779 $slurp =~ s/^.*Clock skew detected.*\n//gm; 780 781 if ($slurp eq $answer) { 782 $answer_matched = 1; 783 } else { 784 # See if it is a slash or CRLF problem 785 local ($answer_mod, $slurp_mod) = ($answer, $slurp); 786 787 $answer_mod =~ tr,\\,/,; 788 $answer_mod =~ s,\r\n,\n,gs; 789 790 $slurp_mod =~ tr,\\,/,; 791 $slurp_mod =~ s,\r\n,\n,gs; 792 793 $answer_matched = ($slurp_mod eq $answer_mod); 794 if ($^O eq 'VMS') { 795 796 # VMS has extra blank lines in output sometimes. 797 # Ticket #41760 798 if (!$answer_matched) { 799 $slurp_mod =~ s/\n\n+/\n/gm; 800 $slurp_mod =~ s/\A\n+//g; 801 $answer_matched = ($slurp_mod eq $answer_mod); 802 } 803 804 # VMS adding a "Waiting for unfinished jobs..." 805 # Remove it for now to see what else is going on. 806 if (!$answer_matched) { 807 $slurp_mod =~ s/^.+\*\*\* Waiting for unfinished jobs.+$//m; 808 $slurp_mod =~ s/\n\n/\n/gm; 809 $slurp_mod =~ s/^\n+//gm; 810 $answer_matched = ($slurp_mod eq $answer_mod); 811 } 812 813 # VMS wants target device to exist or generates an error, 814 # Some test tagets look like VMS devices and trip this. 815 if (!$answer_matched) { 816 $slurp_mod =~ s/^.+\: no such device or address.*$//gim; 817 $slurp_mod =~ s/\n\n/\n/gm; 818 $slurp_mod =~ s/^\n+//gm; 819 $answer_matched = ($slurp_mod eq $answer_mod); 820 } 821 822 # VMS error message has a different case 823 if (!$answer_matched) { 824 $slurp_mod =~ s/no such file /No such file /gm; 825 $answer_matched = ($slurp_mod eq $answer_mod); 826 } 827 828 # VMS is putting comas instead of spaces in output 829 if (!$answer_matched) { 830 $slurp_mod =~ s/,/ /gm; 831 $answer_matched = ($slurp_mod eq $answer_mod); 832 } 833 834 # VMS Is sometimes adding extra leading spaces to output? 835 if (!$answer_matched) { 836 my $slurp_mod = $slurp_mod; 837 $slurp_mod =~ s/^ +//gm; 838 $answer_matched = ($slurp_mod eq $answer_mod); 839 } 840 841 # VMS port not handling POSIX encoded child status 842 # Translate error case it for now. 843 if (!$answer_matched) { 844 $slurp_mod =~ s/0x1035a00a/1/gim; 845 $answer_matched = 1 if $slurp_mod =~ /\Q$answer_mod\E/i; 846 847 } 848 if (!$answer_matched) { 849 $slurp_mod =~ s/0x1035a012/2/gim; 850 $answer_matched = ($slurp_mod eq $answer_mod); 851 } 852 853 # Tests are using a UNIX null command, temp hack 854 # until this can be handled by the VMS port. 855 # ticket # 41761 856 if (!$answer_matched) { 857 $slurp_mod =~ s/^.+DCL-W-NOCOMD.*$//gim; 858 $slurp_mod =~ s/\n\n+/\n/gm; 859 $slurp_mod =~ s/^\n+//gm; 860 $answer_matched = ($slurp_mod eq $answer_mod); 861 } 862 # Tests are using exit 0; 863 # this generates a warning that should stop the make, but does not 864 if (!$answer_matched) { 865 $slurp_mod =~ s/^.+NONAME-W-NOMSG.*$//gim; 866 $slurp_mod =~ s/\n\n+/\n/gm; 867 $slurp_mod =~ s/^\n+//gm; 868 $answer_matched = ($slurp_mod eq $answer_mod); 869 } 870 871 # VMS is sometimes adding single quotes to output? 872 if (!$answer_matched) { 873 my $noq_slurp_mod = $slurp_mod; 874 $noq_slurp_mod =~ s/\'//gm; 875 $answer_matched = ($noq_slurp_mod eq $answer_mod); 876 877 # And missing an extra space in output 878 if (!$answer_matched) { 879 $noq_answer_mod = $answer_mod; 880 $noq_answer_mod =~ s/\h\h+/ /gm; 881 $answer_matched = ($noq_slurp_mod eq $noq_answer_mod); 882 } 883 884 # VMS adding ; to end of some lines. 885 if (!$answer_matched) { 886 $noq_slurp_mod =~ s/;\n/\n/gm; 887 $answer_matched = ($noq_slurp_mod eq $noq_answer_mod); 888 } 889 890 # VMS adding trailing space to end of some quoted lines. 891 if (!$answer_matched) { 892 $noq_slurp_mod =~ s/\h+\n/\n/gm; 893 $answer_matched = ($noq_slurp_mod eq $noq_answer_mod); 894 } 895 896 # And VMS missing leading blank line 897 if (!$answer_matched) { 898 $noq_answer_mod =~ s/\A\n//g; 899 $answer_matched = ($noq_slurp_mod eq $noq_answer_mod); 900 } 901 902 # Unix double quotes showing up as single quotes on VMS. 903 if (!$answer_matched) { 904 $noq_answer_mod =~ s/\"//g; 905 $answer_matched = ($noq_slurp_mod eq $noq_answer_mod); 906 } 907 } 908 } 909 910 # If it still doesn't match, see if the answer might be a regex. 911 if (!$answer_matched && $answer =~ m,^/(.+)/$,) { 912 $answer_matched = ($slurp =~ /$1/); 913 if (!$answer_matched && $answer_mod =~ m,^/(.+)/$,) { 914 $answer_matched = ($slurp_mod =~ /$1/); 915 } 916 } 711 917 } 712 }713 918 } 714 919 … … 732 937 local($command) = "diff -c " . &get_basefile . " " . $logfile; 733 938 &run_command_with_output(&get_difffile,$command); 734 } else { 735 &rmfiles (); 736 } 737 738 $suite_passed = 0; 939 } 940 739 941 return 0; 740 942 } … … 756 958 } 757 959 960 my @OUTSTACK = (); 961 my @ERRSTACK = (); 962 758 963 sub attach_default_output 759 964 { … … 768 973 } 769 974 770 open ("SAVEDOS" . $default_output_stack_level . "out", ">&STDOUT") 771 || &error ("ado: $! duping STDOUT\n", 1); 772 open ("SAVEDOS" . $default_output_stack_level . "err", ">&STDERR") 773 || &error ("ado: $! duping STDERR\n", 1); 774 775 open (STDOUT, "> " . $filename) 776 || &error ("ado: $filename: $!\n", 1); 777 open (STDERR, ">&STDOUT") 778 || &error ("ado: $filename: $!\n", 1); 779 780 $default_output_stack_level++; 975 my $dup = undef; 976 open($dup, '>&', STDOUT) or error("ado: $! duping STDOUT\n", 1); 977 push @OUTSTACK, $dup; 978 979 $dup = undef; 980 open($dup, '>&', STDERR) or error("ado: $! duping STDERR\n", 1); 981 push @ERRSTACK, $dup; 982 983 open(STDOUT, '>', $filename) or error("ado: $filename: $!\n", 1); 984 open(STDERR, ">&STDOUT") or error("ado: $filename: $!\n", 1); 781 985 } 782 986 … … 795 999 } 796 1000 797 if (--$default_output_stack_level < 0) 798 { 799 &error ("default output stack has flown under!\n", 1); 800 } 801 802 close (STDOUT); 803 close (STDERR); 804 805 open (STDOUT, ">&SAVEDOS" . $default_output_stack_level . "out") 806 || &error ("ddo: $! duping STDOUT\n", 1); 807 open (STDERR, ">&SAVEDOS" . $default_output_stack_level . "err") 808 || &error ("ddo: $! duping STDERR\n", 1); 809 810 close ("SAVEDOS" . $default_output_stack_level . "out") 811 || &error ("ddo: $! closing SCSDOSout\n", 1); 812 close ("SAVEDOS" . $default_output_stack_level . "err") 813 || &error ("ddo: $! closing SAVEDOSerr\n", 1); 1001 @OUTSTACK or error("default output stack has flown under!\n", 1); 1002 1003 close(STDOUT); 1004 close(STDERR) unless $^O eq 'VMS'; 1005 1006 1007 open (STDOUT, '>&', pop @OUTSTACK) or error("ddo: $! duping STDOUT\n", 1); 1008 open (STDERR, '>&', pop @ERRSTACK) or error("ddo: $! duping STDERR\n", 1); 814 1009 } 815 1010 … … 825 1020 826 1021 eval { 827 local $SIG{ALRM} = sub { die "timeout\n"; }; 828 alarm $test_timeout; 829 $code = system(@_); 1022 if ($^O eq 'VMS') { 1023 local $SIG{ALRM} = sub { 1024 my $e = $ERRSTACK[0]; 1025 print $e "\nTest timed out after $test_timeout seconds\n"; 1026 die "timeout\n"; }; 1027 # alarm $test_timeout; 1028 system(@_); 1029 my $severity = ${^CHILD_ERROR_NATIVE} & 7; 1030 $code = 0; 1031 if (($severity & 1) == 0) { 1032 $code = 512; 1033 } 1034 1035 # Get the vms status. 1036 my $vms_code = ${^CHILD_ERROR_NATIVE}; 1037 1038 # Remove the print status bit 1039 $vms_code &= ~0x10000000; 1040 1041 # Posix code translation. 1042 if (($vms_code & 0xFFFFF000) == 0x35a000) { 1043 $code = (($vms_code & 0xFFF) >> 3) * 256; 1044 } 1045 } else { 1046 my $pid = fork(); 1047 if (! $pid) { 1048 exec(@_) or die "Cannot execute $_[0]\n"; 1049 } 1050 local $SIG{ALRM} = sub { my $e = $ERRSTACK[0]; print $e "\nTest timed out after $test_timeout seconds\n"; die "timeout\n"; }; 1051 alarm $test_timeout; 1052 waitpid($pid, 0) > 0 or die "No such pid: $pid\n"; 1053 $code = $?; 1054 } 830 1055 alarm 0; 831 1056 }; 832 1057 if ($@) { 833 1058 # The eval failed. If it wasn't SIGALRM then die. 834 $@ eq "timeout\n" or die ;1059 $@ eq "timeout\n" or die "Command failed: $@"; 835 1060 836 1061 # Timed out. Resend the alarm to our process group to kill the children. … … 851 1076 my $code = _run_command(@_); 852 1077 print "run_command returned $code.\n" if $debug; 853 1078 print "vms status = ${^CHILD_ERROR_NATIVE}\n" if $debug and $^O eq 'VMS'; 854 1079 return $code; 855 1080 } … … 866 1091 print "\nrun_command_with_output($filename,$runname): @_\n" if $debug; 867 1092 &attach_default_output ($filename); 868 my $code = _run_command(@_); 1093 my $code = eval { _run_command(@_) }; 1094 my $err = $@; 869 1095 &detach_default_output; 1096 1097 $err and die $err; 1098 870 1099 print "run_command_with_output returned $code.\n" if $debug; 871 1100 print "vms status = ${^CHILD_ERROR_NATIVE}\n" if $debug and $^O eq 'VMS'; 872 1101 return $code; 873 1102 } … … 929 1158 else 930 1159 { 931 unlink $object || return 0; 1160 if ($^O ne 'VMS') 1161 { 1162 unlink $object || return 0; 1163 } 1164 else 1165 { 1166 # VMS can have multiple versions of a file. 1167 1 while unlink $object; 1168 } 932 1169 } 933 1170 } … … 967 1204 foreach $file (@_) { 968 1205 (open(T, ">> $file") && print(T "\n") && close(T)) 969 1206 || &error("Couldn't touch $file: $!\n", 1); 970 1207 } 971 1208 }
Note:
See TracChangeset
for help on using the changeset viewer.
