[patch@35050] replace pathify_dirspec in VMS with new version

--- /rsync_root/perl/vms/vms.c	Fri Dec  5 12:13:19 2008
+++ vms/vms.c	Sat Dec  6 03:31:43 2008
@@ -362,6 +362,40 @@
 int decc_dir_barename = 0;
 
 static int vms_debug_on_exception = 0;
+static int vms_debug_fileify = 0;
+
+
+/* Simple logical name translation */
+static int simple_trnlnm
+   (const char * logname,
+    char * value,
+    int value_len)
+{
+    const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
+    const unsigned long attr = LNM$M_CASE_BLIND;
+    struct dsc$descriptor_s name_dsc;
+    int status;
+    unsigned short result;
+    struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
+                                {0, 0, 0, 0}};
+
+    name_dsc.dsc$w_length = strlen(logname);
+    name_dsc.dsc$a_pointer = (char *)logname;
+    name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
+    name_dsc.dsc$b_class = DSC$K_CLASS_S;
+
+    status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
+
+    if ($VMS_STATUS_SUCCESS(status)) {
+
+	 /* Null terminate and return the string */
+	/*--------------------------------------*/
+	value[result] = 0;
+        return result;
+    }
+
+    return 0;
+}
 
 /* Is this a UNIX file specification?
  *   No longer a simple check with EFS file specs
@@ -888,6 +922,27 @@
 }
 
 
+/* Routine to determine if the file specification ends with .dir */
+static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
+
+    /* e_len must be 4, and version must be <= 2 characters */
+    if (e_len != 4 || vs_len > 2)
+        return 0;
+
+    /* If a version number is present, it needs to be one */
+    if ((vs_len == 2) && (vs_spec[1] != '1'))
+        return 0;
+
+    /* Look for the DIR on the extension */
+    if ((toupper(e_spec[1]) == 'D') &&
+        (toupper(e_spec[2]) == 'I') &&
+        (toupper(e_spec[3]) == 'R')) {
+        return 1;
+    }
+    return 0;
+}
+
+
 /* my_maxidx
  * Routine to retrieve the maximum equivalence index for an input
  * logical name.  Some calls to this routine have no knowledge if
@@ -6236,280 +6291,434 @@
 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
 
-/*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
-static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
-{
-    static char __pathify_retbuf[VMS_MAXRSS];
-    unsigned long int retlen;
-    char *retpath, *cp1, *cp2, *trndir;
+static char * int_pathify_dirspec_simple(const char * dir, char * buf,
+    char * v_spec, int v_len, char * r_spec, int r_len,
+    char * d_spec, int d_len, char * n_spec, int n_len,
+    char * e_spec, int e_len, char * vs_spec, int vs_len) {
+
+    /* VMS specification - Try to do this the simple way */
+    if ((v_len + r_len + d_len) > 0) {
+        int is_dir;
+
+        /* No name or extension component, already a directory */
+        if ((n_len + e_len + vs_len) == 0) {
+            strcpy(buf, dir);
+            return buf;
+        }
+
+        /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
+        /* This results from catfile() being used instead of catdir() */
+        /* So even though it should not work, we need to allow it */
+
+        /* If this is .DIR;1 then do a simple conversion */
+        is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
+        if (is_dir || (e_len == 0)) {
+             int len;
+             len = v_len + r_len + d_len - 1;
+             char dclose = d_spec[d_len - 1];
+             strncpy(buf, dir, len);
+             buf[len] = '.';
+             len++;
+             strncpy(&buf[len], n_spec, n_len);
+             len += n_len;
+             buf[len] = dclose;
+             buf[len + 1] = '\0';
+             return buf;
+        }
+
+#ifdef HAS_SYMLINK
+        else {
+            /* In the olden days, a directory needed to have a .DIR */
+            /* extension to be a valid directory, but now it could  */
+            /* be a symbolic link */
+            int len;
+            len = v_len + r_len + d_len - 1;
+            char dclose = d_spec[d_len - 1];
+            strncpy(buf, dir, len);
+            buf[len] = '.';
+            len++;
+            strncpy(&buf[len], n_spec, n_len);
+            len += n_len;
+            if (e_len > 0) {
+                if (decc_efs_charset) {
+                    buf[len] = '^';
+                    len++;
+                    strncpy(&buf[len], e_spec, e_len);
+                    len += e_len;
+                } else {
+                    set_vaxc_errno(RMS$_DIR);
+                    set_errno(ENOTDIR);
+                    return NULL;
+                }
+            }
+            buf[len] = dclose;
+            buf[len + 1] = '\0';
+            return buf;
+        }
+#else
+        else {
+            set_vaxc_errno(RMS$_DIR);
+            set_errno(ENOTDIR);
+            return NULL;
+        }
+#endif
+    }
+    set_vaxc_errno(RMS$_DIR);
+    set_errno(ENOTDIR);
+    return NULL;
+}
+
+
+/* Common simple case - Expand an already VMS spec */
+static char * 
+int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
+
+  /* Temporary hack until routine is converted to not take a thread context */
+#if defined(PERL_IMPLICIT_CONTEXT)
+    pTHX = NULL;
+#endif
+
+    opts |= PERL_RMSEXPAND_M_VMS_IN;
+    return do_rmsexpand(filespec, outbuf, 0, NULL, opts, NULL, NULL); 
+}
+
+
+
+
+/* Internal routine to make sure or convert a directory to be in a */
+/* path specification.  No utf8 flag because it is not changed or used */
+static char *int_pathify_dirspec(const char *dir, char *buf)
+{
+    char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
+    int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
+    char * exp_spec, *ret_spec;
+    char * trndir;
     unsigned short int trnlnm_iter_count;
     STRLEN trnlen;
-    int sts;
-    if (utf8_fl != NULL)
-	*utf8_fl = 0;
+    int need_to_lower;
+
+    if (vms_debug_fileify) {
+        if (dir == NULL)
+            fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
+        else
+            fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
+    }
+
+    /* We may need to lower case the result if we translated  */
+    /* a logical name or got the current working directory */
+    need_to_lower = 0;
 
     if (!dir || !*dir) {
-      set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
+      set_errno(EINVAL);
+      set_vaxc_errno(SS$_BADPARAM);
+      return NULL;
     }
 
     trndir = PerlMem_malloc(VMS_MAXRSS);
-    if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
-    if (*dir) strcpy(trndir,dir);
-    else getcwd(trndir,VMS_MAXRSS - 1);
+    if (trndir == NULL)
+        _ckvmssts_noperl(SS$_INSFMEM);
+
+    /* If no directory specified use the current default */
+    if (*dir)
+        strcpy(trndir, dir);
+    else {
+        getcwd(trndir, VMS_MAXRSS - 1);
+        need_to_lower = 1;
+    }
 
+    /* now deal with bare names that could be logical names */
     trnlnm_iter_count = 0;
     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
-	   && my_trnlnm(trndir,trndir,0)) {
-      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,".]")) {
-        if (buf) retpath = buf;
-        else if (ts) Newx(retpath,strlen(dir)+10,char);
-        else retpath = __pathify_retbuf;
-        strcpy(retpath,dir);
-        strcat(retpath,":[000000]");
-	PerlMem_free(trndir);
-        return retpath;
-      }
+           && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
+        trnlnm_iter_count++; 
+        need_to_lower = 1;
+        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,".]")) {
+            strcpy(buf, dir);
+            strcat(buf, ":[000000]");
+            PerlMem_free(trndir);
+
+            if (vms_debug_fileify) {
+                fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
+            }
+            return buf;
+        }
     }
 
-    /* At this point we do not work with *dir, but the copy in
-     * *trndir that is modifiable.
-     */
+    /* At this point we do not work with *dir, but the copy in  *trndir */
 
-    if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
-      if (*trndir == '.' && (*(trndir+1) == '\0' ||
-                          (*(trndir+1) == '.' && *(trndir+2) == '\0')))
-        retlen = 2 + (*(trndir+1) != '\0');
-      else {
-        if ( !(cp1 = strrchr(trndir,'/')) &&
-             !(cp1 = strrchr(trndir,']')) &&
-             !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
-        if ((cp2 = strchr(cp1,'.')) != NULL &&
-            (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
-             !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
-              (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
-              (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
-          int ver; char *cp3;
+    if (need_to_lower && !decc_efs_case_preserve) {
+        /* Legacy mode, lower case the returned value */
+        __mystrtolower(trndir);
+    }
 
-	  /* For EFS or ODS-5 look for the last dot */
-	  if (decc_efs_charset) {
-	    cp2 = strrchr(cp1,'.');
-	  }
-	  if (vms_process_case_tolerant) {
-              if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
-                  !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
-                  !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
-                  (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
-                  (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
-                            (ver || *cp3)))))) {
-		PerlMem_free(trndir);
-                set_errno(ENOTDIR);
-                set_vaxc_errno(RMS$_DIR);
-                return NULL;
-              }
-	  }
-	  else {
-              if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
-                  !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
-                  !*(cp2+3) || *(cp2+3) != 'R' ||
-                  (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
-                  (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
-                            (ver || *cp3)))))) {
-		PerlMem_free(trndir);
-                set_errno(ENOTDIR);
-                set_vaxc_errno(RMS$_DIR);
-                return NULL;
-              }
-	  }
-          retlen = cp2 - trndir + 1;
-        }
-        else {  /* No file type present.  Treat the filename as a directory. */
-          retlen = strlen(trndir) + 1;
+
+    /* Some special cases, '..', '.' */
+    sts = 0;
+    if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
+       /* Force UNIX filespec */
+       sts = 1;
+
+    } else {
+        /* Is this Unix or VMS format? */
+        sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
+                             &d_spec, &d_len, &n_spec, &n_len, &e_spec,
+                             &e_len, &vs_spec, &vs_len);
+        if (sts == 0) {
+
+            /* Just a filename? */
+            if ((v_len + r_len + d_len) == 0) {
+
+                /* Now we have a problem, this could be Unix or VMS */
+                /* We have to guess.  .DIR usually means VMS */
+
+                /* In UNIX report mode, the .DIR extension is removed */
+                /* if one shows up, it is for a non-directory or a directory */
+                /* in EFS charset mode */
+
+                /* So if we are in Unix report mode, assume that this */
+                /* is a relative Unix directory specification */
+
+                sts = 1;
+                if (!decc_filename_unix_report && decc_efs_charset) {
+                    int is_dir;
+                    is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
+
+                    if (is_dir) {
+                        /* Traditional mode, assume .DIR is directory */
+                        buf[0] = '[';
+                        buf[1] = '.';
+                        strncpy(&buf[2], n_spec, n_len);
+                        buf[n_len + 2] = ']';
+                        buf[n_len + 3] = '\0';
+                        PerlMem_free(trndir);
+                        if (vms_debug_fileify) {
+                            fprintf(stderr,
+                                    "int_pathify_dirspec: buf = %s\n",
+                                    buf);
+                        }
+                        return buf;
+                    }
+                }
+            }
         }
-      }
-      if (buf) retpath = buf;
-      else if (ts) Newx(retpath,retlen+1,char);
-      else retpath = __pathify_retbuf;
-      strncpy(retpath, trndir, retlen-1);
-      if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
-        retpath[retlen-1] = '/';      /* with '/', add it. */
-        retpath[retlen] = '\0';
-      }
-      else retpath[retlen-1] = '\0';
     }
-    else {  /* VMS-style directory spec */
-      char *esa, *esal, *cp;
-      char *my_esa;
-      int my_esa_len;
-      unsigned long int sts, cmplen, haslower;
-      struct FAB dirfab = cc$rms_fab;
-      int dirlen;
-      rms_setup_nam(savnam);
-      rms_setup_nam(dirnam);
+    if (sts == 0) {
+        ret_spec = int_pathify_dirspec_simple(trndir, buf,
+            v_spec, v_len, r_spec, r_len,
+            d_spec, d_len, n_spec, n_len,
+            e_spec, e_len, vs_spec, vs_len);
+
+        if (ret_spec != NULL) {
+            PerlMem_free(trndir);
+            if (vms_debug_fileify) {
+                fprintf(stderr,
+                        "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
+            }
+            return ret_spec;
+        }
 
-      /* If we've got an explicit filename, we can just shuffle the string. */
-      if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
-             (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
-        if ((cp2 = strchr(cp1,'.')) != NULL) {
-          int ver; char *cp3;
-	  if (vms_process_case_tolerant) {
-              if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
-                  !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
-                  !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
-                  (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
-                  (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
-                            (ver || *cp3)))))) {
-	       PerlMem_free(trndir);
-               set_errno(ENOTDIR);
-               set_vaxc_errno(RMS$_DIR);
-               return NULL;
-             }
-	  }
-	  else {
-              if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
-                  !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
-                  !*(cp2+3) || *(cp2+3) != 'R' ||
-                  (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
-                  (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
-                            (ver || *cp3)))))) {
-	       PerlMem_free(trndir);
-               set_errno(ENOTDIR);
-               set_vaxc_errno(RMS$_DIR);
-               return NULL;
-             }
-	  }
+        /* Simple way did not work, which means that a logical name */
+        /* was present for the directory specification.             */
+        /* Need to use an rmsexpand variant to decode it completely */
+        exp_spec = PerlMem_malloc(VMS_MAXRSS);
+        if (exp_spec == NULL)
+            _ckvmssts_noperl(SS$_INSFMEM);
+
+        ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
+        if (ret_spec != NULL) {
+            sts = vms_split_path(exp_spec, &v_spec, &v_len,
+                                 &r_spec, &r_len, &d_spec, &d_len,
+                                 &n_spec, &n_len, &e_spec,
+                                 &e_len, &vs_spec, &vs_len);
+            if (sts == 0) {
+                ret_spec = int_pathify_dirspec_simple(
+                    exp_spec, buf, v_spec, v_len, r_spec, r_len,
+                    d_spec, d_len, n_spec, n_len,
+                    e_spec, e_len, vs_spec, vs_len);
+
+                if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
+                    /* Legacy mode, lower case the returned value */
+                    __mystrtolower(ret_spec);
+                }
+            } else {
+                set_vaxc_errno(RMS$_DIR);
+                set_errno(ENOTDIR);
+                ret_spec = NULL;
+            }
         }
-        else {  /* No file type, so just draw name into directory part */
-          for (cp2 = cp1; *cp2; cp2++) ;
+        PerlMem_free(exp_spec);
+        PerlMem_free(trndir);
+        if (vms_debug_fileify) {
+            if (ret_spec == NULL)
+                fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
+            else
+                fprintf(stderr,
+                        "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
         }
-        *cp2 = *cp1;
-        *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
-        *cp1 = '.';
-        /* We've now got a VMS 'path'; fall through */
-      }
+        return ret_spec;
 
-      dirlen = strlen(trndir);
-      if (trndir[dirlen-1] == ']' ||
-          trndir[dirlen-1] == '>' ||
-          trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
-        if (buf) retpath = buf;
-        else if (ts) Newx(retpath,strlen(trndir)+1,char);
-        else retpath = __pathify_retbuf;
-        strcpy(retpath,trndir);
-	PerlMem_free(trndir);
-        return retpath;
-      }
-      rms_set_fna(dirfab, dirnam, trndir, dirlen);
-      esa = PerlMem_malloc(VMS_MAXRSS);
-      if (esa == NULL) _ckvmssts(SS$_INSFMEM);
-      esal = NULL;
-#if !defined(__VAX) && defined(NAML$C_MAXRSS)
-      esal = PerlMem_malloc(VMS_MAXRSS);
-      if (esal == NULL) _ckvmssts(SS$_INSFMEM);
-#endif
-      rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
-      rms_bind_fab_nam(dirfab, dirnam);
-      rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
-#ifdef NAM$M_NO_SHORT_UPCASE
-      if (decc_efs_case_preserve)
-	  rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
-#endif
+    } else {
+        /* Unix specification, Could be trivial conversion */
+        STRLEN dir_len;
+        dir_len = strlen(trndir);
+
+        /* If the extended file character set is in effect */
+        /* then pathify is simple */
+
+        if (!decc_efs_charset) {
+            /* Have to deal with traiing '.dir' or extra '.' */
+            /* that should not be there in legacy mode, but is */
+
+            char * lastdot;
+            char * lastslash;
+            int is_dir;
+
+            lastslash = strrchr(trndir, '/');
+            if (lastslash == NULL)
+                lastslash = trndir;
+            else
+                lastslash++;
+
+            lastdot = NULL;
+
+            /* '..' or '.' are valid directory components */
+            is_dir = 0;
+            if (lastslash[0] == '.') {
+                if (lastslash[1] == '\0') {
+                   is_dir = 1;
+                } else if (lastslash[1] == '.') {
+                    if (lastslash[2] == '\0') {
+                        is_dir = 1;
+                    } else {
+                        /* And finally allow '...' */
+                        if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
+                            is_dir = 1;
+                        }
+                    }
+                }             
+            }
 
-      for (cp = trndir; *cp; cp++)
-        if (islower(*cp)) { haslower = 1; break; }
+            if (!is_dir) {
+               lastdot = strrchr(lastslash, '.');
+            }
+            if (lastdot != NULL) {
+                STRLEN e_len;
 
-      if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
-        if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
-	  rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
-          sts = sys$parse(&dirfab) & STS$K_SUCCESS;
+                /* '.dir' is discarded, and any other '.' is invalid */
+                e_len = strlen(lastdot);
+
+                is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
+
+                if (is_dir) {
+                    dir_len = dir_len - 4;
+
+                }
+            }
         }
-        if (!sts) {
-	  PerlMem_free(trndir);
-	  PerlMem_free(esa);
-	  if (esal != NULL)
-	    PerlMem_free(esal);
-          set_errno(EVMSERR);
-          set_vaxc_errno(dirfab.fab$l_sts);
-          return NULL;
+
+        strcpy(buf, trndir);
+        if (buf[dir_len - 1] != '/') {
+            buf[dir_len] = '/';
+            buf[dir_len + 1] = '\0';
+        }
+
+        /* Under ODS-2 rules, '.' becomes '_', so fix it up */
+        if (!decc_efs_charset) {
+             int dir_start = 0;
+             char * str = buf;
+             if (str[0] == '.') {
+                 char * dots = str;
+                 int cnt = 1;
+                 while ((dots[cnt] == '.') && (cnt < 3))
+                     cnt++;
+                 if (cnt <= 3) {
+                     if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
+                         dir_start = 1;
+                         str += cnt;
+                     }
+                 }
+             }
+             for (; *str; ++str) {
+                 while (*str == '/') {
+                     dir_start = 1;
+                     *str++;
+                 }
+                 if (dir_start) {
+
+                     /* Have to skip up to three dots which could be */
+                     /* directories, 3 dots being a VMS extension for Perl */
+                     char * dots = str;
+                     int cnt = 0;
+                     while ((dots[cnt] == '.') && (cnt < 3)) {
+                         cnt++;
+                     }
+                     if (dots[cnt] == '\0')
+                         break;
+                     if ((cnt > 1) && (dots[cnt] != '/')) {
+                         dir_start = 0;
+                     } else {
+                         str += cnt;
+                     }
+
+                     /* too many dots? */
+                     if ((cnt == 0) || (cnt > 3)) {
+                         dir_start = 0;
+                     }
+                 }
+                 if (!dir_start && (*str == '.')) {
+                     *str = '_';
+                 }                 
+             }
         }
-      }
-      else {
-        savnam = dirnam;
-	/* Does the file really exist? */
-        if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
-          if (dirfab.fab$l_sts != RMS$_FNF) {
-	    int sts1;
-	    sts1 = rms_free_search_context(&dirfab);
-	    PerlMem_free(trndir);
-	    PerlMem_free(esa);
-	    if (esal != NULL)
-		PerlMem_free(esal);
-            set_errno(EVMSERR);
-            set_vaxc_errno(dirfab.fab$l_sts);
-            return NULL;
-          }
-          dirnam = savnam; /* No; just work with potential name */
+        PerlMem_free(trndir);
+        ret_spec = buf;
+        if (vms_debug_fileify) {
+            if (ret_spec == NULL)
+                fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
+            else
+                fprintf(stderr,
+                        "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
         }
-      }
-      if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
-        /* Yep; check version while we're at it, if it's there. */
-        cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
-        if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
-	  int sts2;
-          /* Something other than .DIR[;1].  Bzzt. */
-	  sts2 = rms_free_search_context(&dirfab);
-	  PerlMem_free(trndir);
-	  PerlMem_free(esa);
-	  if (esal != NULL)
-	     PerlMem_free(esal);
-          set_errno(ENOTDIR);
-          set_vaxc_errno(RMS$_DIR);
-          return NULL;
+        return ret_spec;
+    }
+}
+
+/*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
+static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
+{
+    static char __pathify_retbuf[VMS_MAXRSS];
+    char * pathified, *ret_spec, *ret_buf;
+    
+    pathified = NULL;
+    ret_buf = buf;
+    if (ret_buf == NULL) {
+        if (ts) {
+            Newx(pathified, VMS_MAXRSS, char);
+            if (pathified == NULL)
+                _ckvmssts(SS$_INSFMEM);
+            ret_buf = pathified;
+        } else {
+            ret_buf = __pathify_retbuf;
         }
-      }
-      /* Make sure we are using the right buffer */
-      if (esal != NULL) {
-	/* We only need one, clean up the other */
-	my_esa = esal;
-	my_esa_len = rms_nam_esll(dirnam);
-      } else {
-	my_esa = esa;
-        my_esa_len = rms_nam_esl(dirnam);
-      }
+    }
 
-      /* Null terminate the buffer */
-      my_esa[my_esa_len] = '\0';
+    ret_spec = int_pathify_dirspec(dir, ret_buf);
 
-      /* OK, the type was fine.  Now pull any file name into the
-         directory path. */
-      if ((cp1 = strrchr(my_esa,']'))) *(rms_nam_typel(dirnam)) = ']';
-      else {
-        cp1 = strrchr(my_esa,'>');
-        *(rms_nam_typel(dirnam)) = '>';
-      }
-      *cp1 = '.';
-      *(rms_nam_typel(dirnam) + 1) = '\0';
-      retlen = (rms_nam_typel(dirnam)) - my_esa + 2;
-      if (buf) retpath = buf;
-      else if (ts) Newx(retpath,retlen,char);
-      else retpath = __pathify_retbuf;
-      strcpy(retpath,my_esa);
-      PerlMem_free(esa);
-      if (esal != NULL)
-	  PerlMem_free(esal);
-      sts = rms_free_search_context(&dirfab);
-      /* $PARSE may have upcased filespec, so convert output to lower
-       * case if input contained any lowercase characters. */
-      if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
+    if (ret_spec == NULL) {
+       /* Cleanup on isle 5, if this is thread specific we need to deallocate */
+       if (pathified)
+           Safefree(pathified);
     }
 
-    PerlMem_free(trndir);
-    return retpath;
+    return ret_spec;
+
 }  /* end of do_pathify_dirspec() */
+
 /*}}}*/
 /* External entry points */
 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
@@ -6520,6 +6729,7 @@
 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
+
 
 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)