Changeset 3138 in kBuild for vendor/gnumake/current/tests/test_driver.pl
- Timestamp:
- Mar 12, 2018 7:32:29 PM (7 years ago)
- File:
-
- 1 edited
-
vendor/gnumake/current/tests/test_driver.pl (modified) (29 diffs)
Legend:
- Unmodified
- Added
- Removed
-
vendor/gnumake/current/tests/test_driver.pl
r2596 r3138 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(); … … 132 179 &parse_command_line (@ARGV); 133 180 134 print "OS name = `$osname'\n" if $debug;181 print "OS name = '$osname'\n" if $debug; 135 182 136 183 $workpath = "$cwdslash$workdir"; … … 140 187 141 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 } 142 208 143 209 if (-d $workpath) … … 167 233 push (@rmdirs, $dir); 168 234 -d "$workpath/$dir" 169 235 || mkdir ("$workpath/$dir", 0777) 170 236 || &error ("Couldn't mkdir $workpath/$dir: $!\n"); 171 237 } … … 176 242 print "Finding tests...\n"; 177 243 opendir (SCRIPTDIR, $scriptpath) 178 244 || &error ("Couldn't opendir $scriptpath: $!\n"); 179 245 @dirs = grep (!/^(\..*|CVS|RCS)$/, readdir (SCRIPTDIR) ); 180 246 closedir (SCRIPTDIR); … … 183 249 next if ($dir =~ /^(\..*|CVS|RCS)$/ || ! -d "$scriptpath/$dir"); 184 250 push (@rmdirs, $dir); 251 # VMS can have overlayed file systems, so directories may repeat. 252 next if -d "$workpath/$dir"; 185 253 mkdir ("$workpath/$dir", 0777) 186 254 || &error ("Couldn't mkdir $workpath/$dir: $!\n"); 187 255 opendir (SCRIPTDIR, "$scriptpath/$dir") 188 256 || &error ("Couldn't opendir $scriptpath/$dir: $!\n"); 189 257 @files = grep (!/^(\..*|CVS|RCS|.*~)$/, readdir (SCRIPTDIR) ); 190 258 closedir (SCRIPTDIR); … … 192 260 { 193 261 -d $test and next; 194 262 push (@TESTS, "$dir/$test"); 195 263 } 196 264 } … … 204 272 print "\n"; 205 273 206 &run_each_test;274 run_all_tests(); 207 275 208 276 foreach $dir (@rmdirs) … … 222 290 print " in $categories_failed Categor"; 223 291 print ($categories_failed == 1 ? "y" : "ies"); 224 print " Failed (See .$diffext files in $workdir dir for details) :-(\n\n";292 print " Failed (See .$diffext* files in $workdir dir for details) :-(\n\n"; 225 293 return 0; 226 294 } … … 241 309 $osname = defined($^O) ? $^O : ''; 242 310 311 if ($osname eq 'VMS') 312 { 313 $vos = 0; 314 $pathsep = "/"; 315 return; 316 } 317 243 318 # Find a path to Perl 244 319 … … 277 352 if ($osname =~ /not found/i) 278 353 { 279 354 $osname = "(something posixy with no uname)"; 280 355 } 281 356 elsif ($@ ne "" || $?) … … 284 359 if ($@ ne "" || $?) 285 360 { 286 287 361 $osname = "(something posixy)"; 362 } 288 363 } 289 364 $vos = 0; … … 417 492 } 418 493 419 sub run_each_test 420 { 421 $categories_run = 0; 422 423 foreach $testname (sort @TESTS) 424 { 425 ++$categories_run; 426 $suite_passed = 1; # reset by test on failure 427 $num_of_logfiles = 0; 428 $num_of_tmpfiles = 0; 429 $description = ""; 430 $details = ""; 431 $old_makefile = undef; 432 $testname =~ s/^$scriptpath$pathsep//; 433 $perl_testname = "$scriptpath$pathsep$testname"; 434 $testname =~ s/(\.pl|\.perl)$//; 435 $testpath = "$workpath$pathsep$testname"; 436 # Leave enough space in the extensions to append a number, even 437 # though it needs to fit into 8+3 limits. 438 if ($short_filenames) { 439 $logext = 'l'; 440 $diffext = 'd'; 441 $baseext = 'b'; 442 $runext = 'r'; 443 $extext = ''; 444 } else { 445 $logext = 'log'; 446 $diffext = 'diff'; 447 $baseext = 'base'; 448 $runext = 'run'; 449 $extext = '.'; 450 } 451 $log_filename = "$testpath.$logext"; 452 $diff_filename = "$testpath.$diffext"; 453 $base_filename = "$testpath.$baseext"; 454 $run_filename = "$testpath.$runext"; 455 $tmp_filename = "$testpath.$tmpfilesuffix"; 456 457 &setup_for_test; # suite-defined 458 459 $output = "........................................................ "; 460 461 substr($output,0,length($testname)) = "$testname "; 462 463 print $output; 464 465 # Run the actual test! 466 $tests_run = 0; 467 $tests_passed = 0; 468 469 $code = do $perl_testname; 470 471 $total_tests_run += $tests_run; 472 $total_tests_passed += $tests_passed; 473 474 # How did it go? 475 if (!defined($code)) 476 { 477 $suite_passed = 0; 478 if (length ($@)) { 479 warn "\n*** Test died ($testname): $@\n"; 480 } else { 481 warn "\n*** Couldn't run $perl_testname\n"; 482 } 483 } 484 elsif ($code == -1) { 485 $suite_passed = 0; 486 } 487 elsif ($code != 1 && $code != -1) { 488 $suite_passed = 0; 489 warn "\n*** Test returned $code\n"; 490 } 491 492 if ($suite_passed) { 493 ++$categories_passed; 494 $status = "ok ($tests_passed passed)"; 495 for ($i = $num_of_tmpfiles; $i; $i--) 496 { 497 &rmfiles ($tmp_filename . &num_suffix ($i) ); 498 } 499 500 for ($i = $num_of_logfiles ? $num_of_logfiles : 1; $i; $i--) 501 { 502 &rmfiles ($log_filename . &num_suffix ($i) ); 503 &rmfiles ($base_filename . &num_suffix ($i) ); 504 } 505 } 506 elsif (!defined $code || $code > 0) { 507 $status = "FAILED ($tests_passed/$tests_run passed)"; 508 } 509 elsif ($code < 0) { 510 $status = "N/A"; 511 --$categories_run; 512 } 513 514 # If the verbose option has been specified, then a short description 515 # of each test is printed before displaying the results of each test 516 # describing WHAT is being tested. 517 518 if ($verbose) 519 { 520 if ($detail) 521 { 522 print "\nWHAT IS BEING TESTED\n"; 523 print "--------------------"; 524 } 525 print "\n\n$description\n\n"; 526 } 527 528 # If the detail option has been specified, then the details of HOW 529 # the test is testing what it says it is testing in the verbose output 530 # will be displayed here before the results of the test are displayed. 531 532 if ($detail) 533 { 534 print "\nHOW IT IS TESTED\n"; 535 print "----------------"; 536 print "\n\n$details\n\n"; 537 } 538 539 print "$status\n"; 540 } 494 sub 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 } 541 626 } 542 627 … … 655 740 local($slurp, $answer_matched) = ('', 0); 656 741 657 print "Comparing Output ........ " if $debug;658 659 $slurp = &read_file_into_string ($logfile);660 661 # For make, get rid of any time skew error before comparing--too bad this662 # has to go into the "generic" driver code :-/663 $slurp =~ s/^.*modification time .*in the future.*\n//gm;664 $slurp =~ s/^.*Clock skew detected.*\n//gm;665 666 742 ++$tests_run; 667 743 668 if ($slurp eq $answer) { 669 $answer_matched = 1; 744 if (! defined $answer) { 745 print "Ignoring output ........ " if $debug; 746 $answer_matched = 1; 670 747 } else { 671 # See if it is a slash or CRLF problem 672 local ($answer_mod, $slurp_mod) = ($answer, $slurp); 673 674 $answer_mod =~ tr,\\,/,; 675 $answer_mod =~ s,\r\n,\n,gs; 676 677 $slurp_mod =~ tr,\\,/,; 678 $slurp_mod =~ s,\r\n,\n,gs; 679 680 $answer_matched = ($slurp_mod eq $answer_mod); 681 682 # If it still doesn't match, see if the answer might be a regex. 683 if (!$answer_matched && $answer =~ m,^/(.+)/$,) { 684 $answer_matched = ($slurp =~ /$1/); 685 if (!$answer_matched && $answer_mod =~ m,^/(.+)/$,) { 686 $answer_matched = ($slurp_mod =~ /$1/); 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 } 687 893 } 688 }689 894 } 690 895 … … 708 913 local($command) = "diff -c " . &get_basefile . " " . $logfile; 709 914 &run_command_with_output(&get_difffile,$command); 710 } else { 711 &rmfiles (); 712 } 713 714 $suite_passed = 0; 915 } 916 715 917 return 0; 716 918 } … … 732 934 } 733 935 936 my @OUTSTACK = (); 937 my @ERRSTACK = (); 938 734 939 sub attach_default_output 735 940 { … … 744 949 } 745 950 746 open ("SAVEDOS" . $default_output_stack_level . "out", ">&STDOUT") 747 || &error ("ado: $! duping STDOUT\n", 1); 748 open ("SAVEDOS" . $default_output_stack_level . "err", ">&STDERR") 749 || &error ("ado: $! duping STDERR\n", 1); 750 751 open (STDOUT, "> " . $filename) 752 || &error ("ado: $filename: $!\n", 1); 753 open (STDERR, ">&STDOUT") 754 || &error ("ado: $filename: $!\n", 1); 755 756 $default_output_stack_level++; 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); 757 961 } 758 962 … … 771 975 } 772 976 773 if (--$default_output_stack_level < 0) 774 { 775 &error ("default output stack has flown under!\n", 1); 776 } 777 778 close (STDOUT); 779 close (STDERR); 780 781 open (STDOUT, ">&SAVEDOS" . $default_output_stack_level . "out") 782 || &error ("ddo: $! duping STDOUT\n", 1); 783 open (STDERR, ">&SAVEDOS" . $default_output_stack_level . "err") 784 || &error ("ddo: $! duping STDERR\n", 1); 785 786 close ("SAVEDOS" . $default_output_stack_level . "out") 787 || &error ("ddo: $! closing SCSDOSout\n", 1); 788 close ("SAVEDOS" . $default_output_stack_level . "err") 789 || &error ("ddo: $! closing SAVEDOSerr\n", 1); 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); 790 985 } 791 986 … … 801 996 802 997 eval { 803 local $SIG{ALRM} = sub { die "timeout\n"; }; 804 alarm $test_timeout; 805 $code = system(@_); 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 } 806 1031 alarm 0; 807 1032 }; 808 1033 if ($@) { 809 1034 # The eval failed. If it wasn't SIGALRM then die. 810 $@ eq "timeout\n" or die ;1035 $@ eq "timeout\n" or die "Command failed: $@"; 811 1036 812 1037 # Timed out. Resend the alarm to our process group to kill the children. … … 827 1052 my $code = _run_command(@_); 828 1053 print "run_command returned $code.\n" if $debug; 829 1054 print "vms status = ${^CHILD_ERROR_NATIVE}\n" if $debug and $^O eq 'VMS'; 830 1055 return $code; 831 1056 } … … 842 1067 print "\nrun_command_with_output($filename,$runname): @_\n" if $debug; 843 1068 &attach_default_output ($filename); 844 my $code = _run_command(@_); 1069 my $code = eval { _run_command(@_) }; 1070 my $err = $@; 845 1071 &detach_default_output; 1072 1073 $err and die $err; 1074 846 1075 print "run_command_with_output returned $code.\n" if $debug; 847 1076 print "vms status = ${^CHILD_ERROR_NATIVE}\n" if $debug and $^O eq 'VMS'; 848 1077 return $code; 849 1078 } … … 905 1134 else 906 1135 { 907 unlink $object || return 0; 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 } 908 1145 } 909 1146 } … … 943 1180 foreach $file (@_) { 944 1181 (open(T, ">> $file") && print(T "\n") && close(T)) 945 1182 || &error("Couldn't touch $file: $!\n", 1); 946 1183 } 947 1184 }
Note:
See TracChangeset
for help on using the changeset viewer.
