From: Craig A. Berry <craigberry@mac.com>
Date: Wed, 2 Apr 2003 18:09:03 +0000 (-0600)
Subject: VMS %ENV fix (follow-up to 18852)
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=843027b0d05d16cd1217a5e0476a463b117fb188;p=p5sagit%2Fp5-mst-13.2.git

VMS %ENV fix (follow-up to 18852)
From: "Craig A. Berry" <craigberry@mac.com>
Message-Id: <5.2.0.9.0.20030402173822.01ba1df0@dcichiexc1>

p4raw-id: //depot/perl@19143
---

diff --git a/vms/vms.c b/vms/vms.c
index 4a5d41c..fb30f1c 100644
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -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 7f326a8..1a29aa6 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; \