In Perl.h, create a new macro STATUS_UNIX_EXIT_SET for setting the exit
status correctly on VMS, and set that macro to be the same as
STATUS_UNIX_SET for non VMS platforms.
This new macro restores the previous behavior of EXIT handling on VMS.
Also added a latent feature that allows setting the encoding UNIX exit
status codes from 1 to 255 into a VMS status code that can be decoded by
other VMS programs like the BASH shell in GNV.
Fixed STATUS_NATIVE_CHILD_SET / STATUS_NATIVE_SET to not set the VMS
native status value to the illegal -1 status.
In perl.c, use STATUS_UNIX_EXIT_SET for setting the exit status.
In vmsish.h, add a posix_exit status to the interp_intern structure and
prototype for routine that attempts to map UNIX errno values to VMS
status values.
In vms.c:
Add unix_status_to_vms() routine for converting UNIX errno codes to a
possible VMS status code that could have caused it. This can not be
100% accurate unless the UNIX status was EVMSERR. But this puts a rock
on a can of worms for now that will keep most of them in.
Fix some bugs in Perl_my_kill() so that it returns a better error code
for unimplemented multiple processs signaling, and implement so that
signal 0 can be used to validate a process.
Fix mp_to_vmsify() for a bug that Craig Berry noticed caused translated
values to sometimes be truncated because the code was guessing wrong at
the resulting filename size when doing a Newx().
Todo:
A method needs to be created to allow setting the exit code handling on
VMS into the mode that GNV and programs written in C expect and
documentation about it. For early testing it is temporarily tied to the
DECC$FILENAME_REPORT_UNIX setting as that is not fully functional until
Pathtools and Cwd get updated to also use that setting.
-John
[EMAIL PROTECTED]
Personal Opinion Only
--- /rsync_root/perl/perl.c Thu Oct 13 20:01:44 2005
+++ ./perl.c Thu Oct 13 22:55:25 2005
@@ -5155,7 +5155,7 @@
STATUS_ALL_FAILURE;
break;
default:
- STATUS_UNIX_SET(status);
+ STATUS_UNIX_EXIT_SET(status);
break;
}
my_exit_jump();
@@ -5165,6 +5165,15 @@
Perl_my_failure_exit(pTHX)
{
#ifdef VMS
+
+/* Note: Unless other actions are taken to refresh it,
+ vaxc$errno only has meaningful information if the
+ errno == EVMSERR and errno is not stale.
+
+ Hopefully one of the STATUS macros or something
+ fixed it up before this point.
+ */
+
if (vaxc$errno & 1) {
if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
STATUS_NATIVE_SET(44);
--- /rsync_root/perl/perl.h Wed Oct 5 12:03:27 2005
+++ ./perl.h Thu Oct 13 22:50:34 2005
@@ -1097,6 +1097,7 @@
# undef SETERRNO /* SOCKS might have defined this */
#endif
+/* Fixme: Should not this be setting the PL_statusvalue* values also? */
#ifdef VMS
# define SETERRNO(errcode,vmserrcode) \
STMT_START { \
@@ -2545,49 +2546,177 @@
#define STATUS_UNIX PL_statusvalue
#ifdef VMS
# define STATUS_NATIVE PL_statusvalue_vms
+/*
+ * Finding this broken again after fixing it, it is clear that some
+ * documentation is needed so that non-VMS (and some VMS) programmers
+ * can figure out what is going on and what should happen.
+ *
+ * VMS native exit codes are actually a structure that is packed into
+ * a longword. It is normally handled as a longword for convenience.
+ * this information is contained in stsdef.h, which will now be included
+ * below to make sure that it's definitions are visible.
+ * Such exit codes are usually generated by the message utility, with
+ * separate message text files that each code can be translated back to
+ * text. Such message text files can be internationallized.
+ *
+ * UNIX/POSIX error codes are currently in a range of 0 to 255.
+ *
+ * Also unlike UNIX where an exit code is just returned to the shell, the
+ * native VMS exit code is passed through a signal handler as the program
+ * is exited.
+ *
+ * This means that problems will occur if the exit code is not a valid VMS
+ * exit code.
+ *
+ * Past versions of Perl on VMS solved that problem by translating UNIX
+ * error status values to 44 when the program exited. This causes a loss of
+ * information.
+ *
+ * There was also an vmsish pragma to cause it to change the Perl exit code
+ * 1 to UNIX code 0, which the C exit code restores back to 1.
+ *
+ * With VMS 7.0, this problem was addressed by encoding the UNIX exit
+ * codes into a range of VMS status codes. Prior to the last change that
+ * broke things on VMS, I fixed the code to translate these codes back to
+ * the proper UNIX codes for processes. For programs ported from UNIX to
+ * VMS, "#define _POSIX_EXIT 1" is needed to take advantage of this.
+ * Perl is too VMSized to use this exit method.
+ *
+ * Unfortunately there is a practice of passing UNIX codes untranslated
+ * back to DCL that has been adopted by people who do not realize what
+ * real and potential problems can come out of that.
+ *
+ * To work correctly with the GNV utilities, Perl must be better behaved
+ * and when the perl exit codes from 1 through 255 are given it should
+ * translate them with:
+ * vms_status = 0x35A000 | ((unix_status & 0xFF) << 3) if unix_status != 0;
+ *
+ * vaxc$errno is only suppose 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>
+/* Code to try to protect against if the size of the UNIX parent/child */
+/* ever changes. Nothing guarantees it to be 8 bits in size always. */
+/* Commenting out for now as not likely to change on VMS, and I do not */
+/* feel like debugging it if I did something wrong */
+/* # include <wait.h> */
+/* # ifndef WEXITSTATUS */
+# define child_offset_bits (8)
+/* # define WEXITSTATUS(s) (((s)>>child_offset_bits)&0xFF) */
+/* # else */
+/* # define child_offset_bits (offsetof(wait,_w_t._w_retcode)*8) */
+/* # endif */
+# 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 where it is needed the least.
+ */
+
# 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 = SS$_ABORT; /* Should not happen */ \
+ } else \
PL_statusvalue = vms_status_to_unix(evalue); \
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.
+ */
# define STATUS_UNIX_SET(n) \
STMT_START { \
PL_statusvalue = (n); \
if (PL_statusvalue != -1) { \
if (PL_statusvalue != EVMSERR) { \
PL_statusvalue &= 0xFFFF; \
- PL_statusvalue_vms = PL_statusvalue ? 44 : 1; \
+ PL_statusvalue_vms = unix_status_to_vms(n); \
} \
else { \
PL_statusvalue_vms = vaxc$errno; \
} \
} \
- else PL_statusvalue_vms = -1; \
+ else PL_statusvalue_vms = SS$_ABORT; \
+ set_vaxc_errno(n); \
+ } 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 { \
+ PL_statusvalue = (n); \
+ 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 |
((n) << 3)) : (n); \
+ } else { /* forgive them Perl, for they have sinned */ \
+ PL_statusvalue_vms = (n); \
+ } /* 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)) : SS$_ABORT)
#else
# define STATUS_NATIVE PL_statusvalue_posix
# if defined(WCOREDUMP)
@@ -2633,6 +2762,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 +3608,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/vms/vms.c Tue Sep 13 02:52:56 2005
+++ vms/vms.c Fri Oct 14 00:57:49 2005
@@ -1477,9 +1477,50 @@
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) {
+ errno = EINVAL;
+ vaxc$errno = 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 lie and say the user has no privileges.
+ */
+
+ if (pid <= 0) {
+ errno = EPERM;
+ vaxc$errno = SS$_NOPRIV;
return -1;
}
@@ -1554,6 +1595,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:
@@ -1630,6 +1678,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 +1714,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 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 = vms_status_to_unix(vaxc$errno);
+ 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 */
+ /* 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 */
@@ -4370,7 +4555,7 @@
if (path == NULL) return NULL;
if (buf) rslt = buf;
- else if (ts) Newx(rslt,strlen(path)+9,char);
+ else if (ts) Newx(rslt,NAM$C_MAXRSS+1,char);
else rslt = __tovmsspec_retbuf;
if (strpbrk(path,"]:>") ||
(dirend = strrchr(path,'/')) == NULL) {
@@ -4402,7 +4587,7 @@
while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
if (!*(cp2+1)) {
- if (!buf & ts) Renew(rslt,18,char);
+/* if (!buf & ts) Renew(rslt,18,char); */
if (decc_disable_posix_root) {
strcpy(rslt,"sys$disk:[000000]");
}
@@ -4626,6 +4811,8 @@
* which is wrong. UNIX notation should be ".dir. unless
* the DECC$FILENAME_UNIX_NO_VERSION is enabled.
* changing this behavior could break more things at this time.
+ * efs character set effectively does not allow "." to be a version
+ * delimiter.
*/
if (decc_filename_unix_report != 0) {
*(cp1++) = '^';
@@ -8308,6 +8495,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;
--- /rsync_root/perl/vms/vmsish.h Sun Oct 2 18:15:16 2005
+++ vms/vmsish.h Thu Oct 13 23:23:44 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
@@ -763,6 +765,7 @@
void prime_env_iter (void);
void init_os_extras (void);
int vms_status_to_unix(int vms_status);
+int 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);
