Reworked, retested, and resubmitted.
In perl.c:
In the routine Perl_my_exit, use the new macro STATUS_UNIX_EXIT_SET to
set the native and UNIX exit codes correctly.
In perl.h:
Fix STATUS_... macros to handle both the encoded POSIX exit codes and
traditional documented VMS EXIT code handling behavior.
Added support to determine if VMS is to pass through codes 1-255 or to
encoded them as per the C library _POSIX_EXIT compile time setting.
Corrected the encoding of the _POSIX_EXIT exit codes when that mode is
selected to match what the C library would have done.
Added new STATUS_UNIX_EXIT_SET to correctly set the VMS exit status.
Make sure that vaxc$errno is updated when Pl_statusvalue_vms is set.
In t/run/exit.t:
Fix tests that I broke in a previous change to verify documented vms
exit behavior.
Add tests to verify that the cases of POSIX exit codes 1 and 255 were
both decoded correctly.
In vms/vmsish.h:
Add posix_exit member to interp_intern, and expose it with MY_POSIX_EXIT
macro.
Add prototypes for Perl_unix_status_to_vms, and Perl_vms_status_to_unix.
Rename vms_status_to_unix to Perl_vms_status_to_unix per perl naming
conventions.
In vms/vms.c
Minor edit to simplify when the routine set_feature_default is
conditionally compiled in.
Update Perl_my_kill() replacement routine to handle signal value 0 as
expected. Fix up so that vaxc$errno and errno are both updated on
error. Return unsupported for pid values of 0 or less.
Rename vms_status_to_unix to Perl_vms_status_to_unix, and add child_flag
parameter to distinguish between decoding a child status and a parent
status.
Fixed the decoding of the POSIX status values.
Updated Perl_vms_status_to_unix to handle more mappings used internal to
Perl.
Add routine Perl_unix_status_to_vms to handle the cases where Perl is
forcing errno to a specific status.
Todo:
Somewhere should be a test that verifies the behavior of Perl for signal
== 0 as apparently it was not noticed that it was not working on VMS.
Along with other things, need a method where Perl on VMS can
read/optionally set if is automatically encoding exit statuses in a
_POSIX_EXIT mode.
Upcoming:
I have a significant edit to vms.c/vmsish.h to follow this in a short
bit to add the first phase of the symbolic link support.
The second phase requires me to add a version of rmsexpand that uses
naml$ blocks instead of nam$ blocks on the versions of VMS that support
naml$ blocks.
-John
[EMAIL PROTECTED]
Personal Opinion Only
--- /rsync_root/perl/perl.c Thu Oct 13 20:01:44 2005
+++ perl.c Sat Oct 15 10:30:20 2005
@@ -5155,7 +5155,7 @@
STATUS_ALL_FAILURE;
break;
default:
- STATUS_UNIX_SET(status);
+ STATUS_UNIX_EXIT_SET(status);
break;
}
my_exit_jump();
--- /rsync_root/perl/perl.h Wed Oct 5 12:03:27 2005
+++ perl.h Sun Oct 16 01:44:11 2005
@@ -2545,49 +2545,133 @@
#define STATUS_UNIX PL_statusvalue
#ifdef VMS
# define STATUS_NATIVE PL_statusvalue_vms
+/*
+ * vaxc$errno is only guaranteed to be valid if errno == EVMSERR, otherwise
+ * it's contents can not be trusted. Unfortunately, Perl seems to check
+ * it on exit, so it when PL_statusvalue_vms is updated, vaxc$errno should
+ * be updated also.
+ */
+# include <stsdef.h>
+# include <ssdef.h>
+/* Presume this because if VMS changes it, it will require a new
+ * set of APIs for waiting on children for binary compatibility.
+ */
+# define child_offset_bits (8)
+# ifndef C_FAC_POSIX
+# define C_FAC_POSIX 0x35A000
+# endif
+
+/* STATUS_EXIT - validates and returns a NATIVE exit status code for the
+ * platform from the existing UNIX or Native status values.
+ */
+
# define STATUS_EXIT \
- (((I32)PL_statusvalue_vms == -1 ? 44 : PL_statusvalue_vms) |
(VMSISH_HUSHED ? 0x10000000 : 0))
+ (((I32)PL_statusvalue_vms == -1 ? SS$_ABORT : PL_statusvalue_vms) | \
+ (VMSISH_HUSHED ? STS$M_INHIB_MSG : 0))
+
+/* STATUS_NATIVE_SET - takes a NATIVE status code and converts it to a
+ * UNIX/POSIX status value and updates both the native and PL_statusvalue
+ * as needed. This currently seems only exist for VMS and is used in the exit
+ * handling.
+ */
+
# define STATUS_NATIVE_SET(n) STATUS_NATIVE_SET_PORC(n, 0)
+
+/* STATUS_NATIVE_CHILD_SET - same as STATUS_NATIVE_SET, but shifts the UNIX
+ * value over the correct number of bits to be a child status. Usually
+ * the number of bits is 8, but that could be platform dependent. The NATIVE
+ * status code is presumed to have either from a child process.
+ */
+
# define STATUS_NATIVE_CHILD_SET(n) STATUS_NATIVE_SET_PORC(n, 1)
+
+ /* internal convert VMS status codes to UNIX error or status codes */
# define STATUS_NATIVE_SET_PORC(n, _x) \
STMT_START { \
I32 evalue = (I32)n; \
if (evalue == EVMSERR) { \
PL_statusvalue_vms = vaxc$errno; \
PL_statusvalue = evalue; \
- } \
- else { \
+ } else { \
PL_statusvalue_vms = evalue; \
- if ((I32)PL_statusvalue_vms == -1) \
+ if ((I32)PL_statusvalue_vms == -1) { \
PL_statusvalue = -1; \
- else \
- PL_statusvalue = vms_status_to_unix(evalue); \
+ PL_statusvalue_vms = SS$_ABORT; /* Should not happen */ \
+ } else \
+ PL_statusvalue = Perl_vms_status_to_unix(evalue, _x); \
set_vaxc_errno(evalue); \
set_errno(PL_statusvalue); \
- if (_x) PL_statusvalue = PL_statusvalue << 8; \
+ if (_x) PL_statusvalue = PL_statusvalue << child_offset_bits; \
} \
} STMT_END
+
# ifdef VMSISH_STATUS
# define STATUS_CURRENT (VMSISH_STATUS ? STATUS_NATIVE : STATUS_UNIX)
# else
# define STATUS_CURRENT STATUS_UNIX
# endif
+
+ /* STATUS_UNIX_SET - takes a UNIX/POSIX errno value and attempts to update
+ * the NATIVE status to an equivalent value. Can not be used to translate
+ * exit code values as exit code values are not guaranteed to have any
+ * relationship at all to errno values.
+ * This is used when Perl is forcing errno to have a specific value.
+ */
# define STATUS_UNIX_SET(n) \
STMT_START { \
- PL_statusvalue = (n); \
+ I32 evalue = (I32)n; \
+ PL_statusvalue = evalue; \
if (PL_statusvalue != -1) { \
if (PL_statusvalue != EVMSERR) { \
PL_statusvalue &= 0xFFFF; \
- PL_statusvalue_vms = PL_statusvalue ? 44 : 1; \
+ PL_statusvalue_vms = Perl_unix_status_to_vms(evalue); \
} \
else { \
PL_statusvalue_vms = vaxc$errno; \
} \
} \
- else PL_statusvalue_vms = -1; \
+ else PL_statusvalue_vms = SS$_ABORT; \
+ set_vaxc_errno(evalue); \
+ } 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
+ * values and are only being encoded into the NATIVE form so
+ * that they can be properly passed through to the calling
+ * program or shell.
+ */
+
+# define STATUS_UNIX_EXIT_SET(n) \
+ STMT_START { \
+ I32 evalue = (I32)n; \
+ PL_statusvalue = evalue; \
+ if (PL_statusvalue != -1) { \
+ if (PL_statusvalue != EVMSERR) { \
+ if (PL_statusvalue < 256) { \
+ if (PL_statusvalue == 0) \
+ PL_statusvalue_vms == SS$_NORMAL; \
+ else \
+ PL_statusvalue_vms = MY_POSIX_EXIT ? \
+ (C_FAC_POSIX | (evalue << 3 ) | (evalue == 1)? \
+ (STS$K_ERROR | STS$M_INHIB_MSG) : 0) : evalue; \
+ } else { /* forgive them Perl, for they have sinned */ \
+ PL_statusvalue_vms = evalue; \
+ } /* And obviously used a VMS status value instead of UNIX
*/ \
+ PL_statusvalue = EVMSERR; \
+ } \
+ else { \
+ PL_statusvalue_vms = vaxc$errno; \
+ } \
+ } \
+ else PL_statusvalue_vms = SS$_ABORT; \
+ set_vaxc_errno(PL_statusvalue_vms); \
} STMT_END
-# define STATUS_ALL_SUCCESS (PL_statusvalue = 0, PL_statusvalue_vms = 1)
-# define STATUS_ALL_FAILURE (PL_statusvalue = 1, PL_statusvalue_vms = 44)
+# define STATUS_ALL_SUCCESS \
+ (PL_statusvalue = 0, PL_statusvalue_vms = SS$_NORMAL)
+# define STATUS_ALL_FAILURE (PL_statusvalue = 1, \
+ vaxc$errno = PL_statusvalue_vms = MY_POSIX_EXIT ? \
+ (C_FAC_POSIX | (1 << 3) | STS$K_ERROR | STS$M_INHIB_MSG) : SS$_ABORT)
#else
# define STATUS_NATIVE PL_statusvalue_posix
# if defined(WCOREDUMP)
@@ -2633,6 +2717,7 @@
if (PL_statusvalue != -1) \
PL_statusvalue &= 0xFFFF; \
} STMT_END
+# define STATUS_UNIX_EXIT_SET(n) STATUS_UNIX_SET(n)
# define STATUS_CURRENT STATUS_UNIX
# define STATUS_EXIT STATUS_UNIX
# define STATUS_ALL_SUCCESS (PL_statusvalue = 0, PL_statusvalue_posix = 0)
@@ -3478,6 +3563,8 @@
#endif
#endif /* !__cplusplus */
+/* Fixme on VMS. This needs to be a run-time, not build time options */
+/* Also rename() is affected by this */
#ifdef UNLINK_ALL_VERSIONS /* Currently only makes sense for VMS */
#define UNLINK unlnk
I32 unlnk (const char*);
--- /rsync_root/perl/t/run/exit.t Thu Aug 11 03:52:02 2005
+++ t/run/exit.t Sat Oct 15 23:19:25 2005
@@ -17,7 +17,7 @@
BEGIN {
# MacOS system() doesn't have good return value
- $numtests = ($^O eq 'VMS') ? 14 : ($^O eq 'MacOS') ? 0 : 17;
+ $numtests = ($^O eq 'VMS') ? 16 : ($^O eq 'MacOS') ? 0 : 17;
}
require "test.pl";
@@ -95,24 +95,30 @@
# Double quotes are needed to pass these commands through DCL to PERL
$exit = run("exit 268632065"); # %CLI-S-NORMAL
- is( $exit, 0, 'PERL success exit' );
+ is( $exit >> 8, 0, 'PERL success exit' );
is( ${^CHILD_ERROR_NATIVE} & 7, 1, 'VMS success exit' );
$exit = run("exit 268632067"); # %CLI-I-NORMAL
- is( $exit, 0, 'PERL informational exit' );
+ is( $exit >> 8, 0, 'PERL informational exit' );
is( ${^CHILD_ERROR_NATIVE} & 7, 3, 'VMS informational exit' );
$exit = run("exit 268632064"); # %CLI-W-NORMAL
- is( $exit != 0, 1, 'Perl warning exit' );
+ is( $exit >> 8, 1, 'Perl warning exit' );
is( ${^CHILD_ERROR_NATIVE} & 7, 0, 'VMS warning exit' );
$exit = run("exit 268632066"); # %CLI-E-NORMAL
- is( $exit != 0, 1, 'Perl error exit' );
+ is( $exit >> 8, 2, 'Perl error exit' );
is( ${^CHILD_ERROR_NATIVE} & 7, 2, 'VMS error exit' );
$exit = run("exit 268632068"); # %CLI-F-NORMAL
- is( $exit != 0, 1, 'Perl fatal error exit' );
+ is( $exit >> 8, 4, 'Perl fatal error exit' );
is( ${^CHILD_ERROR_NATIVE} & 7, 4, 'VMS fatal exit' );
+
+ $exit = run("exit 02015320012"); # POSIX exit code 1
+ is( $exit >> 8, 1, 'Posix exit code 1' );
+
+ $exit = run("exit 02015323771"); # POSIX exit code 255
+ is( $exit >> 8 , 255, 'Posix exit code 255' );
}
$exit_arg = 42;
@@ -132,7 +138,7 @@
# status codes to SS$_ABORT on exit, but passes through unmodified UNIX
# status codes that exit() is called with by scripts.
-$exit_arg = 4 if $^O eq 'VMS';
+$exit_arg = (44 & 7) if $^O eq 'VMS';
is( $exit >> 8, $exit_arg, 'Changing $? in END block' );
}
--- /rsync_root/perl/vms/vmsish.h Sun Oct 2 18:15:16 2005
+++ vms/vmsish.h Sat Oct 15 20:58:54 2005
@@ -300,10 +300,12 @@
#define HAVE_INTERP_INTERN
struct interp_intern {
int hushed;
+ int posix_exit;
double inv_rand_max;
};
#define VMSISH_HUSHED (PL_sys_intern.hushed)
#define MY_INV_RAND_MAX (PL_sys_intern.inv_rand_max)
+#define MY_POSIX_EXIT (PL_sys_intern.posix_exit)
/* Flags for vmstrnenv() */
#define PERL__TRNENV_SECURE 0x01
@@ -762,7 +764,8 @@
void prime_env_iter (void);
void init_os_extras (void);
-int vms_status_to_unix(int vms_status);
+int Perl_vms_status_to_unix(int vms_status, int child_flag);
+int Perl_unix_status_to_vms(int unix_status);
/* prototype section start marker; `typedef' passes through cpp */
typedef char __VMS_PROTOTYPES__;
int Perl_vmstrnenv (const char *, char *, unsigned long int, struct
dsc$descriptor_s **, unsigned long int);
--- /rsync_root/perl/vms/vms.c Fri Oct 14 12:02:51 2005
+++ vms/vms.c Sat Oct 15 22:39:49 2005
@@ -76,8 +76,7 @@
#include <unixlib.h>
#endif
-#ifndef __VAX
-#if __CRTL_VER >= 70300000
+#if __CRTL_VER >= 70300000 && !defined(__VAX)
static int set_feature_default(const char *name, int value)
{
@@ -99,7 +98,6 @@
return 0;
}
#endif
-#endif
/* Older versions of ssdef.h don't have these */
#ifndef SS$_INVFILFOROP
@@ -1477,9 +1475,48 @@
struct dsc$descriptor_s *prcname,
unsigned int code);
+ /* sig 0 means validate the PID */
+ /*------------------------------*/
+ if (sig == 0) {
+ const unsigned long int jpicode = JPI$_PID;
+ pid_t ret_pid;
+ int status;
+ status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
+ if ($VMS_STATUS_SUCCESS(status))
+ return 0;
+ switch (status) {
+ case SS$_NOSUCHNODE:
+ case SS$_UNREACHABLE:
+ case SS$_NONEXPR:
+ errno = ESRCH;
+ break;
+ case SS$_NOPRIV:
+ errno = EPERM;
+ break;
+ default:
+ errno = EVMSERR;
+ }
+ vaxc$errno=status;
+ return -1;
+ }
+
code = Perl_sig_to_vmscondition(sig);
- if (!pid || !code) {
+ if (!code) {
+ SETERRNO(EINVAL, SS$_BADPARAM);
+ return -1;
+ }
+
+ /* Fixme: Per official UNIX specification: If pid = 0, or negative then
+ * signals are to be sent to multiple processes.
+ * pid = 0 - all processes in group except ones that the system exempts
+ * pid = -1 - all processes except ones that the system exempts
+ * pid = -n - all processes in group (abs(n)) except ...
+ * For now, just report as not supported.
+ */
+
+ if (pid <= 0) {
+ SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
return -1;
}
@@ -1526,7 +1563,7 @@
#define DCL_IVVERB 0x38090
#endif
-int vms_status_to_unix(int vms_status)
+int Perl_vms_status_to_unix(int vms_status, int child_flag)
{
int facility;
int fac_sp;
@@ -1546,7 +1583,7 @@
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)) {
+ if ((facility == 0) || (fac_sp == 0) && (child_flag == 0)) {
switch(msg_no) {
case SS$_NORMAL:
unix_status = 0;
@@ -1554,6 +1591,13 @@
case SS$_ACCVIO:
unix_status = EFAULT;
break;
+ case SS$_DEVOFFLINE:
+ unix_status = EBUSY;
+ break;
+ case SS$_CLEARED:
+ unix_status = ENOTCONN;
+ break;
+ case SS$_IVCHAN:
case SS$_IVLOGNAM:
case SS$_BADPARAM:
case SS$_IVLOGTAB:
@@ -1565,6 +1609,9 @@
case SS$_IVIDENT:
unix_status = EINVAL;
break;
+ case SS$_UNSUPPORTED:
+ unix_status = ENOTSUP;
+ break;
case SS$_FILACCERR:
case SS$_NOGRPPRV:
case SS$_NOSYSPRV:
@@ -1612,9 +1659,31 @@
else {
/* Translate a POSIX exit code to a UNIX exit code */
if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
- unix_status = (msg_no & 0x0FF0) >> 3;
+ unix_status = (msg_no & 0x07F8) >> 3;
}
else {
+
+ /* Documented traditional behavior for handling VMS child exits */
+ /*--------------------------------------------------------------*/
+ if (child_flag != 0) {
+
+ /* Success / Informational return 0 */
+ /*----------------------------------*/
+ if (msg_no & STS$K_SUCCESS)
+ return 0;
+
+ /* Warning returns 1 */
+ /*-------------------*/
+ if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
+ return 1;
+
+ /* Everything else pass through the severity bits */
+ /*------------------------------------------------*/
+ return (msg_no & STS$M_SEVERITY);
+ }
+
+ /* Normal VMS status to ERRNO mapping attempt */
+ /*--------------------------------------------*/
switch(msg_status) {
/* case RMS$_EOF: */ /* End of File */
case RMS$_FNF: /* File Not Found */
@@ -1630,6 +1699,14 @@
case RMS$_DEV:
unix_status = ENODEV;
break;
+ case RMS$_IFI:
+ case RMS$_FAC:
+ case RMS$_ISI:
+ unix_status = EBADF;
+ break;
+ case RMS$_FEX:
+ unix_status = EEXIST;
+ break;
case RMS$_SYN:
case RMS$_FNM:
case LIB$_INVSTRDES:
@@ -1658,6 +1735,135 @@
return unix_status;
}
+/* Try to guess at what VMS error status should go with a UNIX errno
+ * value. This is hard to do as there could be many possible VMS
+ * error statuses that caused the errno value to be set.
+ */
+
+int Perl_unix_status_to_vms(int unix_status)
+{
+int test_unix_status;
+
+ /* Trivial cases first */
+ /*---------------------*/
+ if (unix_status == EVMSERR)
+ return vaxc$errno;
+
+ /* Is vaxc$errno sane? */
+ /*---------------------*/
+ test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
+ if (test_unix_status == unix_status)
+ return vaxc$errno;
+
+ /* If way out of range, must be VMS code already */
+ /*-----------------------------------------------*/
+ if (unix_status > EVMSERR)
+ return unix_status;
+
+ /* If out of range, punt */
+ /*-----------------------*/
+ if (unix_status > __ERRNO_MAX)
+ return SS$_ABORT;
+
+
+ /* Ok, now we have to do it the hard way. */
+ /*----------------------------------------*/
+ switch(unix_status) {
+ case 0: return SS$_NORMAL;
+ case EPERM: return SS$_NOPRIV;
+ case ENOENT: return SS$_NOSUCHOBJECT;
+ case ESRCH: return SS$_UNREACHABLE;
+ case EINTR: return SS$_ABORT;
+ /* case EIO: */
+ /* case ENXIO: */
+ case E2BIG: return SS$_BUFFEROVF;
+ /* case ENOEXEC */
+ case EBADF: return RMS$_IFI;
+ case ECHILD: return SS$_NONEXPR;
+ /* case EAGAIN */
+ case ENOMEM: return SS$_INSFMEM;
+ case EACCES: return SS$_FILACCERR;
+ case EFAULT: return SS$_ACCVIO;
+ /* case ENOTBLK */
+ case EBUSY: SS$_DEVOFFLINE;
+ case EEXIST: return RMS$_FEX;
+ /* case EXDEV */
+ case ENODEV: return SS$_NOSUCHDEV;
+ case ENOTDIR: return RMS$_DIR;
+ /* case EISDIR */
+ case EINVAL: return SS$_INVARG;
+ /* case ENFILE */
+ /* case EMFILE */
+ /* case ENOTTY */
+ /* case ETXTBSY */
+ /* case EFBIG */
+ case ENOSPC: return SS$_DEVICEFULL;
+ case ESPIPE: return LIB$_INVARG;
+ /* case EROFS: */
+ /* case EMLINK: */
+ /* case EPIPE: */
+ /* case EDOM */
+ case ERANGE: return LIB$_INVARG;
+ /* case EWOULDBLOCK */
+ /* case EINPROGRESS */
+ /* case EALREADY */
+ /* case ENOTSOCK */
+ /* case EDESTADDRREQ */
+ /* case EMSGSIZE */
+ /* case EPROTOTYPE */
+ /* case ENOPROTOOPT */
+ /* case EPROTONOSUPPORT */
+ /* case ESOCKTNOSUPPORT */
+ /* case EOPNOTSUPP */
+ /* case EPFNOSUPPORT */
+ /* case EAFNOSUPPORT */
+ /* case EADDRINUSE */
+ /* case EADDRNOTAVAIL */
+ /* case ENETDOWN */
+ /* case ENETUNREACH */
+ /* case ENETRESET */
+ /* case ECONNABORTED */
+ /* case ECONNRESET */
+ /* case ENOBUFS */
+ /* case EISCONN */
+ case ENOTCONN: return SS$_CLEARED;
+ /* case ESHUTDOWN */
+ /* case ETOOMANYREFS */
+ /* case ETIMEDOUT */
+ /* case ECONNREFUSED */
+ /* case ELOOP */
+ /* case ENAMETOOLONG */
+ /* case EHOSTDOWN */
+ /* case EHOSTUNREACH */
+ /* case ENOTEMPTY */
+ /* case EPROCLIM */
+ /* case EUSERS */
+ /* case EDQUOT */
+ /* case ENOMSG */
+ /* case EIDRM */
+ /* case EALIGN */
+ /* case ESTALE */
+ /* case EREMOTE */
+ /* case ENOLCK */
+ /* case ENOSYS */
+ /* case EFTYPE */
+ /* case ECANCELED */
+ /* case EFAIL */
+ /* case EINPROG */
+ case ENOTSUP:
+ return SS$_UNSUPPORTED;
+ /* case EDEADLK */
+ /* case ENWAIT */
+ /* case EILSEQ */
+ /* case EBADCAT */
+ /* case EBADMSG */
+ /* case EABANDONED */
+ default:
+ return SS$_ABORT; /* punt */
+ }
+
+ return SS$_ABORT; /* Should not get here */
+}
/* default piping mailbox size */
@@ -8307,6 +8513,10 @@
double x;
VMSISH_HUSHED = 0;
+
+ /* fix me later to track running under GNV */
+ /* this allows some limited testing */
+ MY_POSIX_EXIT = decc_filename_unix_report;
x = (float)ix;
MY_INV_RAND_MAX = 1./x;
