Commit | Line | Data |
---|---|---|
9b599b2a GS |
1 | #!./perl |
2 | ||
3 | # | |
4 | # Verify that C<die> return the return code | |
5 | # -- Robin Barker <rmb@cise.npl.co.uk> | |
6 | # | |
7 | ||
8 | BEGIN { | |
9 | chdir 't' if -d 't'; | |
20822f61 | 10 | @INC = '../lib'; |
9b599b2a | 11 | } |
0994c4d0 JH |
12 | |
13 | if ($^O eq 'mpeix') { | |
14 | print "1..0 # Skip: broken on MPE/iX\n"; | |
15 | exit 0; | |
16 | } | |
17 | ||
0ecd3ba2 MG |
18 | $| = 1; |
19 | ||
9b599b2a GS |
20 | use strict; |
21 | ||
22 | my %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], | |
df0bd2f4 | 39 | # see if implicit close preserves $? |
a8710ca1 | 40 | 17 => [ 0, 512, '{ local *F; open F, q[TEST]; close F; $!=0 } die;'], |
9b599b2a GS |
41 | ); |
42 | ||
43 | my $max = keys %tests; | |
44 | ||
45 | print "1..$max\n"; | |
46 | ||
ffbead30 MS |
47 | # Dump any error messages from the dying processes off to a temp file. |
48 | open(STDERR, ">die_exit.err") or die "Can't open temp error file: $!"; | |
49 | ||
9b599b2a | 50 | foreach my $test (1 .. $max) { |
df0bd2f4 GS |
51 | my($bang, $query, $code) = @{$tests{$test}}; |
52 | $code ||= 'die;'; | |
ffbead30 MS |
53 | if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') { |
54 | system(qq{$^X -e "\$! = $bang; \$? = $query; $code"}); | |
55 | } | |
56 | else { | |
57 | system(qq{$^X -e '\$! = $bang; \$? = $query; $code'}); | |
58 | } | |
59 | my $exit = $?; | |
60 | ||
61 | # VMS exit code 44 (SS$_ABORT) is returned if a program dies. We only get | |
62 | # the severity bits, which boils down to 4. See L<perlvms/$?>. | |
63 | $bang = 4 if $^O eq 'VMS'; | |
9b599b2a | 64 | |
d289e7db GS |
65 | printf "# 0x%04x 0x%04x 0x%04x\n", $exit, $bang, $query; |
66 | print "not " unless $exit == (($bang || ($query >> 8) || 255) << 8); | |
9b599b2a GS |
67 | print "ok $test\n"; |
68 | } | |
69 | ||
ffbead30 MS |
70 | close STDERR; |
71 | END { 1 while unlink 'die_exit.err' } | |
72 |