* 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
*/
-#include <accdef.h>
#include <acedef.h>
#include <acldef.h>
#include <armdef.h>
/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
#define PERL_LNM_MAX_ALLOWED_INDEX 127
+/* OpenVMS User's Guide says at least 9 iterative translations will be performed,
+ * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
+ * the Perl facility.
+ */
+#define PERL_LNM_MAX_ITER 10
+
#define MAX_DCL_SYMBOL 255 /* well, what *we* can set, at least*/
#define MAX_DCL_LINE_LENGTH (4*MAX_DCL_SYMBOL-4)
static int tz_updated = 1;
#endif
+/* my_maxidx
+ * Routine to retrieve the maximum equivalence index for an input
+ * logical name. Some calls to this routine have no knowledge if
+ * the variable is a logical or not. So on error we return a max
+ * index of zero.
+ */
+/*{{{int my_maxidx(char *lnm) */
+static int
+my_maxidx(char *lnm)
+{
+ int status;
+ int midx;
+ int attr = LNM$M_CASE_BLIND;
+ struct dsc$descriptor lnmdsc;
+ struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
+ {0, 0, 0, 0}};
+
+ lnmdsc.dsc$w_length = strlen(lnm);
+ lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
+ lnmdsc.dsc$b_class = DSC$K_CLASS_S;
+ lnmdsc.dsc$a_pointer = lnm;
+
+ status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
+ if ((status & 1) == 0)
+ midx = 0;
+
+ return (midx);
+}
+/*}}}*/
+
/*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
int
Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
unsigned long int retsts, attr = LNM$M_CASE_BLIND;
+ int midx;
unsigned char acmode;
struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
$DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
#if defined(PERL_IMPLICIT_CONTEXT)
pTHX = NULL;
-# if defined(USE_5005THREADS)
- /* We jump through these hoops because we can be called at */
- /* platform-specific initialization time, which is before anything is */
- /* set up--we can't even do a plain dTHX since that relies on the */
- /* interpreter structure to be initialized */
- if (PL_curinterp) {
- aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
- } else {
- aTHX = NULL;
- }
-# else
if (PL_curinterp) {
aTHX = PERL_GET_INTERP;
} else {
aTHX = NULL;
}
-
-# endif
#endif
- if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) {
+ if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
}
for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
retsts = SS$_NOLOGNAM;
for (i = 0; environ[i]; i++) {
if ((eq = strchr(environ[i],'=')) &&
+ lnmdsc.dsc$w_length == (eq - environ[i]) &&
!strncmp(environ[i],uplnm,eq - environ[i])) {
eq++;
for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
/* fully initialized, in which case either thr or PL_curcop */
/* might be bogus. We have to check, since ckWARN needs them */
/* both to be valid if running threaded */
-#if defined(USE_5005THREADS)
- if (thr && PL_curcop) {
-#endif
if (ckWARN(WARN_MISC)) {
- Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
+ Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
}
-#if defined(USE_5005THREADS)
- } else {
- Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
- }
-#endif
-
}
strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
}
}
}
else if (!ivlnm) {
- retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
- if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
- if (retsts == SS$_NOLOGNAM) continue;
- /* PPFs have a prefix */
- if (
+ if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
+ midx = my_maxidx((char *) lnm);
+ for (idx = 0, cp1 = eqv; idx <= midx; idx++) {
+ lnmlst[1].bufadr = cp1;
+ eqvlen = 0;
+ retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
+ if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
+ if (retsts == SS$_NOLOGNAM) break;
+ /* PPFs have a prefix */
+ if (
#if INTSIZE == 4
- *((int *)uplnm) == *((int *)"SYS$") &&
+ *((int *)uplnm) == *((int *)"SYS$") &&
#endif
- eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
- ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
- (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
- (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
- (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
- memcpy(eqv,eqv+4,eqvlen-4);
- eqvlen -= 4;
+ eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
+ ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
+ (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
+ (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
+ (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
+ memcpy(eqv,eqv+4,eqvlen-4);
+ eqvlen -= 4;
+ }
+ cp1 += eqvlen;
+ *cp1 = '\0';
+ }
+ if ((retsts == SS$_IVLOGNAM) ||
+ (retsts == SS$_NOLOGNAM)) { continue; }
}
+ else {
+ retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
+ if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
+ if (retsts == SS$_NOLOGNAM) continue;
+ eqv[eqvlen] = '\0';
+ }
+ eqvlen = strlen(eqv);
break;
}
}
char *
Perl_my_getenv(pTHX_ const char *lnm, bool sys)
{
- static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
+ static char *__my_getenv_eqv = NULL;
char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
unsigned long int idx = 0;
int trnsuccess, success, secure, saverr, savvmserr;
+ int midx, flags;
SV *tmpsv;
+ midx = my_maxidx((char *) lnm) + 1;
+
if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
/* Set up a temporary buffer for the return value; Perl will
* clean it up at the next statement transition */
- tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
+ tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
if (!tmpsv) return NULL;
eqv = SvPVX(tmpsv);
}
- else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
+ else {
+ /* Assume no interpreter ==> single thread */
+ if (__my_getenv_eqv != NULL) {
+ Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
+ }
+ else {
+ New(1380,__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
+ }
+ eqv = __my_getenv_eqv;
+ }
+
for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
getcwd(eqv,LNM$C_NAMLENGTH);
return eqv;
}
else {
- if ((cp2 = strchr(lnm,';')) != NULL) {
- strcpy(uplnm,lnm);
- uplnm[cp2-lnm] = '\0';
- idx = strtoul(cp2+1,NULL,0);
- lnm = uplnm;
- }
/* Impose security constraints only if tainting */
if (sys) {
/* Impose security constraints only if tainting */
secure = PL_curinterp ? PL_tainting : will_taint;
saverr = errno; savvmserr = vaxc$errno;
}
- else secure = 0;
- success = vmstrnenv(lnm,eqv,idx,
- secure ? fildev : NULL,
+ else {
+ secure = 0;
+ }
+
+ flags =
#ifdef SECURE_INTERNAL_GETENV
- secure ? PERL__TRNENV_SECURE : 0
+ secure ? PERL__TRNENV_SECURE : 0
#else
- 0
+ 0
#endif
- );
+ ;
+
+ /* For the getenv interface we combine all the equivalence names
+ * of a search list logical into one value to acquire a maximum
+ * value length of 255*128 (assuming %ENV is using logicals).
+ */
+ flags |= PERL__TRNENV_JOIN_SEARCHLIST;
+
+ /* If the name contains a semicolon-delimited index, parse it
+ * off and make sure we only retrieve the equivalence name for
+ * that index. */
+ if ((cp2 = strchr(lnm,';')) != NULL) {
+ strcpy(uplnm,lnm);
+ uplnm[cp2-lnm] = '\0';
+ idx = strtoul(cp2+1,NULL,0);
+ lnm = uplnm;
+ flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
+ }
+
+ success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
+
/* Discard NOLOGNAM on internal calls since we're often looking
* for an optional name, and this "error" often shows up as the
* (bogus) exit status for a die() call later on. */
{
char *buf, *cp1, *cp2;
unsigned long idx = 0;
- static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
+ int midx, flags;
+ static char *__my_getenv_len_eqv = NULL;
int secure, saverr, savvmserr;
SV *tmpsv;
+ midx = my_maxidx((char *) lnm) + 1;
+
if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
/* Set up a temporary buffer for the return value; Perl will
* clean it up at the next statement transition */
- tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
+ tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
if (!tmpsv) return NULL;
buf = SvPVX(tmpsv);
}
- else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
+ else {
+ /* Assume no interpreter ==> single thread */
+ if (__my_getenv_len_eqv != NULL) {
+ Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
+ }
+ else {
+ New(1381,__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
+ }
+ buf = __my_getenv_len_eqv;
+ }
+
for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
getcwd(buf,LNM$C_NAMLENGTH);
return buf;
}
else {
- if ((cp2 = strchr(lnm,';')) != NULL) {
- strcpy(buf,lnm);
- buf[cp2-lnm] = '\0';
- idx = strtoul(cp2+1,NULL,0);
- lnm = buf;
- }
if (sys) {
/* Impose security constraints only if tainting */
secure = PL_curinterp ? PL_tainting : will_taint;
saverr = errno; savvmserr = vaxc$errno;
}
- else secure = 0;
- *len = vmstrnenv(lnm,buf,idx,
- secure ? fildev : NULL,
+ else {
+ secure = 0;
+ }
+
+ flags =
#ifdef SECURE_INTERNAL_GETENV
- secure ? PERL__TRNENV_SECURE : 0
+ secure ? PERL__TRNENV_SECURE : 0
#else
- 0
+ 0
#endif
- );
+ ;
+
+ flags |= PERL__TRNENV_JOIN_SEARCHLIST;
+
+ if ((cp2 = strchr(lnm,';')) != NULL) {
+ strcpy(buf,lnm);
+ buf[cp2-lnm] = '\0';
+ idx = strtoul(cp2+1,NULL,0);
+ lnm = buf;
+ flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
+ }
+
+ *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
+
/* Discard NOLOGNAM on internal calls since we're often looking
* for an optional name, and this "error" often shows up as the
* (bogus) exit status for a die() call later on. */
#if defined(PERL_IMPLICIT_CONTEXT)
pTHX;
#endif
-#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
+#if defined(USE_ITHREADS)
static perl_mutex primenv_mutex;
MUTEX_INIT(&primenv_mutex);
#endif
/* platform-specific initialization time, which is before anything is */
/* set up--we can't even do a plain dTHX since that relies on the */
/* interpreter structure to be initialized */
-#if defined(USE_5005THREADS)
- if (PL_curinterp) {
- aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
- } else {
- aTHX = NULL;
- }
-#else
if (PL_curinterp) {
aTHX = PERL_GET_INTERP;
} else {
aTHX = NULL;
}
#endif
-#endif
if (primed || !PL_envgv) return;
MUTEX_LOCK(&primenv_mutex);
for (j = 0; environ[j]; j++) {
if (!(start = strchr(environ[j],'='))) {
if (ckWARN(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
}
else {
start++;
continue;
}
if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
if (*cp1 == '(' || /* Logical name table name */
cp1--; /* stop on last non-space char */
}
if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
- Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
continue;
}
PERL_HASH(hash,key,keylen);
- sv = newSVpvn(cp2,cp1 - cp2 + 1);
+
+ if (cp1 == cp2 && *cp2 == '.') {
+ /* A single dot usually means an unprintable character, such as a null
+ * to indicate a zero-length value. Get the actual value to make sure.
+ */
+ char lnm[LNM$C_NAMLENGTH+1];
+ char eqv[LNM$C_NAMLENGTH+1];
+ strncpy(lnm, key, keylen);
+ int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
+ sv = newSVpvn(eqv, strlen(eqv));
+ }
+ else {
+ sv = newSVpvn(cp2,cp1 - cp2 + 1);
+ }
+
SvTAINTED_on(sv);
hv_store(envhv,key,keylen,sv,hash);
hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
/*}}}*/
-/*{{{ int vmssetenv(char *lnm, char *eqv)*/
+/*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
/* Define or delete an element in the same "environment" as
* vmstrnenv(). If an element is to be deleted, it's removed from
* the first place it's found. If it's to be set, it's set in the
* Like setenv() returns 0 for success, non-zero on error.
*/
int
-Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
+Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
{
- char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
+ char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2, *c;
unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
+ int nseg = 0, j;
unsigned long int retsts, usermode = PSL$C_USER;
+ struct itmlst_3 *ile, *ilist;
struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
$DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
$DESCRIPTOR(local,"_LOCAL");
- for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
+ if (!lnm) {
+ set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
+ return SS$_IVLOGNAM;
+ }
+
+ for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
*cp2 = _toupper(*cp1);
if (cp1 - lnm > LNM$C_NAMLENGTH) {
set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
for (curtab = 0; tabvec[curtab]; curtab++) {
if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
int i;
- for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
+ for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
if ((cp1 = strchr(environ[i],'=')) &&
+ lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
!strncmp(environ[i],lnm,cp1 - environ[i])) {
#ifdef HAS_SETENV
return setenv(lnm,"",1) ? vaxc$errno : 0;
ivenv = 1; retsts = SS$_NOLOGNAM;
#else
if (ckWARN(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
ivenv = 1; retsts = SS$_NOSUCHPGM;
break;
}
return setenv(lnm,eqv,1) ? vaxc$errno : 0;
#else
if (ckWARN(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
retsts = SS$_NOSUCHPGM;
#endif
}
else {
- eqvdsc.dsc$a_pointer = eqv;
+ eqvdsc.dsc$a_pointer = (char *)eqv;
eqvdsc.dsc$w_length = strlen(eqv);
if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
!str$case_blind_compare(&tmpdsc,&clisym)) {
else {
if (!*eqv) eqvdsc.dsc$w_length = 1;
if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
- eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
- if (ckWARN(WARN_MISC)) {
- Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
+
+ nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
+ if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
+ Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
+ lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
+ eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
+ nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
}
+
+ New(1382,ilist,nseg+1,struct itmlst_3);
+ ile = ilist;
+ if (!ile) {
+ set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
+ return SS$_INSFMEM;
+ }
+ memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
+
+ for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
+ ile->itmcode = LNM$_STRING;
+ ile->bufadr = c;
+ if ((j+1) == nseg) {
+ ile->buflen = strlen(c);
+ /* in case we are truncating one that's too long */
+ if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
+ }
+ else {
+ ile->buflen = LNM$C_NAMLENGTH;
+ }
+ }
+
+ retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
+ Safefree (ilist);
+ }
+ else {
+ retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
}
- retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
}
}
}
} /* end of vmssetenv() */
/*}}}*/
-/*{{{ void my_setenv(char *lnm, char *eqv)*/
+/*{{{ void my_setenv(const char *lnm, const char *eqv)*/
/* This has to be a function since there's a prototype for it in proto.h */
void
-Perl_my_setenv(pTHX_ char *lnm,char *eqv)
+Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
{
if (lnm && *lnm) {
int len = strlen(lnm);
}
/*}}}*/
-/*{{{static void vmssetuserlnm(char *name, char *eqv);
+/*{{{static void vmssetuserlnm(char *name, char *eqv); */
/* vmssetuserlnm
* sets a user-mode logical in the process logical name table
* used for redirection of sys$error
#ifdef KILL_BY_SIGPRC
#include <errnodef.h>
-/* okay, this is some BLATENT hackery ...
- we use this if the kill() in the CRTL uses sys$forcex, causing the
+/* We implement our own kill() using the undocumented system service
+ sys$sigprc for one of two reasons:
+
+ 1.) If the kill() in an older CRTL uses sys$forcex, causing the
target process to do a sys$exit, which usually can't be handled
gracefully...certainly not by Perl and the %SIG{} mechanism.
- Instead we use the (undocumented) system service sys$sigprc.
- It has the same parameters as sys$forcex, but throws an exception
+ 2.) If the kill() in the CRTL can't be called from a signal
+ handler without disappearing into the ether, i.e., the signal
+ it purportedly sends is never trapped. Still true as of VMS 7.3.
+
+ sys$sigprc has the same parameters as sys$forcex, but throws an exception
in the target process rather than calling sys$exit.
Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
#define _MY_SIG_MAX 17
-int
-Perl_my_kill(int pid, int sig)
+unsigned int
+Perl_sig_to_vmscondition(int sig)
{
- int iss;
- int sys$sigprc(unsigned int *pidadr,
- struct dsc$descriptor_s *prcname,
- unsigned int code);
- static unsigned long sig_code[_MY_SIG_MAX+1] =
+ static unsigned int sig_code[_MY_SIG_MAX+1] =
{
0, /* 0 ZERO */
SS$_HANGUP, /* 1 SIGHUP */
}
#endif
- if (!pid || sig < _SIG_MIN || sig > _SIG_MAX || sig > _MY_SIG_MAX || !sig_code[sig]) {
+ if (sig < _SIG_MIN) return 0;
+ if (sig > _MY_SIG_MAX) return 0;
+ return sig_code[sig];
+}
+
+
+int
+Perl_my_kill(int pid, int sig)
+{
+ dTHX;
+ int iss;
+ unsigned int code;
+ int sys$sigprc(unsigned int *pidadr,
+ struct dsc$descriptor_s *prcname,
+ unsigned int code);
+
+ code = Perl_sig_to_vmscondition(sig);
+
+ if (!pid || !code) {
return -1;
}
- iss = sys$sigprc((unsigned int *)&pid,0,sig_code[sig]);
+ iss = sys$sigprc((unsigned int *)&pid,0,code);
if (iss&1) return 0;
switch (iss) {
unsigned long int exit_status;
};
+typedef struct _closed_pipes Xpipe;
+typedef struct _closed_pipes* pXpipe;
+
+struct _closed_pipes {
+ int pid; /* PID of subprocess */
+ unsigned long completion; /* termination status of subprocess */
+};
+#define NKEEPCLOSED 50
+static Xpipe closed_list[NKEEPCLOSED];
+static int closed_index = 0;
+static int closed_num = 0;
+
#define RETRY_DELAY "0 ::0.20"
#define MAX_RETRY 50
{
pInfo i = open_pipes;
int iss;
+ pXpipe x;
+
+ info->completion &= 0x0FFFFFFF; /* strip off "control" field */
+ closed_list[closed_index].pid = info->pid;
+ closed_list[closed_index].completion = info->completion;
+ closed_index++;
+ if (closed_index == NKEEPCLOSED)
+ closed_index = 0;
+ closed_num++;
while (i) {
if (i == info) break;
}
if (!i) return; /* unlinked, probably freed too */
- info->completion &= 0x0FFFFFFF; /* strip off "control" field */
info->done = TRUE;
/*
}
-static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote);
-static void vms_execfree(pTHX);
+static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
+static void vms_execfree(struct dsc$descriptor_s *vmscmd);
/*
we actually differ from vmstrnenv since we use this to
STRLEN n_a;
if (head_PLOC)
- free_pipelocs(&head_PLOC);
+ free_pipelocs(aTHX_ &head_PLOC);
/* the . directory from @INC comes last */
/* get the directory from $^X */
+#ifdef PERL_IMPLICIT_CONTEXT
+ if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
+#else
if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
+#endif
strcpy(temp, PL_origargv[0]);
x = strrchr(temp,']');
if (x) x[1] = '\0';
/* reverse order of @INC entries, skip "." since entered above */
+#ifdef PERL_IMPLICIT_CONTEXT
+ if (aTHX)
+#endif
if (PL_incgv) av = GvAVn(PL_incgv);
for (i = 0; av && i <= AvFILL(av); i++) {
p->dir[NAM$C_MAXRSS] = '\0';
}
#endif
- Perl_call_atexit(aTHX_ &free_pipelocs, &head_PLOC);
}
}
if (!fp) return 0; /* we're hosed */
- fprintf(fp,"$! 'f$verify(0)\n");
+ fprintf(fp,"$! 'f$verify(0)'\n");
fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
fprintf(fp,"$ perl_define = \"define/nolog\"\n");
fprintf(fp,"$c=c+perl_popen_cmd2\n");
fprintf(fp,"$x=perl_popen_cmd3\n");
fprintf(fp,"$c=c+x\n");
- fprintf(fp,"$! --- get rid of global symbols\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd0\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd1\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd2\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd3\n");
fprintf(fp,"$ perl_on\n");
- fprintf(fp,"$ 'c\n");
+ fprintf(fp,"$ 'c'\n");
fprintf(fp,"$ perl_status = $STATUS\n");
fprintf(fp,"$ perl_del 'perl_cfile'\n");
fprintf(fp,"$ perl_exit 'perl_status'\n");
safe_popen(pTHX_ char *cmd, char *in_mode, int *psts)
{
static int handler_set_up = FALSE;
- unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
- unsigned int table = LIB$K_CLI_GLOBAL_SYM;
+ unsigned long int sts, flags = CLI$M_NOWAIT;
+ /* The use of a GLOBAL table (as was done previously) rendered
+ * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
+ * environment. Hence we've switched to LOCAL symbol table.
+ */
+ unsigned int table = LIB$K_CLI_LOCAL_SYM;
int j, wait = 0;
char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
char in[512], out[512], err[512], mbx[512];
DSC$K_CLASS_S, 0};
struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
DSC$K_CLASS_S, cmd_sym_name};
+ struct dsc$descriptor_s *vmscmd;
$DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
$DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
$DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
tpipe = vmspipe_tempfile(aTHX);
if (!tpipe) { /* a fish popular in Boston */
if (ckWARN(WARN_PIPE)) {
- Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
+ Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
}
return Nullfp;
}
vmspipedsc.dsc$a_pointer = tfilebuf;
vmspipedsc.dsc$w_length = strlen(tfilebuf);
- sts = setup_cmddsc(aTHX_ cmd,0,0);
+ sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
if (!(sts & 1)) {
switch (sts) {
case RMS$_FNF: case RMS$_DNF:
}
set_vaxc_errno(sts);
if (*mode != 'n' && ckWARN(WARN_PIPE)) {
- Perl_warner(aTHX_ WARN_PIPE,"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
+ Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
}
*psts = sts;
return Nullfp;
d_symbol.dsc$w_length = strlen(symbol);
_ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
- p = VMSCMD.dsc$a_pointer;
+ p = vmscmd->dsc$a_pointer;
while (*p && *p != '\n') p++;
*p = '\0'; /* truncate on \n */
- p = VMSCMD.dsc$a_pointer;
+ p = vmscmd->dsc$a_pointer;
while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
if (*p == '$') p++; /* remove leading $ */
while (*p == ' ' || *p == '\t') p++;
info->next=open_pipes; /* prepend to list */
open_pipes=info;
_ckvmssts(sys$setast(1));
- _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
+ /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
+ * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
+ * have SYS$COMMAND if we need it.
+ */
+ _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
0, &info->pid, &info->completion,
0, popen_completion_ast,info,0,0,0));
_ckvmssts(lib$delete_symbol(&d_sym_in, &table));
_ckvmssts(lib$delete_symbol(&d_sym_err, &table));
_ckvmssts(lib$delete_symbol(&d_sym_out, &table));
- vms_execfree(aTHX);
+ vms_execfree(vmscmd);
+#ifdef PERL_IMPLICIT_CONTEXT
+ if (aTHX)
+#endif
PL_forkprocess = info->pid;
+
if (wait) {
int done = 0;
while (!done) {
} /* end of my_pclose() */
-#if defined(__CRTL_VER) && __CRTL_VER >= 70100322
+#if defined(__CRTL_VER) && __CRTL_VER >= 70200000
/* Roll our own prototype because we want this regardless of whether
* _VMS_WAIT is defined.
*/
pInfo info;
int done;
int sts;
+ int j;
if (statusp) *statusp = 0;
if (statusp) *statusp = info->completion;
return pid;
+ }
+
+ /* child that already terminated? */
+ for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
+ if (closed_list[j].pid == pid) {
+ if (statusp) *statusp = closed_list[j].completion;
+ return pid;
+ }
}
- else { /* this child is not one of our own pipe children */
-#if defined(__CRTL_VER) && __CRTL_VER >= 70100322
+ /* fall through if this child is not one of our own pipe children */
+
+#if defined(__CRTL_VER) && __CRTL_VER >= 70200000
/* waitpid() became available in the CRTL as of VMS 7.0, but only
* in 7.2 did we get a version that fills in the VMS completion
* of the current process.
*/
-#endif /* defined(__CRTL_VER) && __CRTL_VER >= 70100322 */
+#endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
+ {
$DESCRIPTOR(intdsc,"0 00:00:01");
unsigned long int ownercode = JPI$_OWNER, ownerpid;
unsigned long int pidcode = JPI$_PID, mypid;
unsigned long int interval[2];
- int termination_mbu = 0;
- unsigned short qio_iosb[4];
unsigned int jpi_iosb[2];
- struct itmlst_3 jpilist[3] = {
+ struct itmlst_3 jpilist[2] = {
{sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
- {sizeof(termination_mbu), JPI$_TMBU, &termination_mbu, 0},
{ 0, 0, 0, 0}
};
- char trmmbx[NAM$C_DVI+1];
- $DESCRIPTOR(trmmbxdsc,trmmbx);
- struct accdef trmmsg;
- unsigned short int mbxchan;
if (pid <= 0) {
/* Sorry folks, we don't presently implement rooting around for
return -1;
}
- /* Get the owner of the child so I can warn if it's not mine, plus
- * get the termination mailbox. If the process doesn't exist or I
- * don't have the privs to look at it, I can go home early.
+ /* Get the owner of the child so I can warn if it's not mine. If the
+ * process doesn't exist or I don't have the privs to look at it,
+ * I can go home early.
*/
sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
if (sts & 1) sts = jpi_iosb[0];
/* remind folks they are asking for non-standard waitpid behavior */
_ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
if (ownerpid != mypid)
- Perl_warner(aTHX_ WARN_EXEC,
+ Perl_warner(aTHX_ packWARN(WARN_EXEC),
"waitpid: process %x is not a child of process %x",
pid,mypid);
}
- /* It's possible to have a mailbox unit number but no actual mailbox; we
- * check for this by assigning a channel to it, which we need anyway.
- */
- if (termination_mbu != 0) {
- sprintf(trmmbx, "MBA%d:", termination_mbu);
- trmmbxdsc.dsc$w_length = strlen(trmmbx);
- sts = sys$assign(&trmmbxdsc, &mbxchan, 0, 0);
- if (sts == SS$_NOSUCHDEV) {
- termination_mbu = 0; /* set up to take "no mailbox" case */
- sts = SS$_NORMAL;
- }
- _ckvmssts(sts);
- }
- /* If the process doesn't have a termination mailbox, then simply check
- * on it once a second until it's not there anymore.
- */
- if (termination_mbu == 0) {
- _ckvmssts(sys$bintim(&intdsc,interval));
- while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
+ /* simply check on it once a second until it's not there anymore. */
+
+ _ckvmssts(sys$bintim(&intdsc,interval));
+ while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
_ckvmssts(sys$schdwk(0,0,interval,0));
_ckvmssts(sys$hiber());
- }
- if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
- }
- else {
- /* If we do have a termination mailbox, post reads to it until we get a
- * termination message, discarding messages of the wrong type or for other
- * processes. If there is a place to put the final status, then do so.
- */
- sts = SS$_NORMAL;
- while (sts & 1) {
- memset((void *) &trmmsg, 0, sizeof(trmmsg));
- sts = sys$qiow(0,mbxchan,IO$_READVBLK,&qio_iosb,0,0,
- &trmmsg,ACC$K_TERMLEN,0,0,0,0);
- if (sts & 1) sts = qio_iosb[0];
-
- if ( sts & 1
- && trmmsg.acc$w_msgtyp == MSG$_DELPROC
- && trmmsg.acc$l_pid == pid ) {
-
- if (statusp) *statusp = trmmsg.acc$l_finalsts;
- sts = sys$dassgn(mbxchan);
- break;
- }
- }
- } /* termination_mbu ? */
+ }
+ if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
_ckvmssts(sts);
return pid;
-
- } /* else one of our own pipe children */
-
+ }
} /* end of waitpid() */
/*}}}*/
/*}}}*/
unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
char *retspec, *cp1, *cp2, *lastdir;
char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
+ unsigned short int trnlnm_iter_count;
if (!dir || !*dir) {
set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
}
if (!strpbrk(dir+1,"/]>:")) {
strcpy(trndir,*dir == '/' ? dir + 1: dir);
- while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
+ trnlnm_iter_count = 0;
+ while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
+ trnlnm_iter_count++;
+ if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
+ }
dir = trndir;
dirlen = strlen(dir);
}
static char __pathify_retbuf[NAM$C_MAXRSS+1];
unsigned long int retlen;
char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
+ unsigned short int trnlnm_iter_count;
+ STRLEN trnlen;
if (!dir || !*dir) {
set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
if (*dir) strcpy(trndir,dir);
else getcwd(trndir,sizeof trndir - 1);
+ trnlnm_iter_count = 0;
while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
&& my_trnlnm(trndir,trndir,0)) {
- STRLEN trnlen = strlen(trndir);
+ trnlnm_iter_count++;
+ if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
+ trnlen = strlen(trndir);
/* Trap simple rooted lnms, and return lnm:[000000] */
if (!strcmp(trndir+trnlen-2,".]")) {
{
static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
- int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
+ int devlen, dirlen, retlen = NAM$C_MAXRSS+1;
+ int expand = 1; /* guarantee room for leading and trailing slashes */
+ unsigned short int trnlnm_iter_count;
if (spec == NULL) return NULL;
if (strlen(spec) > NAM$C_MAXRSS) return NULL;
if (ts) Safefree(rslt);
return NULL;
}
+ trnlnm_iter_count = 0;
do {
cp3 = tmp;
while (*cp3 != ':' && *cp3) cp3++;
*(cp3++) = '\0';
if (strchr(cp3,']') != NULL) break;
+ trnlnm_iter_count++;
+ if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
} while (vmstrnenv(tmp,tmp,0,fildev,0));
if (ts && !buf &&
((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
struct list_item **tail,
int *count);
-static int background_process(int argc, char **argv);
+static int background_process(pTHX_ int argc, char **argv);
static void pipe_and_fork(pTHX_ char **cmargv);
*/
ap = argv[argc-1];
if (0 == strcmp("&", ap))
- exit(background_process(--argc, argv));
+ exit(background_process(aTHX_ --argc, argv));
if (*ap && '&' == ap[strlen(ap)-1])
{
ap[strlen(ap)-1] = '\0';
- exit(background_process(argc, argv));
+ exit(background_process(aTHX_ argc, argv));
}
/*
* Now we handle the general redirection cases that involve '>', '>>',
int expcount = 0;
unsigned long int context = 0;
int isunix = 0;
+int item_len = 0;
char *had_version;
char *had_device;
int had_directory;
add_item(head, tail, item, count);
return;
}
+ else
+ {
+ /* "double quoted" wild card expressions pass as is */
+ /* From DCL that means using e.g.: */
+ /* perl program """perl.*""" */
+ item_len = strlen(item);
+ if ( '"' == *item && '"' == item[item_len-1] )
+ {
+ item++;
+ item[item_len-2] = '\0';
+ add_item(head, tail, item, count);
+ return;
+ }
+ }
resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
resultspec.dsc$b_class = DSC$K_CLASS_D;
resultspec.dsc$a_pointer = NULL;
pipe_and_fork(pTHX_ char **cmargv)
{
PerlIO *fp;
+ struct dsc$descriptor_s *vmscmd;
char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
int sts, j, l, ismcr, quote, tquote = 0;
- sts = setup_cmddsc(cmargv[0],0,"e);
+ sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
+ vms_execfree(vmscmd);
j = l = 0;
p = subcmd;
}
*p = '\0';
- fp = safe_popen(subcmd,"wbF",&sts);
+ fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
if (fp == Nullfp) {
PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
}
}
-static int background_process(int argc, char **argv)
+static int background_process(pTHX_ int argc, char **argv)
{
char command[2048] = "$";
$DESCRIPTOR(value, "");
{ sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
{ 0, 0, 0, 0} };
+#ifdef KILL_BY_SIGPRC
+ (void) Perl_csighandler_init();
+#endif
+
_ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
_ckvmssts_noperl(iosb[0]);
for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
* hasn't been allocated when vms_image_init() is called.
*/
if (will_taint) {
- char ***newap;
- New(1320,newap,*argcp+2,char **);
- newap[0] = argvp[0];
- *newap[1] = "-T";
- Copy(argvp[1],newap[2],*argcp-1,char **);
+ char **newargv, **oldargv;
+ oldargv = *argvp;
+ New(1320,newargv,(*argcp)+2,char *);
+ newargv[0] = oldargv[0];
+ New(1320,newargv[1],3,char);
+ strcpy(newargv[1], "-T");
+ Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
+ (*argcp)++;
+ newargv[*argcp] = NULL;
/* We orphan the old argv, since we don't know where it's come from,
* so we don't know how to free it.
*/
- *argcp++; argvp = newap;
+ *argvp = newargv;
}
else { /* Did user explicitly request tainting? */
int i;
if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
getredirection(argcp,argvp);
-#if defined(USE_5005THREADS) && ( defined(__DECC) || defined(__DECCXX) )
+#if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
{
# include <reentrancy.h>
(void) decc$set_reentrancy(C$C_MULTITHREAD);
* Minor modifications to original routines.
*/
+/* readdir may have been redefined by reentr.h, so make sure we get
+ * the local version for what we do here.
+ */
+#ifdef readdir
+# undef readdir
+#endif
+#if !defined(PERL_IMPLICIT_CONTEXT)
+# define readdir Perl_readdir
+#else
+# define readdir(a) Perl_readdir(aTHX_ a)
+#endif
+
/* Number of elements in vms_versions array */
#define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
if (do_tovmspath(name,dir,0) == NULL) {
return NULL;
}
+ /* Check access before stat; otherwise stat does not
+ * accurately report whether it's a directory.
+ */
+ if (!cando_by_name(S_IRUSR,0,dir)) {
+ /* cando_by_name has already set errno */
+ return NULL;
+ }
if (flex_stat(dir,&sb) == -1) return NULL;
if (!S_ISDIR(sb.st_mode)) {
set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
return NULL;
}
- if (!cando_by_name(S_IRUSR,0,dir)) {
- set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
- return NULL;
- }
/* Get memory for the handle, and the pattern. */
New(1306,dd,1,DIR);
New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
dd->pat.dsc$w_length = strlen(dd->pattern);
dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
dd->pat.dsc$b_class = DSC$K_CLASS_S;
+#if defined(USE_ITHREADS)
+ New(1308,dd->mutex,1,perl_mutex);
+ MUTEX_INIT( (perl_mutex *) dd->mutex );
+#else
+ dd->mutex = NULL;
+#endif
return dd;
} /* end of opendir() */
{
(void)lib$find_file_end(&dd->context);
Safefree(dd->pattern);
+#if defined(USE_ITHREADS)
+ MUTEX_DESTROY( (perl_mutex *) dd->mutex );
+ Safefree(dd->mutex);
+#endif
Safefree((char *)dd);
}
/*}}}*/
/*}}}*/
/*
+ * Read the next entry from the directory -- thread-safe version.
+ */
+/*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
+int
+Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
+{
+ int retval;
+
+ MUTEX_LOCK( (perl_mutex *) dd->mutex );
+
+ entry = readdir(dd);
+ *result = entry;
+ retval = ( *result == NULL ? errno : 0 );
+
+ MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
+
+ return retval;
+
+} /* end of readdir_r() */
+/*}}}*/
+
+/*
* Return something that can be used in a seekdir later.
*/
/*{{{ long telldir(DIR *dd)*/
*
* vms_do_aexec() and vms_do_exec() are called in response to the
* perl 'exec' function. If this follows a vfork call, then they
- * call out the the regular perl routines in doio.c which do an
+ * call out the regular perl routines in doio.c which do an
* execvp (for those who really want to try this under VMS).
* Otherwise, they do exactly what the perl docs say exec should
* do - terminate the current script and invoke a new command
* in 'VMSish fashion' (i.e. not after a call to vfork) The args
* are concatenated to form a DCL command string. If the first arg
* begins with '$' (i.e. the perl script had "\$ Type" or some such),
- * the the command string is handed off to DCL directly. Otherwise,
+ * the command string is handed off to DCL directly. Otherwise,
* the first token of the command is taken as the filespec of an image
* to run. The filespec is expanded using a default type of '.EXE' and
* the process defaults for device, directory, etc., and if found, the resultant
static void
-vms_execfree(pTHX) {
- if (PL_Cmd) {
- if (PL_Cmd != VMSCMD.dsc$a_pointer) Safefree(PL_Cmd);
- PL_Cmd = Nullch;
- }
- if (VMSCMD.dsc$a_pointer) {
- Safefree(VMSCMD.dsc$a_pointer);
- VMSCMD.dsc$w_length = 0;
- VMSCMD.dsc$a_pointer = Nullch;
+vms_execfree(struct dsc$descriptor_s *vmscmd)
+{
+ if (vmscmd) {
+ if (vmscmd->dsc$a_pointer) {
+ Safefree(vmscmd->dsc$a_pointer);
+ }
+ Safefree(vmscmd);
}
}
static unsigned long int
-setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote)
+setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote,
+ struct dsc$descriptor_s **pvmscmd)
{
char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
$DESCRIPTOR(defdsc,".EXE");
$DESCRIPTOR(defdsc2,".");
$DESCRIPTOR(resdsc,resspec);
+ struct dsc$descriptor_s *vmscmd;
struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
register char *s, *rest, *cp, *wordbreak;
register int isdcl;
+ New(402,vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
+ vmscmd->dsc$a_pointer = NULL;
+ vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
+ vmscmd->dsc$b_class = DSC$K_CLASS_S;
+ vmscmd->dsc$w_length = 0;
+ if (pvmscmd) *pvmscmd = vmscmd;
+
if (suggest_quote) *suggest_quote = 0;
if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
if (check_img && isdcl) return RMS$_FNF;
if (cando_by_name(S_IXUSR,0,resspec)) {
- New(402,VMSCMD.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
+ New(402,vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
if (!isdcl) {
- strcpy(VMSCMD.dsc$a_pointer,"$ MCR ");
+ strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
if (suggest_quote) *suggest_quote = 1;
} else {
- strcpy(VMSCMD.dsc$a_pointer,"@");
+ strcpy(vmscmd->dsc$a_pointer,"@");
if (suggest_quote) *suggest_quote = 1;
}
- strcat(VMSCMD.dsc$a_pointer,resspec);
- if (rest) strcat(VMSCMD.dsc$a_pointer,rest);
- VMSCMD.dsc$w_length = strlen(VMSCMD.dsc$a_pointer);
- return (VMSCMD.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
+ strcat(vmscmd->dsc$a_pointer,resspec);
+ if (rest) strcat(vmscmd->dsc$a_pointer,rest);
+ vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
+ return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
}
else retsts = RMS$_PRV;
}
}
/* It's either a DCL command or we couldn't find a suitable image */
- VMSCMD.dsc$w_length = strlen(cmd);
- if (cmd == PL_Cmd) {
- VMSCMD.dsc$a_pointer = PL_Cmd;
+ vmscmd->dsc$w_length = strlen(cmd);
+/* if (cmd == PL_Cmd) {
+ vmscmd->dsc$a_pointer = PL_Cmd;
if (suggest_quote) *suggest_quote = 1;
}
- else VMSCMD.dsc$a_pointer = savepvn(cmd,VMSCMD.dsc$w_length);
+ else */
+ vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
/* check if it's a symbol (for quoting purposes) */
if (suggest_quote && !*suggest_quote) {
struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
eqvdsc.dsc$a_pointer = equiv;
- iss = lib$get_symbol(&VMSCMD,&eqvdsc);
+ iss = lib$get_symbol(vmscmd,&eqvdsc);
if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
}
if (!(retsts & 1)) {
else { _ckvmssts(retsts); }
}
- return (VMSCMD.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
+ return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
} /* end of setup_cmddsc() */
bool
Perl_vms_do_exec(pTHX_ char *cmd)
{
+ struct dsc$descriptor_s *vmscmd;
if (vfork_called) { /* this follows a vfork - act Unixish */
vfork_called--;
TAINT_ENV();
TAINT_PROPER("exec");
- if ((retsts = setup_cmddsc(aTHX_ cmd,1,0)) & 1)
- retsts = lib$do_command(&VMSCMD);
+ if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
+ retsts = lib$do_command(vmscmd);
switch (retsts) {
case RMS$_FNF: case RMS$_DNF:
}
set_vaxc_errno(retsts);
if (ckWARN(WARN_EXEC)) {
- Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
- VMSCMD.dsc$w_length, VMSCMD.dsc$a_pointer, Strerror(errno));
+ Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
+ vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
}
- vms_execfree(aTHX);
+ vms_execfree(vmscmd);
}
return FALSE;
}
set_vaxc_errno(sts);
if (ckWARN(WARN_EXEC)) {
- Perl_warner(aTHX_ WARN_EXEC,"Can't spawn: %s",
+ Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
Strerror(errno));
}
}
sts = substs;
}
else {
- (void) safe_popen(cmd, "nW", (int *)&sts);
+ (void) safe_popen(aTHX_ cmd, "nW", (int *)&sts);
}
return sts;
} /* end of do_spawn() */
*/
static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
-/*{{{int my_utime(char *path, struct utimbuf *utimes)*/
-int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
+/*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
+int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
{
register int i;
long int bintime[2], len = 2, lowbit, unixtime,
set_vaxc_errno(LIB$_INVARG);
return -1;
}
- if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
+ if (do_tovmsspec((char *)file,vmsspec,0) == NULL) return -1;
if (utimes != NULL) {
/* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
* subset of the applicable information.
*/
bool
-Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
+Perl_cando(pTHX_ Mode_t bit, Uid_t effective, const Stat_t *statbufp)
{
char fname_phdev[NAM$C_MAXRSS+1];
if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
{0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
- unsigned short int retlen;
+ unsigned short int retlen, trnlnm_iter_count;
struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
union prvdef curprv;
struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
{sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
- struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
+ struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
+ {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
{0,0,0,0}};
+ struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
+ {0,0,0,0}};
+ struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
if (!fname || !*fname) return FALSE;
/* Make sure we expand logical names, since sys$check_access doesn't */
if (!strpbrk(fname,"/]>:")) {
strcpy(fileified,fname);
- while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
+ trnlnm_iter_count = 0;
+ while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
+ trnlnm_iter_count++;
+ if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
+ }
fname = fileified;
}
if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
namdsc.dsc$a_pointer = fileified;
}
- if (!usrdsc.dsc$w_length) {
- cuserid(usrname);
- usrdsc.dsc$w_length = strlen(usrname);
- }
-
switch (bit) {
case S_IXUSR: case S_IXGRP: case S_IXOTH:
access = ARM$M_EXECUTE; break;
return FALSE;
}
+ /* Before we call $check_access, create a user profile with the current
+ * process privs since otherwise it just uses the default privs from the
+ * UAF and might give false positives or negatives. This only works on
+ * VMS versions v6.0 and later since that's when sys$create_user_profile
+ * became available.
+ */
+
+ /* get current process privs and username */
+ _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
+ _ckvmssts(iosb[0]);
+
+#if defined(__VMS_VER) && __VMS_VER >= 60000000
+
+ /* find out the space required for the profile */
+ _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
+ &usrprodsc.dsc$w_length,0));
+
+ /* allocate space for the profile and get it filled in */
+ New(1330,usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
+ _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
+ &usrprodsc.dsc$w_length,0));
+
+ /* use the profile to check access to the file; free profile & analyze results */
+ retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
+ Safefree(usrprodsc.dsc$a_pointer);
+ if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
+
+#else
+
retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
+
+#endif
+
if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
else set_errno(ENOENT);
return FALSE;
}
- if (retsts == SS$_NORMAL) {
- if (!privused) return TRUE;
- /* We can get access, but only by using privs. Do we have the
- necessary privs currently enabled? */
- _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
- if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
- if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
- !curprv.prv$v_bypass) return FALSE;
- if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
- !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
- if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
- return TRUE;
- }
- if (retsts == SS$_ACCONFLICT) {
+ if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
return TRUE;
}
_ckvmssts(retsts);
char fileified[NAM$C_MAXRSS+1];
char temp_fspec[NAM$C_MAXRSS+300];
int retval = -1;
+ int saved_errno, saved_vaxc_errno;
if (!fspec) return retval;
+ saved_errno = errno; saved_vaxc_errno = vaxc$errno;
strcpy(temp_fspec, fspec);
if (statbufp == (Stat_t *) &PL_statcache)
do_tovmsspec(temp_fspec,namecache,0);
}
# endif
}
+ /* If we were successful, leave errno where we found it */
+ if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
return retval;
} /* end of flex_stat() */
void
Perl_sys_intern_init(pTHX)
{
- int ix = RAND_MAX;
- float x;
+ unsigned int ix = RAND_MAX;
+ double x;
VMSISH_HUSHED = 0;
x = (float)ix;
MY_INV_RAND_MAX = 1./x;
-
- VMSCMD.dsc$a_pointer = NULL;
- VMSCMD.dsc$w_length = 0;
- VMSCMD.dsc$b_dtype = DSC$K_DTYPE_T;
- VMSCMD.dsc$b_class = DSC$K_CLASS_S;
}
void
projects / p5sagit/p5-mst-13.2.git / blobdiff