diff options
Diffstat (limited to 'vms')
| -rw-r--r-- | vms/vms.c | 80 | ||||
| -rw-r--r-- | vms/vmsish.h | 1 |
2 files changed, 53 insertions, 28 deletions
@@ -262,7 +262,7 @@ Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, } } else if (!ivlnm) { - if (idx == 0) { + 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; @@ -290,7 +290,6 @@ Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, (retsts == SS$_NOLOGNAM)) { continue; } } else { - idx -= 1; retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst); if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; } if (retsts == SS$_NOLOGNAM) continue; @@ -341,7 +340,7 @@ Perl_my_getenv(pTHX_ const char *lnm, bool sys) char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv; unsigned long int idx = 0; int trnsuccess, success, secure, saverr, savvmserr; - int midx; + int midx, flags; SV *tmpsv; midx = my_maxidx((char *) lnm) + 1; @@ -370,27 +369,43 @@ Perl_my_getenv(pTHX_ const char *lnm, bool sys) return eqv; } else { - if ((cp2 = strchr(lnm,';')) != NULL) { - strcpy(uplnm,lnm); - uplnm[cp2-lnm] = '\0'; - idx = strtoul(cp2+1,NULL,0) + 1; - 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. */ @@ -408,7 +423,7 @@ Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys) { char *buf, *cp1, *cp2; unsigned long idx = 0; - int midx; + int midx, flags; static char *__my_getenv_len_eqv = NULL; int secure, saverr, savvmserr; SV *tmpsv; @@ -440,26 +455,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) + 1; - 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. */ diff --git a/vms/vmsish.h b/vms/vmsish.h index 7f326a8665..1a29aa6b59 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -307,6 +307,7 @@ struct interp_intern { /* Flags for vmstrnenv() */ #define PERL__TRNENV_SECURE 0x01 +#define PERL__TRNENV_JOIN_SEARCHLIST 0x02 /* Handy way to vet calls to VMS system services and RTL routines. */ #define _ckvmssts(call) STMT_START { register unsigned long int __ckvms_sts; \ |