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 (file)
--- 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 (file)
--- 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 (file)
--- 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;