X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=vms%2Fvms.c;h=e7687ac7aec387b593dc6c69732b02afcf5e5cfe;hb=9137345a080bfc646c2f9440cdb7bd90b8b37428;hp=7ecb29fed540c338dbacd53157523856c55c8404;hpb=f2610a60660dc5fbebc67120bf8fe194b8ff585c;p=p5sagit%2Fp5-mst-13.2.git diff --git a/vms/vms.c b/vms/vms.c index 7ecb29f..e7687ac 100644 --- a/vms/vms.c +++ b/vms/vms.c @@ -9,7 +9,6 @@ * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu */ -#include #include #include #include @@ -106,6 +105,12 @@ struct itmlst_3 { /* 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) @@ -132,6 +137,36 @@ static int no_translate_barewords; 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, @@ -140,6 +175,7 @@ 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}; @@ -149,27 +185,14 @@ Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, $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++) { @@ -199,6 +222,7 @@ Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, 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]; @@ -226,18 +250,9 @@ Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, /* 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); } @@ -248,22 +263,40 @@ Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, } } 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; } } @@ -304,47 +337,76 @@ int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx) 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. */ @@ -362,18 +424,31 @@ Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys) { 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); @@ -381,26 +456,35 @@ Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys) 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. */ @@ -442,7 +526,7 @@ prime_env_iter(void) #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 @@ -452,20 +536,12 @@ prime_env_iter(void) /* 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); @@ -494,7 +570,7 @@ prime_env_iter(void) 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++; @@ -564,7 +640,7 @@ prime_env_iter(void) 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 */ @@ -585,11 +661,25 @@ prime_env_iter(void) 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); @@ -618,7 +708,7 @@ prime_env_iter(void) /*}}}*/ -/*{{{ 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 @@ -626,18 +716,25 @@ prime_env_iter(void) * 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); @@ -651,8 +748,9 @@ Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) 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; @@ -661,7 +759,7 @@ Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) 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; } @@ -696,12 +794,12 @@ Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) 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)) { @@ -716,12 +814,42 @@ Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) 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); } } } @@ -758,10 +886,10 @@ Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) } /* 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); @@ -789,7 +917,7 @@ Perl_my_setenv(pTHX_ char *lnm,char *eqv) } /*}}}*/ -/*{{{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 @@ -1096,13 +1224,18 @@ Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act, #ifdef KILL_BY_SIGPRC #include -/* 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 @@ -1125,14 +1258,10 @@ Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act, #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 */ @@ -1167,11 +1296,29 @@ Perl_my_kill(int pid, int sig) } #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) { @@ -1322,6 +1469,18 @@ struct exit_control_block 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 @@ -1457,6 +1616,15 @@ popen_completion_ast(pInfo info) { 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; @@ -1464,7 +1632,6 @@ popen_completion_ast(pInfo info) } if (!i) return; /* unlinked, probably freed too */ - info->completion &= 0x0FFFFFFF; /* strip off "control" field */ info->done = TRUE; /* @@ -1509,8 +1676,8 @@ popen_completion_ast(pInfo info) } -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 @@ -1982,7 +2149,7 @@ store_pipelocs(pTHX) STRLEN n_a; if (head_PLOC) - free_pipelocs(&head_PLOC); + free_pipelocs(aTHX_ &head_PLOC); /* the . directory from @INC comes last */ @@ -1993,7 +2160,11 @@ store_pipelocs(pTHX) /* 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'; @@ -2009,6 +2180,9 @@ store_pipelocs(pTHX) /* 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++) { @@ -2038,7 +2212,6 @@ store_pipelocs(pTHX) p->dir[NAM$C_MAXRSS] = '\0'; } #endif - Perl_call_atexit(aTHX_ &free_pipelocs, &head_PLOC); } @@ -2117,7 +2290,7 @@ vmspipe_tempfile(pTHX) } 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"); @@ -2135,16 +2308,8 @@ vmspipe_tempfile(pTHX) 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"); @@ -2175,8 +2340,12 @@ static PerlIO * 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]; @@ -2190,6 +2359,7 @@ safe_popen(pTHX_ char *cmd, char *in_mode, int *psts) 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"); @@ -2232,7 +2402,7 @@ safe_popen(pTHX_ char *cmd, char *in_mode, int *psts) 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; } @@ -2241,7 +2411,7 @@ safe_popen(pTHX_ char *cmd, char *in_mode, int *psts) 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: @@ -2263,7 +2433,7 @@ safe_popen(pTHX_ char *cmd, char *in_mode, int *psts) } 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; @@ -2419,10 +2589,10 @@ safe_popen(pTHX_ char *cmd, char *in_mode, int *psts) 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++; @@ -2445,7 +2615,11 @@ safe_popen(pTHX_ char *cmd, char *in_mode, int *psts) 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)); @@ -2464,9 +2638,13 @@ safe_popen(pTHX_ char *cmd, char *in_mode, int *psts) _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) { @@ -2591,7 +2769,7 @@ I32 Perl_my_pclose(pTHX_ PerlIO *fp) } /* 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. */ @@ -2609,6 +2787,7 @@ Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags) pInfo info; int done; int sts; + int j; if (statusp) *statusp = 0; @@ -2626,11 +2805,20 @@ Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags) 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 @@ -2649,24 +2837,18 @@ Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags) * 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 @@ -2677,9 +2859,9 @@ Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags) 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]; @@ -2702,63 +2884,23 @@ Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags) /* 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() */ /*}}}*/ /*}}}*/ @@ -2990,6 +3132,7 @@ static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts) 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; @@ -3006,7 +3149,11 @@ static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts) } 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); } @@ -3312,6 +3459,8 @@ static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts) 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; @@ -3320,9 +3469,12 @@ static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts) 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,".]")) { @@ -3497,7 +3649,9 @@ static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts) { 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; @@ -3544,11 +3698,14 @@ static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts) 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)) { @@ -3869,7 +4026,7 @@ static void mp_expand_wild_cards(pTHX_ char *item, 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); @@ -3919,11 +4076,11 @@ mp_getredirection(pTHX_ int *ac, char ***av) */ 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 '>', '>>', @@ -4137,6 +4294,7 @@ static void mp_expand_wild_cards(pTHX_ char *item, int expcount = 0; unsigned long int context = 0; int isunix = 0; +int item_len = 0; char *had_version; char *had_device; int had_directory; @@ -4156,6 +4314,20 @@ unsigned long int zero = 0, sts; 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; @@ -4272,10 +4444,12 @@ static void 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; @@ -4311,13 +4485,13 @@ pipe_and_fork(pTHX_ char **cmargv) } *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, ""); @@ -4387,6 +4561,10 @@ vms_image_init(int *argcp, char ***argvp) { 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++) { @@ -4436,15 +4614,19 @@ vms_image_init(int *argcp, char ***argvp) * 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; @@ -4478,7 +4660,7 @@ vms_image_init(int *argcp, char ***argvp) 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 (void) decc$set_reentrancy(C$C_MULTITHREAD); @@ -4657,6 +4839,18 @@ Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts) * 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]) @@ -4674,15 +4868,18 @@ Perl_opendir(pTHX_ char *name) 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); @@ -4696,6 +4893,12 @@ Perl_opendir(pTHX_ char *name) 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() */ @@ -4721,6 +4924,10 @@ closedir(DIR *dd) { (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); } /*}}}*/ @@ -4835,6 +5042,28 @@ Perl_readdir(pTHX_ DIR *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)*/ @@ -4880,7 +5109,7 @@ Perl_seekdir(pTHX_ DIR *dd, long count) * * 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 @@ -4893,7 +5122,7 @@ Perl_seekdir(pTHX_ DIR *dd, long count) * 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 @@ -4916,15 +5145,13 @@ my_vfork() 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); } } @@ -4973,17 +5200,26 @@ setup_argstr(pTHX_ SV *really, SV **mark, SV **sp) 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) @@ -5067,29 +5303,30 @@ setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote) 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) { @@ -5098,7 +5335,7 @@ setup_cmddsc(pTHX_ char *cmd, int check_img, int *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)) { @@ -5109,7 +5346,7 @@ setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote) 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() */ @@ -5140,6 +5377,7 @@ Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp) bool Perl_vms_do_exec(pTHX_ char *cmd) { + struct dsc$descriptor_s *vmscmd; if (vfork_called) { /* this follows a vfork - act Unixish */ vfork_called--; @@ -5155,8 +5393,8 @@ Perl_vms_do_exec(pTHX_ char *cmd) 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: @@ -5178,10 +5416,10 @@ Perl_vms_do_exec(pTHX_ char *cmd) } 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; @@ -5232,14 +5470,14 @@ Perl_do_spawn(pTHX_ char *cmd) } 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() */ @@ -6227,8 +6465,8 @@ Perl_my_localtime(pTHX_ const time_t *timep) */ 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, @@ -6261,7 +6499,7 @@ int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes) 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) @@ -6483,7 +6721,7 @@ is_null_device(name) * 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); @@ -6534,19 +6772,27 @@ Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname) {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; @@ -6559,11 +6805,6 @@ Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname) 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; @@ -6577,7 +6818,39 @@ Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname) 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) { @@ -6587,20 +6860,7 @@ Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname) 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); @@ -6651,8 +6911,10 @@ Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp) 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); @@ -6703,6 +6965,8 @@ Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp) } # 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() */ @@ -7211,18 +7475,13 @@ Perl_sys_intern_clear(pTHX) 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