[perl #22622] Bogus error codes from File::Copy::move
[p5sagit/p5-mst-13.2.git] / vms / vms.c
index d5c8a98..2bcf087 100644 (file)
--- 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.  */
@@ -2728,7 +2752,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.
    */
@@ -2777,7 +2801,7 @@ Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
 
     /* fall through if this child is not one of our own pipe children */
 
-#if defined(__CRTL_VER) && __CRTL_VER >= 70100322
+#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
@@ -2796,7 +2820,7 @@ 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");
@@ -4618,6 +4642,12 @@ vms_image_init(int *argcp, char ***argvp)
   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
 
   getredirection(argcp,argvp);
+#if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
+  {
+# include <reentrancy.h>
+  (void) decc$set_reentrancy(C$C_MULTITHREAD);
+  }
+#endif
   return;
 }
 /*}}}*/
@@ -4845,7 +4875,7 @@ 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_5005THREADS) || defined(USE_ITHREADS)
+#if defined(USE_ITHREADS)
     New(1308,dd->mutex,1,perl_mutex);
     MUTEX_INIT( (perl_mutex *) dd->mutex );
 #else
@@ -4876,7 +4906,7 @@ closedir(DIR *dd)
 {
     (void)lib$find_file_end(&dd->context);
     Safefree(dd->pattern);
-#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
+#if defined(USE_ITHREADS)
     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
     Safefree(dd->mutex);
 #endif