VMS posix exit fixes

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
wb8tyw@gmail.com
--
My qsl.net e-mail address is temporarily out of order.

5 files changed, 99 insertions, 46 deletions

diff --git a/perl.c b/perl.c
index 9091f2fcb4..99a5ce2a45 100644
--- a/perl.c
+++ b/perl.c
@@ -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. */
diff --git a/perl.h b/perl.h
index 13de9050e7..45d0e1d9ba 100644
--- a/perl.h
+++ b/perl.h
@@ -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