1#!./perl 2 3# 4# Verify that C<die> return the return code 5# -- Robin Barker <rmb@cise.npl.co.uk> 6# 7 8BEGIN { 9 chdir 't' if -d 't'; 10 @INC = '../lib'; 11} 12 13if ($^O eq 'mpeix') { 14 print "1..0 # Skip: broken on MPE/iX\n"; 15 exit 0; 16} 17 18$| = 1; 19 20use strict; 21 22my %tests = ( 23 1 => [ 0, 0], 24 2 => [ 0, 1], 25 3 => [ 0, 127], 26 4 => [ 0, 128], 27 5 => [ 0, 255], 28 6 => [ 0, 256], 29 7 => [ 0, 512], 30 8 => [ 1, 0], 31 9 => [ 1, 1], 32 10 => [ 1, 256], 33 11 => [ 128, 0], 34 12 => [ 128, 1], 35 13 => [ 128, 256], 36 14 => [ 255, 0], 37 15 => [ 255, 1], 38 16 => [ 255, 256], 39 # see if implicit close preserves $? 40 17 => [ 0, 512, '{ local *F; open F, q[TEST]; close F; $!=0 } die;'], 41); 42 43my $max = keys %tests; 44 45my $vms_exit_mode = 0; 46 47if ($^O eq 'VMS') { 48 if (eval 'require VMS::Feature') { 49 $vms_exit_mode = !(VMS::Feature::current("posix_exit")); 50 } else { 51 my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; 52 my $env_posix_ex = $ENV{'PERL_VMS_POSIX_EXIT'} || ''; 53 my $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; 54 my $posix_ex = $env_posix_ex =~ /^[ET1]/i; 55 if (($unix_rpt || $posix_ex) ) { 56 $vms_exit_mode = 0; 57 } else { 58 $vms_exit_mode = 1; 59 } 60 } 61} 62 63 64print "1..$max\n"; 65 66# Dump any error messages from the dying processes off to a temp file. 67open(STDERR, ">die_exit.err") or die "Can't open temp error file: $!"; 68 69foreach my $test (1 .. $max) { 70 my($bang, $query, $code) = @{$tests{$test}}; 71 $code ||= 'die;'; 72 if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') { 73 system(qq{$^X -e "\$! = $bang; \$? = $query; $code"}); 74 } 75 else { 76 system(qq{$^X -e '\$! = $bang; \$? = $query; $code'}); 77 } 78 my $exit = $?; 79 80 # The legacy VMS exit code 44 (SS$_ABORT) is returned if a program dies. 81 # We only get the severity bits, which boils down to 4. See L<perlvms/$?>. 82 $bang = 4 if $vms_exit_mode; 83 84 printf "# 0x%04x 0x%04x 0x%04x\n", $exit, $bang, $query; 85 print "not " unless $exit == (($bang || ($query >> 8) || 255) << 8); 86 print "ok $test\n"; 87} 88 89close STDERR; 90END { 1 while unlink 'die_exit.err' } 91 92