diff options
| -rw-r--r-- | perl.c | 2 | ||||
| -rw-r--r-- | perl.h | 111 | ||||
| -rw-r--r-- | t/run/exit.t | 20 | ||||
| -rw-r--r-- | vms/vms.c | 224 | ||||
| -rw-r--r-- | vms/vmsish.h | 5 |
5 files changed, 334 insertions, 28 deletions
@@ -5155,7 +5155,7 @@ Perl_my_exit(pTHX_ U32 status) STATUS_ALL_FAILURE; break; default: - STATUS_UNIX_SET(status); + STATUS_UNIX_EXIT_SET(status); break; } my_exit_jump(); @@ -2545,49 +2545,133 @@ typedef pthread_key_t perl_key; #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 @@ typedef pthread_key_t perl_key; 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 @@ char *getlogin (void); #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*); diff --git a/t/run/exit.t b/t/run/exit.t index 90eeafc440..8302ae81dd 100644 --- a/t/run/exit.t +++ b/t/run/exit.t @@ -17,7 +17,7 @@ sub run { 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 @@ if ($^O ne 'VMS') { # 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 @@ $exit = run("END { \$? = $exit_arg }"); # 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' ); } @@ -76,8 +76,7 @@ int decc$feature_set_value(int index, int mode, int value); #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 @@ 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 @@ -1477,9 +1475,48 @@ Perl_my_kill(int pid, int sig) 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 @@ Perl_my_kill(int pid, int sig) #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 @@ 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)) { + if ((facility == 0) || (fac_sp == 0) && (child_flag == 0)) { switch(msg_no) { case SS$_NORMAL: unix_status = 0; @@ -1554,6 +1591,13 @@ int unix_status; 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 @@ int unix_status; 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 @@ int unix_status; 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 @@ int unix_status; 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 @@ int unix_status; 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 */ @@ -8308,6 +8514,10 @@ Perl_sys_intern_init(pTHX) 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; } diff --git a/vms/vmsish.h b/vms/vmsish.h index 41b2bb21d7..2ca6f03cd4 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -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 @@ typedef unsigned myino_t; 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); |