From: John E. Malmberg <wb8tyw@qsl.net>
Date: Mon, 24 Oct 2005 01:34:41 +0000 (-0400)
Subject: VMS exit handling still broken, need some help.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0968cdad220f9ff42abaf7f92b7d3731a578e46d;p=p5sagit%2Fp5-mst-13.2.git

VMS exit handling still broken, need some help.
From: "John E. Malmberg" <wb8tyw@qsl.net>
Message-ID: <435C7271.8070403@qsl.net>

p4raw-id: //depot/perl@25839
---

diff --git a/perl.c b/perl.c
index e335432..be0f4b4 100644
--- a/perl.c
+++ b/perl.c
@@ -5166,15 +5166,57 @@ Perl_my_failure_exit(pTHX)
 #ifdef VMS
      /* We have been called to fall on our sword.  The desired exit code
       * should be already set in STATUS_UNIX, but could be shifted over
-      * by 8 bits.  STATUS_UNIX_EXIT_SET will fix all cases where
-      * an error code has been set.
+      * by 8 bits.  STATUS_UNIX_EXIT_SET will handle the cases where a
+      * that code is set.
       *
       * If an error code has not been set, then force the issue.
       */
-    if (STATUS_UNIX == 0)   /* No errors or status recorded? */
-	STATUS_ALL_FAILURE; /* Ok, force the issue with a generic code */
-    else
-      STATUS_UNIX_EXIT_SET(STATUS_UNIX);
+    if (MY_POSIX_EXIT) {
+
+	/* In POSIX_EXIT mode follow Perl documentations and use 255 for
+	 * the exit code when there isn't an error.
+	 */
+
+	if (STATUS_UNIX == 0)
+	    STATUS_UNIX_EXIT_SET(255);
+	else {
+	    STATUS_UNIX_EXIT_SET(STATUS_UNIX);
+
+	    /* 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)
+		STATUS_UNIX_EXIT_SET(255);
+	}
+    }
+    else {
+	/* Traditionally Perl on VMS always expects a Fatal Error. */
+	if (vaxc$errno & 1) {
+
+	    /* So force success status to failure */
+	    if (STATUS_NATIVE & 1)
+		STATUS_ALL_FAILURE;
+	}
+	else {
+	    if (!vaxc$errno) {
+		STATUS_UNIX = EINTR; /* In case something cares */
+		STATUS_ALL_FAILURE;
+	    }
+	    else {
+		int severity;
+		STATUS_NATIVE = vaxc$errno; /* Should already be this */
+
+		/* Encode the severity code */
+		severity = STATUS_NATIVE & STS$M_SEVERITY;
+		STATUS_UNIX = (severity ? severity : 1) << 8;
+
+		/* Perl expects this to be a fatal error */
+		if (severity != STS$K_SEVERE)
+		    STATUS_ALL_FAILURE;
+	    }
+	}
+    }
 
 #else
     int exitstatus;
diff --git a/perl.h b/perl.h
index 28d2ad8..5a2a771 100644
--- a/perl.h
+++ b/perl.h
@@ -2642,26 +2642,28 @@ typedef pthread_key_t	perl_key;
 #   define STATUS_UNIX_SET(n)				\
 	STMT_START {					\
 	    I32 evalue = (I32)n;			\
-	    PL_statusvalue = evalue;				\
+	    PL_statusvalue = evalue;			\
 	    if (PL_statusvalue != -1) {			\
-		if (PL_statusvalue != EVMSERR) {		\
-		  PL_statusvalue &= 0xFFFF;			\
-		  PL_statusvalue_vms = Perl_unix_status_to_vms(evalue); \
-		}						\
-		else {						\
-		  PL_statusvalue_vms = vaxc$errno;		\
-		}						\
+		if (PL_statusvalue != EVMSERR) {	\
+		  PL_statusvalue &= 0xFFFF;		\
+		  if (MY_POSIX_EXIT)			\
+		    PL_statusvalue_vms=PL_statusvalue ? SS$_ABORT : SS$_NORMAL;\
+		  else PL_statusvalue_vms = Perl_unix_status_to_vms(evalue); \
+		}					\
+		else {					\
+		  PL_statusvalue_vms = vaxc$errno;	\
+		}					\
 	    }						\
-	    else PL_statusvalue_vms = SS$_ABORT;		\
-	    set_vaxc_errno(evalue);				\
+	    else PL_statusvalue_vms = SS$_ABORT;	\
+	    set_vaxc_errno(PL_statusvalue_vms);		\
 	} 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, anything other than 0 indicates
-   * a native status should be set to the failure code SS$_ABORT;
+   * with the Perl VMS documentation, status of one is set to the
+   * failure code of SS$_ABORT.  Any other number is passed through.
    *
    * 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
@@ -2686,7 +2688,8 @@ typedef pthread_key_t	perl_key;
 		    PL_statusvalue_vms =	\
 		       (C_FAC_POSIX | (evalue << 3 ) | (evalue == 1)? \
 		        (STS$K_ERROR | STS$M_INHIB_MSG) : 0); \
-		  else PL_statusvalue_vms = SS$_ABORT; \
+		  else					\
+		    PL_statusvalue_vms = (evalue == 1)? SS$_ABORT : evalue; \
 	      } else { /* forgive them Perl, for they have sinned */ \
 		if (evalue != EVMSERR) PL_statusvalue_vms = evalue; \
 		else PL_statusvalue_vms = vaxc$errno;		\
diff --git a/vms/vms.c b/vms/vms.c
index 6110a97..0f3d3d5 100644
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -1821,7 +1821,7 @@ int unix_status;
   fac_sp = vms_status & STS$M_FAC_SP;
   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
 
-  if ((facility == 0) || (fac_sp == 0)  && (child_flag == 0)) {
+  if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
     switch(msg_no) {
     case SS$_NORMAL:
 	unix_status = 0;
@@ -2025,7 +2025,7 @@ int test_unix_status;
     case EACCES: return SS$_FILACCERR;
     case EFAULT: return SS$_ACCVIO;
     /* case ENOTBLK */
-    case EBUSY: SS$_DEVOFFLINE;
+    case EBUSY: return SS$_DEVOFFLINE;
     case EEXIST: return RMS$_FEX;
     /* case EXDEV */
     case ENODEV: return SS$_NOSUCHDEV;