diff options
| -rw-r--r-- | perl.c | 36 | ||||
| -rw-r--r-- | perl.h | 55 | ||||
| -rwxr-xr-x | t/op/die_exit.t | 25 | ||||
| -rwxr-xr-x | t/op/exec.t | 21 | ||||
| -rw-r--r-- | t/run/exit.t | 8 |
5 files changed, 99 insertions, 46 deletions
@@ -5262,22 +5262,34 @@ Perl_my_failure_exit(pTHX) */ if (MY_POSIX_EXIT) { - /* In POSIX_EXIT mode follow Perl documentations and use 255 for - * the exit code when there isn't an error. - */ + /* According to the die_exit.t tests, if errno is non-zero */ + /* It should be used for the error status. */ - if (STATUS_UNIX == 0) - STATUS_UNIX_EXIT_SET(255); - else { - STATUS_UNIX_EXIT_SET(STATUS_UNIX); + if (errno == EVMSERR) { + STATUS_NATIVE = vaxc$errno; + } else { - /* The exit code could have been set by $? or vmsish which - * means that it may not be fatal. So convert - * success/warning codes to fatal. - */ - if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) + /* According to die_exit.t tests, if the child_exit code is */ + /* also zero, then we need to exit with a code of 255 */ + if ((errno != 0) && (errno < 256)) + STATUS_UNIX_EXIT_SET(errno); + else if (STATUS_UNIX < 255) { STATUS_UNIX_EXIT_SET(255); + } + } + + /* The exit code could have been set by $? or vmsish which + * means that it may not have fatal set. So convert + * success/warning codes to fatal with out changing + * the POSIX status code. The severity makes VMS native + * status handling work, while UNIX mode programs use the + * the POSIX exit codes. + */ + if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) { + STATUS_NATIVE &= STS$M_COND_ID; + STATUS_NATIVE |= STS$K_ERROR | STS$M_INHIB_MSG; + } } else { /* Traditionally Perl on VMS always expects a Fatal Error. */ @@ -2933,11 +2933,11 @@ typedef pthread_key_t perl_key; } STMT_END /* STATUS_UNIX_EXIT_SET - Takes a UNIX/POSIX exit code and sets - * the NATIVE error status based on it. It does not assume that - * the UNIX/POSIX exit codes have any relationship to errno, except - * that 0 indicates a success. When in the default mode to comply - * with the Perl VMS documentation, any other code sets the NATIVE - * status to a failure code of SS$_ABORT. + * the NATIVE error status based on it. + * + * When in the default mode to comply with the Perl VMS documentation, + * 0 is a success and any other code sets the NATIVE status to a failure + * code of SS$_ABORT. * * In the new POSIX EXIT mode, native status will be set so that the * actual exit code will can be retrieved by the calling program or @@ -2951,30 +2951,31 @@ typedef pthread_key_t perl_key; STMT_START { \ I32 evalue = (I32)n; \ PL_statusvalue = evalue; \ - if (evalue != -1) { \ - if (evalue <= 0xFF00) { \ - if (evalue > 0xFF) \ - evalue = (evalue >> child_offset_bits) & 0xFF; \ - if (evalue == 0) \ - PL_statusvalue_vms == SS$_NORMAL; \ - else \ - if (MY_POSIX_EXIT) \ - PL_statusvalue_vms = \ - (C_FAC_POSIX | (evalue << 3 ) | \ - ((evalue == 1) ? (STS$K_ERROR | STS$M_INHIB_MSG) : 1)); \ - else \ - PL_statusvalue_vms = SS$_ABORT; \ - } else { /* forgive them Perl, for they have sinned */ \ - if (evalue != EVMSERR) PL_statusvalue_vms = evalue; \ - else PL_statusvalue_vms = vaxc$errno; \ - /* And obviously used a VMS status value instead of UNIX */ \ - PL_statusvalue = EVMSERR; \ - } \ - } \ - else PL_statusvalue_vms = SS$_ABORT; \ - set_vaxc_errno(PL_statusvalue_vms); \ + if (MY_POSIX_EXIT) { \ + if (evalue <= 0xFF00) { \ + if (evalue > 0xFF) \ + evalue = (evalue >> child_offset_bits) & 0xFF; \ + PL_statusvalue_vms = \ + (C_FAC_POSIX | (evalue << 3 ) | \ + ((evalue == 1) ? (STS$K_ERROR | STS$M_INHIB_MSG) : 1)); \ + } else /* forgive them Perl, for they have sinned */ \ + PL_statusvalue_vms = evalue; \ + } else { \ + if (evalue == 0) \ + PL_statusvalue_vms = SS$_NORMAL; \ + else if (evalue <= 0xFF00) \ + PL_statusvalue_vms = SS$_ABORT; \ + else { /* forgive them Perl, for they have sinned */ \ + if (evalue != EVMSERR) PL_statusvalue_vms = evalue; \ + else PL_statusvalue_vms = vaxc$errno; \ + /* And obviously used a VMS status value instead of UNIX */ \ + PL_statusvalue = EVMSERR; \ + } \ + set_vaxc_errno(PL_statusvalue_vms); \ + } \ } STMT_END + /* STATUS_EXIT_SET - Takes a NATIVE/UNIX/POSIX exit code * and sets the NATIVE error status based on it. This special case * is needed to maintain compatibility with past VMS behavior. diff --git a/t/op/die_exit.t b/t/op/die_exit.t index fedef945e1..4ee20d24bb 100755 --- a/t/op/die_exit.t +++ b/t/op/die_exit.t @@ -42,6 +42,25 @@ my %tests = ( my $max = keys %tests; +my $vms_exit_mode = 0; + +if ($^O eq 'VMS') { + if (eval 'require VMS::Feature') { + $vms_exit_mode = !(VMS::Feature::current("posix_exit")); + } else { + my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + my $env_posix_ex = $ENV{'PERL_VMS_POSIX_EXIT'} || ''; + my $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; + my $posix_ex = $env_posix_ex =~ /^[ET1]/i; + if (($unix_rpt || $posix_ex) ) { + $vms_exit_mode = 0; + } else { + $vms_exit_mode = 1; + } + } +} + + print "1..$max\n"; # Dump any error messages from the dying processes off to a temp file. @@ -58,9 +77,9 @@ foreach my $test (1 .. $max) { } my $exit = $?; - # VMS exit code 44 (SS$_ABORT) is returned if a program dies. We only get - # the severity bits, which boils down to 4. See L<perlvms/$?>. - $bang = 4 if $^O eq 'VMS'; + # The legacy VMS exit code 44 (SS$_ABORT) is returned if a program dies. + # We only get the severity bits, which boils down to 4. See L<perlvms/$?>. + $bang = 4 if $vms_exit_mode; printf "# 0x%04x 0x%04x 0x%04x\n", $exit, $bang, $query; print "not " unless $exit == (($bang || ($query >> 8) || 255) << 8); diff --git a/t/op/exec.t b/t/op/exec.t index c23364b29d..91821aa08e 100755 --- a/t/op/exec.t +++ b/t/op/exec.t @@ -6,6 +6,25 @@ BEGIN { require './test.pl'; } +my $vms_exit_mode = 0; + +if ($^O eq 'VMS') { + if (eval 'require VMS::Feature') { + $vms_exit_mode = !(VMS::Feature::current("posix_exit")); + } else { + my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + my $env_posix_ex = $ENV{'PERL_VMS_POSIX_EXIT'} || ''; + my $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; + my $posix_ex = $env_posix_ex =~ /^[ET1]/i; + if (($unix_rpt || $posix_ex) ) { + $vms_exit_mode = 0; + } else { + $vms_exit_mode = 1; + } + } +} + + # supress VMS whinging about bad execs. use vmsish qw(hushed); @@ -85,7 +104,7 @@ is( $echo_out, "ok\n", 'piped echo emulation'); is( system(qq{$Perl -e "exit 0"}), 0, 'Explicit exit of 0' ); -my $exit_one = $Is_VMS ? 4 << 8 : 1 << 8; +my $exit_one = $vms_exit_mode ? 4 << 8 : 1 << 8; is( system(qq{$Perl "-I../lib" -e "use vmsish qw(hushed); exit 1"}), $exit_one, 'Explicit exit of 1' ); diff --git a/t/run/exit.t b/t/run/exit.t index f59584cd8f..986afeaad4 100644 --- a/t/run/exit.t +++ b/t/run/exit.t @@ -27,8 +27,10 @@ if ($^O eq 'VMS') { if (eval 'require VMS::Feature') { $vms_exit_mode = !(VMS::Feature::current("posix_exit")); } else { - my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} =~ /^[ET1]/i; - my $posix_ex = $ENV{'PERL_VMS_POSIX_EXIT'} =~ /^[ET1]/i; + my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + my $env_posix_ex = $ENV{'PERL_VMS_POSIX_EXIT'} || ''; + my $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; + my $posix_ex = $env_posix_ex =~ /^[ET1]/i; if (($unix_rpt || $posix_ex) ) { $vms_exit_mode = 0; } else { @@ -149,7 +151,7 @@ if ($^O eq 'VMS') { $exit_arg = 42; $exit = run("END { \$? = $exit_arg }"); -# On VMS, in the child process the actual exit status will be SS$_ABORT, +# On VMS, in the child process the actual exit status will be SS$_ABORT, # or 44, which is what you get from any non-zero value of $? except for # 65535 that has been dePOSIXified by STATUS_UNIX_SET. If $? is set to # 65535 internally when there is a VMS status code that is valid, and |