perl.h and perl.c need further fixes to get VMS to return the expected
POSIX exit codes when that is enabled.
This fix gets the correct numbers except for the SIGTERM case, which
will need some more work.
It also gets the posix exit code to set an error severity on a fatal
exit so that DCL and MMS/MMK or VMS native programs can easily detect a
script failure.
This patch does not address an issue in vms.c where the feature logicals
may not be correctly read. That will follow in a future patch.
The tests have been adjusted to detect when VMS is in the POSIX exit
mode and perform properly.
-John
wb8...@gmail.com
--
My qsl.net e-mail address is temporarily out of order.
--- /rsync_root/perl/perl.c Wed Dec 31 01:55:07 2008
+++ perl.c Sat Jan 3 21:47:04 2009
@@ -5262,22 +5262,34 @@
*/
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. */
--- /rsync_root/perl/perl.h Fri Jan 2 04:03:12 2009
+++ perl.h Sat Jan 3 23:13:50 2009
@@ -2933,11 +2933,11 @@
} 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,29 +2951,30 @@
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
--- /rsync_root/perl/t/op/exec.t Tue Apr 17 12:13:08 2007
+++ t/op/exec.t Fri Nov 21 22:41:02 2008
@@ -6,6 +6,25 @@
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( 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' );
--- /rsync_root/perl/t/op/die_exit.t Tue Jun 13 14:29:32 2006
+++ t/op/die_exit.t Sat Jan 3 17:12:02 2009
@@ -42,6 +42,25 @@
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 @@
}
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);
--- /rsync_root/perl/t/run/exit.t Mon Nov 10 06:51:29 2008
+++ t/run/exit.t Mon Nov 17 23:36:16 2008
@@ -27,8 +27,10 @@
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 @@
$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
