In adding the ability to handle very long %ENV values in change #18852, I
failed to distinguish adequately between the uses of logical names to
support the %ENV hash and other internal uses of logical names (such as
manipulating file specs in VMSish ways). This sometimes brings a
fixed-length buffer up against a value that is too long for it, causing
stack corruption and crashes. The attached patch fixes that by adding a
flag to the logical name translation infrastructure in vms.c so that only
Perl_my_getenv and Perl_my_getenv_len will attempt to take advantage of the
longer values. The internal function my_trnlnm may once again be safely
used as it always has for logical name translations not related to the
support of %ENV.
This should be applied to both 5.8.1 and bleadperl.
--- vms/vmsish.h_orig Tue Apr 1 09:53:48 2003
+++ vms/vmsish.h Tue Apr 1 09:53:49 2003
@@ -307,6 +307,7 @@
/* 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; \
--- vms/vms.c;-0 Tue Apr 1 00:43:14 2003
+++ vms/vms.c Tue Apr 1 13:08:44 2003
@@ -284,7 +284,7 @@
}
}
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;
@@ -312,7 +312,6 @@
(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;
@@ -363,7 +362,7 @@
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;
@@ -392,27 +391,43 @@
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. */
@@ -430,7 +445,7 @@
{
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;
@@ -462,26 +477,35 @@
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. */
