STATUS_ALL_FAILURE;
break;
default:
- STATUS_UNIX_SET(status);
+ STATUS_UNIX_EXIT_SET(status);
break;
}
my_exit_jump();
#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)
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)
#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*);
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";
# 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;
# 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' );
}
#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)
{
return 0;
}
#endif
-#endif
/* Older versions of ssdef.h don't have these */
#ifndef SS$_INVFILFOROP
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;
}
#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;
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;
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:
case SS$_IVIDENT:
unix_status = EINVAL;
break;
+ case SS$_UNSUPPORTED:
+ unix_status = ENOTSUP;
+ break;
case SS$_FILACCERR:
case SS$_NOGRPPRV:
case SS$_NOSYSPRV:
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 */
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:
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 */
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;
}
#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
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);
projects / p5sagit/p5-mst-13.2.git / commitdiff