X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=vms%2Fvms.c;h=40348e00564b9e851457d4b7c1eea388b4398e1c;hb=e3acbfda4f677df31695d7b2b63b7e9e854a3514;hp=ebb05a142a39fb914bdf3a02b85b8c51aebcea25;hpb=a6c403648ecd5cc72235fdb1e7535523a8ff2ac9;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/vms/vms.c b/vms/vms.c
index ebb05a1..40348e0 100644
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -2,8 +2,8 @@
  *
  * VMS-specific routines for perl5
  *
- * Last revised: 24-Apr-1999 by Charles Bailey  bailey@newman.upenn.edu
- * Version: 5.5.58
+ * Last revised: 20-Aug-1999 by Charles Bailey  bailey@newman.upenn.edu
+ * Version: 5.5.60
  */
 
 #include <acedef.h>
@@ -68,6 +68,9 @@
 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 #endif
 
+#if defined(NEED_AN_H_ERRNO)
+dEXT int h_errno;
+#endif
 
 struct itmlst_3 {
   unsigned short int buflen;
@@ -76,6 +79,16 @@ struct itmlst_3 {
   unsigned short int *retlen;
 };
 
+#define do_fileify_dirspec(a,b,c)	mp_do_fileify_dirspec(aTHX_ a,b,c)
+#define do_pathify_dirspec(a,b,c)	mp_do_pathify_dirspec(aTHX_ a,b,c)
+#define do_tovmsspec(a,b,c)		mp_do_tovmsspec(aTHX_ a,b,c)
+#define do_tovmspath(a,b,c)		mp_do_tovmspath(aTHX_ a,b,c)
+#define do_rmsexpand(a,b,c,d,e)		mp_do_rmsexpand(aTHX_ a,b,c,d,e)
+#define do_tounixspec(a,b,c)		mp_do_tounixspec(aTHX_ a,b,c)
+#define do_tounixpath(a,b,c)		mp_do_tounixpath(aTHX_ a,b,c)
+#define expand_wild_cards(a,b,c,d)	mp_expand_wild_cards(aTHX_ a,b,c,d)
+#define getredirection(a,b)		mp_getredirection(aTHX_ a,b)
+
 static char *__mystrtolower(char *str)
 {
   if (str) for (; *str; ++str) *str= tolower(*str);
@@ -91,12 +104,19 @@ static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 static struct dsc$descriptor_s **env_tables = defenv;
 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 
+/* True if we shouldn't treat barewords as logicals during directory */
+/* munching */ 
+static int no_translate_barewords;
+
+/* Temp for subprocess commands */
+static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
+
 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 int
-vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
+Perl_vmstrnenv(pTHX_ const char *lnm, char *eqv, unsigned long int idx,
   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 {
-    char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
+    char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
     unsigned char acmode;
@@ -106,6 +126,18 @@ vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
                                  {0, 0, 0, 0}};
     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
+#if defined(USE_THREADS)
+    /* We jump through these hoops because we can be called at */
+    /* platform-specific initialization time, which is before anything is */
+    /* set up--we can't even do a plain dTHX since that relies on the */
+    /* interpreter structure to be initialized */
+    struct perl_thread *thr;
+    if (PL_curinterp) {
+      thr = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
+    } else {
+      thr = NULL;
+    }
+#endif
 
     if (!lnm || !eqv || idx > LNM$_MAX_INDEX) {
       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
@@ -119,6 +151,7 @@ vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
     }
     lnmdsc.dsc$w_length = cp1 - lnm;
     lnmdsc.dsc$a_pointer = uplnm;
+    uplnm[lnmdsc.dsc$w_length] = '\0';
     secure = flags & PERL__TRNENV_SECURE;
     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
     if (!tabvec || !*tabvec) tabvec = env_tables;
@@ -130,7 +163,7 @@ vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
           int i;
           if (!environ) {
             ivenv = 1; 
-            warn("Can't read CRTL environ\n");
+            Perl_warn(aTHX_ "Can't read CRTL environ\n");
             continue;
           }
           retsts = SS$_NOLOGNAM;
@@ -159,8 +192,22 @@ vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
             if (eqvlen > 1024) {
               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
               eqvlen = 1024;
-              if (ckWARN(WARN_MISC))
-                warner(WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
+	      /* Special hack--we might be called before the interpreter's */
+	      /* fully initialized, in which case either thr or PL_curcop */
+	      /* might be bogus. We have to check, since ckWARN needs them */
+	      /* both to be valid if running threaded */
+#if defined(USE_THREADS)
+	      if (thr && PL_curcop) {
+#endif
+		if (ckWARN(WARN_MISC)) {
+		  Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
+		}
+#if defined(USE_THREADS)
+	      } else {
+		  Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
+	      }
+#endif
+	      
             }
             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
           }
@@ -174,6 +221,19 @@ vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
         retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
         if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
         if (retsts == SS$_NOLOGNAM) continue;
+        /* PPFs have a prefix */
+        if (
+#if INTSIZE == 4
+             *((int *)uplnm) == *((int *)"SYS$")                    &&
+#endif
+             eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
+             ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
+               (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
+               (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
+               (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
+          memcpy(eqv,eqv+4,eqvlen-4);
+          eqvlen -= 4;
+        }
         break;
       }
     }
@@ -188,10 +248,9 @@ vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 }  /* end of vmstrnenv */
 /*}}}*/
 
-
 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 /* Define as a function so we can access statics. */
-int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)
+int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 {
   return vmstrnenv(lnm,eqv,idx,fildev,                                   
 #ifdef SECURE_INTERNAL_GETENV
@@ -213,7 +272,7 @@ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)
  */
 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 char *
-my_getenv(const char *lnm, bool sys)
+Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 {
     static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
     char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
@@ -241,6 +300,8 @@ my_getenv(const char *lnm, bool sys)
         idx = strtoul(cp2+1,NULL,0);
         lnm = uplnm;
       }
+      /* Impose security constraints only if tainting */
+      if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
       if (vmstrnenv(lnm,eqv,idx,
                     sys ? fildev : NULL,
 #ifdef SECURE_INTERNAL_GETENV
@@ -260,9 +321,20 @@ my_getenv(const char *lnm, bool sys)
 char *
 my_getenv_len(const char *lnm, unsigned long *len, bool sys)
 {
-    char buf[LNM$C_NAMLENGTH+1], *cp1, *cp2;
+    dTHX;
+    char *buf, *cp1, *cp2;
     unsigned long idx = 0;
-
+    static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
+    SV *tmpsv;
+    
+    if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
+      /* Set up a temporary buffer for the return value; Perl will
+       * clean it up at the next statement transition */
+      tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
+      if (!tmpsv) return NULL;
+      buf = SvPVX(tmpsv);
+    }
+    else buf = __my_getenv_len_eqv;  /* Assume no interpreter ==> single thread */
     for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
       getcwd(buf,LNM$C_NAMLENGTH);
@@ -276,6 +348,8 @@ my_getenv_len(const char *lnm, unsigned long *len, bool sys)
         idx = strtoul(cp2+1,NULL,0);
         lnm = buf;
       }
+      /* Impose security constraints only if tainting */
+      if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
       if ((*len = vmstrnenv(lnm,buf,idx,
                            sys ? fildev : NULL,
 #ifdef SECURE_INTERNAL_GETENV
@@ -285,7 +359,8 @@ my_getenv_len(const char *lnm, unsigned long *len, bool sys)
 #endif
                                                          )))
 	  return buf;
-      else return Nullch;
+      else
+	  return Nullch;
     }
 
 }  /* end of my_getenv_len() */
@@ -302,7 +377,7 @@ prime_env_iter(void)
  * find, in preparation for iterating over it.
  */
 {
-  dTHR;
+  dTHX;
   static int primed = 0;
   HV *seenhv = NULL, *envhv;
   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
@@ -319,7 +394,7 @@ prime_env_iter(void)
   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam); 
-#ifdef USE_THREADS
+#if defined(USE_THREADS) || defined(USE_ITHREADS)
   static perl_mutex primenv_mutex;
   MUTEX_INIT(&primenv_mutex);
 #endif
@@ -351,7 +426,7 @@ prime_env_iter(void)
       for (j = 0; environ[j]; j++) { 
         if (!(start = strchr(environ[j],'='))) {
           if (ckWARN(WARN_INTERNAL)) 
-            warner(WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
+            Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
         }
         else {
           start++;
@@ -415,12 +490,12 @@ prime_env_iter(void)
       buf[retlen] = '\0';
       if (iosb[1] != subpid) {
         if (iosb[1]) {
-          croak("Unknown process %x sent message to prime_env_iter: %s",buf);
+          Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
         }
         continue;
       }
       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
-        warner(WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
+        Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
 
       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
       if (*cp1 == '(' || /* Logical name table name */
@@ -430,15 +505,22 @@ prime_env_iter(void)
       key = cp1;  keylen = cp2 - cp1;
       if (keylen && hv_exists(seenhv,key,keylen)) continue;
       while (*cp2 && *cp2 != '=') cp2++;
-      while (*cp2 && *cp2 != '"') cp2++;
-      for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
-      if ((!keylen || (cp1 - cp2 <= 0)) && ckWARN(WARN_INTERNAL)) {
-        warner(WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
+      while (*cp2 && *cp2 == '=') cp2++;
+      while (*cp2 && *cp2 == ' ') cp2++;
+      if (*cp2 == '"') {  /* String translation; may embed "" */
+        for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
+        cp2++;  cp1--; /* Skip "" surrounding translation */
+      }
+      else {  /* Numeric translation */
+        for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
+        cp1--;  /* stop on last non-space char */
+      }
+      if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
+        Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
         continue;
       }
-      /* Skip "" surrounding translation */
       PERL_HASH(hash,key,keylen);
-      hv_store(envhv,key,keylen,newSVpv(cp2+1,cp1 - cp2 - 1),hash);
+      hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
     }
     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
@@ -481,6 +563,7 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
     $DESCRIPTOR(local,"_LOCAL");
+    dTHX;
 
     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
       *cp2 = _toupper(*cp1);
@@ -506,7 +589,7 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
           ivenv = 1; retsts = SS$_NOLOGNAM;
 #else
               if (ckWARN(WARN_INTERNAL))
-                warner(WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
+                Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
               ivenv = 1; retsts = SS$_NOSUCHPGM;
               break;
             }
@@ -541,7 +624,7 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
 #else
         if (ckWARN(WARN_INTERNAL))
-          warner(WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
+          Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
         retsts = SS$_NOSUCHPGM;
 #endif
       }
@@ -560,6 +643,12 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
         }
         else {
           if (!*eqv) eqvdsc.dsc$w_length = 1;
+	  if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
+	    eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
+	    if (ckWARN(WARN_MISC)) {
+	      Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
+	    }
+	  }
           retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
         }
       }
@@ -600,7 +689,7 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
 /*{{{ void  my_setenv(char *lnm, char *eqv)*/
 /* This has to be a function since there's a prototype for it in proto.h */
 void
-my_setenv(char *lnm,char *eqv)
+Perl_my_setenv(pTHX_ char *lnm,char *eqv)
 {
   if (lnm && *lnm && strlen(lnm) == 7) {
     char uplnm[8];
@@ -653,8 +742,7 @@ my_crypt(const char *textpasswd, const char *usrname)
     usrdsc.dsc$a_pointer = usrname;
     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
       switch (sts) {
-        case SS$_NOGRPPRV:
-        case SS$_NOSYSPRV:
+        case SS$_NOGRPPRV: case SS$_NOSYSPRV:
           set_errno(EACCES);
           break;
         case RMS$_RNF:
@@ -679,13 +767,13 @@ my_crypt(const char *textpasswd, const char *usrname)
 /*}}}*/
 
 
-static char *do_rmsexpand(char *, char *, int, char *, unsigned);
-static char *do_fileify_dirspec(char *, char *, int);
-static char *do_tovmsspec(char *, char *, int);
+static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
+static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
+static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
 
 /*{{{int do_rmdir(char *name)*/
 int
-do_rmdir(char *name)
+Perl_do_rmdir(pTHX_ char *name)
 {
     char dirfile[NAM$C_MAXRSS+1];
     int retval;
@@ -714,6 +802,7 @@ kill_file(char *name)
     char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
+    dTHX;
     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
     struct myacedef {
       unsigned char myace$b_length;
@@ -752,15 +841,13 @@ kill_file(char *name)
     newace.myace$l_ident = oldace.myace$l_ident;
     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
       switch (aclsts) {
-        case RMS$_FNF:
-        case RMS$_DNF:
-        case RMS$_DIR:
-        case SS$_NOSUCHOBJECT:
+        case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
           set_errno(ENOENT); break;
+        case RMS$_DIR:
+          set_errno(ENOTDIR); break;
         case RMS$_DEV:
           set_errno(ENODEV); break;
-        case RMS$_SYN:
-        case SS$_INVFILFOROP:
+        case RMS$_SYN: case SS$_INVFILFOROP:
           set_errno(EINVAL); break;
         case RMS$_PRV:
           set_errno(EACCES); break;
@@ -815,6 +902,10 @@ int
 my_mkdir(char *dir, Mode_t mode)
 {
   STRLEN dirlen = strlen(dir);
+  dTHX;
+
+  /* zero length string sometimes gives ACCVIO */
+  if (dirlen == 0) return -1;
 
   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
    * null file name/type.  However, it's commonplace under Unix,
@@ -830,12 +921,59 @@ my_mkdir(char *dir, Mode_t mode)
 }  /* end of my_mkdir */
 /*}}}*/
 
+/*{{{int my_chdir(char *)*/
+int
+my_chdir(char *dir)
+{
+  STRLEN dirlen = strlen(dir);
+  dTHX;
+
+  /* zero length string sometimes gives ACCVIO */
+  if (dirlen == 0) return -1;
+
+  /* some versions of CRTL chdir() doesn't tolerate trailing /, since
+   * that implies
+   * null file name/type.  However, it's commonplace under Unix,
+   * so we'll allow it for a gain in portability.
+   */
+  if (dir[dirlen-1] == '/') {
+    char *newdir = savepvn(dir,dirlen-1);
+    int ret = chdir(newdir);
+    Safefree(newdir);
+    return ret;
+  }
+  else return chdir(dir);
+}  /* end of my_chdir */
+/*}}}*/
+
+
+/*{{{FILE *my_tmpfile()*/
+FILE *
+my_tmpfile(void)
+{
+  FILE *fp;
+  char *cp;
+  dTHX;
+
+  if ((fp = tmpfile())) return fp;
+
+  New(1323,cp,L_tmpnam+24,char);
+  strcpy(cp,"Sys$Scratch:");
+  tmpnam(cp+strlen(cp));
+  strcat(cp,".Perltmp");
+  fp = fopen(cp,"w+","fop=dlt");
+  Safefree(cp);
+  return fp;
+}
+/*}}}*/
+
 
 static void
 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
 {
   static unsigned long int mbxbufsiz;
   long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
+  dTHX;
   
   if (!mbxbufsiz) {
     /*
@@ -881,11 +1019,12 @@ static int waitpid_asleep = 0;
  * to a mbx; that's the caller's responsibility.
  */
 static unsigned long int
-pipe_eof(FILE *fp)
+pipe_eof(FILE *fp, int immediate)
 {
   char devnam[NAM$C_MAXRSS+1], *cp;
   unsigned long int chan, iosb[2], retsts, retsts2;
   struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
+  dTHX;
 
   if (fgetname(fp,devnam,1)) {
     /* It oughta be a mailbox, so fgetname should give just the device
@@ -893,7 +1032,8 @@ pipe_eof(FILE *fp)
     if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
     devdsc.dsc$w_length = strlen(devnam);
     _ckvmssts(sys$assign(&devdsc,&chan,0,0));
-    retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
+    retsts = sys$qiow(0,chan,IO$_WRITEOF|(immediate?IO$M_NOW|IO$M_NORSWAIT:0),
+             iosb,0,0,0,0,0,0,0,0);
     if (retsts & 1) retsts = iosb[0];
     retsts2 = sys$dassgn(chan);  /* Be sure to deassign the channel */
     if (retsts & 1) retsts = retsts2;
@@ -910,6 +1050,7 @@ pipe_exit_routine()
     struct pipe_details *info;
     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
     int sts, did_stuff;
+    dTHX;
 
     /* 
      first we try sending an EOF...ignore if doesn't work, make sure we
@@ -919,8 +1060,12 @@ pipe_exit_routine()
     info = open_pipes;
 
     while (info) {
-      if (info->mode != 'r' && !info->done) {
-        if (pipe_eof(info->fp) & 1) did_stuff = 1;
+      int need_eof;
+      _ckvmssts(sys$setast(0));
+      need_eof = info->mode != 'r' && !info->done;
+      _ckvmssts(sys$setast(1));
+      if (need_eof) {
+        if (pipe_eof(info->fp, 1) & 1) did_stuff = 1;
       }
       info = info->next;
     }
@@ -929,22 +1074,26 @@ pipe_exit_routine()
     did_stuff = 0;
     info = open_pipes;
     while (info) {
+      _ckvmssts(sys$setast(0));
       if (!info->done) { /* Tap them gently on the shoulder . . .*/
         sts = sys$forcex(&info->pid,0,&abort);
         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts); 
         did_stuff = 1;
       }
+      _ckvmssts(sys$setast(1));
       info = info->next;
     }
     if (did_stuff) sleep(1);    /* wait for them to respond */
 
     info = open_pipes;
     while (info) {
+      _ckvmssts(sys$setast(0));
       if (!info->done) {  /* We tried to be nice . . . */
         sts = sys$delprc(&info->pid,0);
         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts); 
         info->done = 1; /* so my_pclose doesn't try to write EOF */
       }
+      _ckvmssts(sys$setast(1));
       info = info->next;
     }
 
@@ -970,13 +1119,17 @@ popen_completion_ast(struct pipe_details *thispipe)
   }
 }
 
+static unsigned long int setup_cmddsc(char *cmd, int check_img);
+static void vms_execfree(pTHX);
+
 static PerlIO *
 safe_popen(char *cmd, char *mode)
 {
     static int handler_set_up = FALSE;
     char mbxname[64];
     unsigned short int chan;
-    unsigned long int flags=1;  /* nowait - gnu c doesn't allow &1 */
+    unsigned long int sts, flags=1;  /* nowait - gnu c doesn't allow &1 */
+    dTHX;
     struct pipe_details *info;
     struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
                                       DSC$K_CLASS_S, mbxname},
@@ -984,13 +1137,7 @@ safe_popen(char *cmd, char *mode)
                                       DSC$K_CLASS_S, 0};
                             
 
-    cmddsc.dsc$w_length=strlen(cmd);
-    cmddsc.dsc$a_pointer=cmd;
-    if (cmddsc.dsc$w_length > 255) {
-      set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
-      return Nullfp;
-    }
-
+    if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
     New(1301,info,1,struct pipe_details);
 
     /* create mailbox */
@@ -1010,16 +1157,17 @@ safe_popen(char *cmd, char *mode)
     info->completion=0;
         
     if (*mode == 'r') {
-      _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
+      _ckvmssts(lib$spawn(&VMScmd, &nl_desc, &namdsc, &flags,
                      0  /* name */, &info->pid, &info->completion,
                      0, popen_completion_ast,info,0,0,0));
     }
     else {
-      _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
+      _ckvmssts(lib$spawn(&VMScmd, &namdsc, 0 /* sys$output */, &flags,
                      0  /* name */, &info->pid, &info->completion,
                      0, popen_completion_ast,info,0,0,0));
     }
 
+    vms_execfree(aTHX);
     if (!handler_set_up) {
       _ckvmssts(sys$dclexh(&pipe_exitblock));
       handler_set_up = TRUE;
@@ -1034,7 +1182,7 @@ safe_popen(char *cmd, char *mode)
 
 /*{{{  FILE *my_popen(char *cmd, char *mode)*/
 FILE *
-my_popen(char *cmd, char *mode)
+Perl_my_popen(pTHX_ char *cmd, char *mode)
 {
     TAINT_ENV();
     TAINT_PROPER("popen");
@@ -1045,10 +1193,11 @@ my_popen(char *cmd, char *mode)
 /*}}}*/
 
 /*{{{  I32 my_pclose(FILE *fp)*/
-I32 my_pclose(FILE *fp)
+I32 Perl_my_pclose(pTHX_ FILE *fp)
 {
     struct pipe_details *info, *last = NULL;
     unsigned long int retsts;
+    int need_eof;
     
     for (info = open_pipes; info != NULL; last = info, info = info->next)
         if (info->fp == fp) break;
@@ -1062,15 +1211,20 @@ I32 my_pclose(FILE *fp)
     /* If we were writing to a subprocess, insure that someone reading from
      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
      * produce an EOF record in the mailbox.  */
-    if (info->mode != 'r' && !info->done) pipe_eof(info->fp);
+    _ckvmssts(sys$setast(0));
+    need_eof = info->mode != 'r' && !info->done;
+    _ckvmssts(sys$setast(1));
+    if (need_eof) pipe_eof(info->fp,0);
     PerlIO_close(info->fp);
 
     if (info->done) retsts = info->completion;
     else waitpid(info->pid,(int *) &retsts,0);
 
     /* remove from list of open pipes */
+    _ckvmssts(sys$setast(0));
     if (last) last->next = info->next;
     else open_pipes = info->next;
+    _ckvmssts(sys$setast(1));
     Safefree(info);
 
     return retsts;
@@ -1083,6 +1237,7 @@ Pid_t
 my_waitpid(Pid_t pid, int *statusp, int flags)
 {
     struct pipe_details *info;
+    dTHX;
     
     for (info = open_pipes; info != NULL; info = info->next)
         if (info->pid == pid) break;
@@ -1105,7 +1260,7 @@ my_waitpid(Pid_t pid, int *statusp, int flags)
         _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
         _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
         if (ownerpid != mypid)
-          warner(WARN_EXEC,"pid %x not a child",pid);
+          Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
       }
 
       _ckvmssts(sys$bintim(&intdsc,interval));
@@ -1170,10 +1325,10 @@ my_gconvert(double val, int ndig, int trail, char *buf)
  * rmesexpand() returns the address of the resultant string if
  * successful, and NULL on error.
  */
-static char *do_tounixspec(char *, char *, int);
+static char *mp_do_tounixspec(pTHX_ char *, char *, int);
 
 static char *
-do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
+mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
 {
   static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
   char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
@@ -1217,8 +1372,7 @@ do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
   retsts = sys$parse(&myfab,0,0);
   if (!(retsts & 1)) {
     mynam.nam$b_nop |= NAM$M_SYNCHK;
-    if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
-        retsts == RMS$_DEV || retsts == RMS$_DEV) {
+    if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
       retsts = sys$parse(&myfab,0,0);
       if (retsts & 1) goto expanded;
     }  
@@ -1309,9 +1463,9 @@ do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
 }
 /*}}}*/
 /* External entry points */
-char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
+char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
 { return do_rmsexpand(spec,buf,0,def,opt); }
-char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
+char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
 { return do_rmsexpand(spec,buf,1,def,opt); }
 
 
@@ -1350,7 +1504,7 @@ char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
  */
 
 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
-static char *do_fileify_dirspec(char *dir,char *buf,int ts)
+static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
 {
     static char __fileify_retbuf[NAM$C_MAXRSS+1];
     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
@@ -1361,7 +1515,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
     }
     dirlen = strlen(dir);
-    while (dir[dirlen-1] == '/') --dirlen;
+    while (dirlen && dir[dirlen-1] == '/') --dirlen;
     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
       strcpy(trndir,"/sys$disk/000000");
       dir = trndir;
@@ -1387,7 +1541,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
      *    ... do_fileify_dirspec("myroot",buf,1) ...
      * does something useful.
      */
-    if (!strcmp(dir+dirlen-2,".]")) {
+    if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
       dir[--dirlen] = '\0';
       dir[dirlen-1] = ']';
     }
@@ -1417,7 +1571,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
                  (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
           return do_fileify_dirspec("[-]",buf,ts);
       }
-      if (dir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
+      if (dirlen && dir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
         dirlen -= 1;                 /* to last element */
         lastdir = strrchr(dir,'/');
       }
@@ -1444,7 +1598,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
         } while ((cp1 = strstr(cp1,"/.")) != NULL);
         lastdir = strrchr(dir,'/');
       }
-      else if (!strcmp(&dir[dirlen-7],"/000000")) {
+      else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
         /* Ditto for specs that end in an MFD -- let the VMS code
          * figure out whether it's a real device or a rooted logical. */
         dir[dirlen] = '/'; dir[dirlen+1] = '\0';
@@ -1534,13 +1688,14 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
           /* Yes; fake the fnb bits so we'll check type below */
           dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
         }
-        else {
-          if (dirfab.fab$l_sts != RMS$_FNF) {
-            set_errno(EVMSERR);
-            set_vaxc_errno(dirfab.fab$l_sts);
+        else { /* No; just work with potential name */
+          if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
+          else { 
+            set_errno(EVMSERR);  set_vaxc_errno(dirfab.fab$l_sts);
+            dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
+            dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
             return NULL;
           }
-          dirnam = savnam; /* No; just work with potential name */
         }
       }
       if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
@@ -1556,6 +1711,8 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) { 
           /* Something other than .DIR[;1].  Bzzt. */
+          dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
+          dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
           set_errno(ENOTDIR);
           set_vaxc_errno(RMS$_DIR);
           return NULL;
@@ -1568,6 +1725,8 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
         else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
         else retspec = __fileify_retbuf;
         strcpy(retspec,esa);
+        dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
+        dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
         return retspec;
       }
       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
@@ -1576,7 +1735,11 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
         dirnam.nam$b_esl -= 9;
       }
       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
-      if (cp1 == NULL) return NULL; /* should never happen */
+      if (cp1 == NULL) { /* should never happen */
+        dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
+        dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
+        return NULL;
+      }
       term = *cp1;
       *cp1 = '\0';
       retlen = strlen(esa);
@@ -1593,6 +1756,8 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
           /* Go back and expand rooted logical name */
           dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
           if (!(sys$parse(&dirfab) & 1)) {
+            dirnam.nam$l_rlf = NULL;
+            dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
             set_errno(EVMSERR);
             set_vaxc_errno(dirfab.fab$l_sts);
             return NULL;
@@ -1637,6 +1802,8 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
           strcpy(cp2+9,cp1);
         }
       }
+      dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
+      dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
       /* We've set up the string up through the filename.  Add the
          type and version, and we're done. */
       strcat(retspec,".DIR;1");
@@ -1649,13 +1816,13 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
 }  /* end of do_fileify_dirspec() */
 /*}}}*/
 /* External entry points */
-char *fileify_dirspec(char *dir, char *buf)
+char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
 { return do_fileify_dirspec(dir,buf,0); }
-char *fileify_dirspec_ts(char *dir, char *buf)
+char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
 { return do_fileify_dirspec(dir,buf,1); }
 
 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
-static char *do_pathify_dirspec(char *dir,char *buf, int ts)
+static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
 {
     static char __pathify_retbuf[NAM$C_MAXRSS+1];
     unsigned long int retlen;
@@ -1668,7 +1835,8 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts)
     if (*dir) strcpy(trndir,dir);
     else getcwd(trndir,sizeof trndir - 1);
 
-    while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
+    while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
+	   && my_trnlnm(trndir,trndir,0)) {
       STRLEN trnlen = strlen(trndir);
 
       /* Trap simple rooted lnms, and return lnm:[000000] */
@@ -1788,6 +1956,8 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts)
         savnam = dirnam;
         if (!(sys$search(&dirfab)&1)) {  /* Does the file really exist? */
           if (dirfab.fab$l_sts != RMS$_FNF) {
+            dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
+            dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
             set_errno(EVMSERR);
             set_vaxc_errno(dirfab.fab$l_sts);
             return NULL;
@@ -1800,6 +1970,8 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts)
         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) { 
           /* Something other than .DIR[;1].  Bzzt. */
+          dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
+          dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
           set_errno(ENOTDIR);
           set_vaxc_errno(RMS$_DIR);
           return NULL;
@@ -1819,6 +1991,8 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts)
       else if (ts) New(1314,retpath,retlen,char);
       else retpath = __pathify_retbuf;
       strcpy(retpath,esa);
+      dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
+      dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
       /* $PARSE may have upcased filespec, so convert output to lower
        * case if input contained any lowercase characters. */
       if (haslower) __mystrtolower(retpath);
@@ -1828,13 +2002,13 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts)
 }  /* end of do_pathify_dirspec() */
 /*}}}*/
 /* External entry points */
-char *pathify_dirspec(char *dir, char *buf)
+char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
 { return do_pathify_dirspec(dir,buf,0); }
-char *pathify_dirspec_ts(char *dir, char *buf)
+char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
 { return do_pathify_dirspec(dir,buf,1); }
 
 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
-static char *do_tounixspec(char *spec, char *buf, int ts)
+static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
 {
   static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
   char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
@@ -1958,11 +2132,11 @@ static char *do_tounixspec(char *spec, char *buf, int ts)
 }  /* end of do_tounixspec() */
 /*}}}*/
 /* External entry points */
-char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
-char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
+char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
+char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
 
 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
-static char *do_tovmsspec(char *path, char *buf, int ts) {
+static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
   static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
   char *rslt, *dirend;
   register char *cp1, *cp2;
@@ -2102,11 +2276,11 @@ static char *do_tovmsspec(char *path, char *buf, int ts) {
 }  /* end of do_tovmsspec() */
 /*}}}*/
 /* External entry points */
-char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
-char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
+char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
+char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
 
 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
-static char *do_tovmspath(char *path, char *buf, int ts) {
+static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
   static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
   int vmslen;
   char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
@@ -2130,12 +2304,12 @@ static char *do_tovmspath(char *path, char *buf, int ts) {
 }  /* end of do_tovmspath() */
 /*}}}*/
 /* External entry points */
-char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
-char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
+char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
+char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
 
 
 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
-static char *do_tounixpath(char *path, char *buf, int ts) {
+static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
   static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
   int unixlen;
   char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
@@ -2159,8 +2333,8 @@ static char *do_tounixpath(char *path, char *buf, int ts) {
 }  /* end of do_tounixpath() */
 /*}}}*/
 /* External entry points */
-char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
-char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
+char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
+char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
 
 /*
  * @(#)argproc.c 2.2 94/08/16	Mark Pizzolato (mark@infocomm.com)
@@ -2205,10 +2379,10 @@ static void add_item(struct list_item **head,
 		     char *value,
 		     int *count);
 
-static void expand_wild_cards(char *item,
-			      struct list_item **head,
-			      struct list_item **tail,
-			      int *count);
+static void mp_expand_wild_cards(pTHX_ char *item,
+				struct list_item **head,
+				struct list_item **tail,
+				int *count);
 
 static int background_process(int argc, char **argv);
 
@@ -2216,7 +2390,7 @@ static void pipe_and_fork(char **cmargv);
 
 /*{{{ void getredirection(int *ac, char ***av)*/
 static void
-getredirection(int *ac, char ***av)
+mp_getredirection(pTHX_ int *ac, char ***av)
 /*
  * Process vms redirection arg's.  Exit if any error is seen.
  * If getredirection() processes an argument, it is erased
@@ -2421,6 +2595,9 @@ getredirection(int *ac, char ***av)
 	exit(vaxc$errno);
 	}
     if (err != NULL) {
+        if (strcmp(err,"&1") == 0) {
+            dup2(fileno(stdout), fileno(Perl_debug_log));
+        } else {
 	FILE *tmperr;
 	if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
 	    {
@@ -2433,6 +2610,7 @@ getredirection(int *ac, char ***av)
 		exit(vaxc$errno);
 		}
 	}
+        }
 #ifdef ARGPROC_DEBUG
     PerlIO_printf(Perl_debug_log, "Arglist:\n");
     for (j = 0; j < *ac;  ++j)
@@ -2462,7 +2640,7 @@ static void add_item(struct list_item **head,
     ++(*count);
 }
 
-static void expand_wild_cards(char *item,
+static void mp_expand_wild_cards(pTHX_ char *item,
 			      struct list_item **head,
 			      struct list_item **tail,
 			      int *count)
@@ -2540,14 +2718,13 @@ unsigned long int zero = 0, sts;
 	set_vaxc_errno(sts);
 	switch (sts)
 	    {
-	    case RMS$_FNF:
-	    case RMS$_DNF:
-	    case RMS$_DIR:
+	    case RMS$_FNF: case RMS$_DNF:
 		set_errno(ENOENT); break;
+	    case RMS$_DIR:
+		set_errno(ENOTDIR); break;
 	    case RMS$_DEV:
 		set_errno(ENODEV); break;
-	    case RMS$_FNM:
-	    case RMS$_SYN:
+	    case RMS$_FNM: case RMS$_SYN:
 		set_errno(EINVAL); break;
 	    case RMS$_PRV:
 		set_errno(EACCES); break;
@@ -2701,6 +2878,7 @@ vms_image_init(int *argcp, char ***argvp)
   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
   unsigned short int dummy, rlen;
   struct dsc$descriptor_s **tabvec;
+  dTHX;
   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
@@ -2816,7 +2994,7 @@ vms_image_init(int *argcp, char ***argvp)
  */
 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
 int
-trim_unixpath(char *fspec, char *wildspec, int opts)
+Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
 {
   char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
        *template, *base, *end, *cp1, *cp2;
@@ -2975,7 +3153,7 @@ trim_unixpath(char *fspec, char *wildspec, int opts)
  */
 /*{{{ DIR *opendir(char*name) */
 DIR *
-opendir(char *name)
+Perl_opendir(pTHX_ char *name)
 {
     DIR *dd;
     char dir[NAM$C_MAXRSS+1];
@@ -3048,6 +3226,7 @@ collectversions(dd)
     char *p, *text, buff[sizeof dd->entry.d_name];
     int i;
     unsigned long context, tmpsts;
+    dTHX;
 
     /* Convenient shorthand. */
     e = &dd->entry;
@@ -3115,7 +3294,8 @@ readdir(DIR *dd)
         case RMS$_DEV:
           set_errno(ENODEV); break;
         case RMS$_DIR:
-        case RMS$_FNF:
+          set_errno(ENOTDIR); break;
+        case RMS$_FNF: case RMS$_DNF:
           set_errno(ENOENT); break;
         default:
           set_errno(EVMSERR);
@@ -3163,6 +3343,7 @@ void
 seekdir(DIR *dd, long count)
 {
     int vms_wantversions;
+    dTHX;
 
     /* If we haven't done anything yet... */
     if (dd->count == 0)
@@ -3225,12 +3406,10 @@ my_vfork()
 /*}}}*/
 
 
-static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
-
 static void
-vms_execfree() {
+vms_execfree(pTHX) {
   if (PL_Cmd) {
-    Safefree(PL_Cmd);
+    if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
     PL_Cmd = Nullch;
   }
   if (VMScmd.dsc$a_pointer) {
@@ -3243,7 +3422,7 @@ vms_execfree() {
 static char *
 setup_argstr(SV *really, SV **mark, SV **sp)
 {
-  dTHR;
+  dTHX;
   char *junk, *tmps = Nullch;
   register size_t cmdlen = 0;
   size_t rlen;
@@ -3288,43 +3467,102 @@ setup_argstr(SV *really, SV **mark, SV **sp)
 static unsigned long int
 setup_cmddsc(char *cmd, int check_img)
 {
-  char resspec[NAM$C_MAXRSS+1];
+  char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
   $DESCRIPTOR(defdsc,".EXE");
+  $DESCRIPTOR(defdsc2,".");
   $DESCRIPTOR(resdsc,resspec);
   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
-  register char *s, *rest, *cp;
-  register int isdcl = 0;
+  register char *s, *rest, *cp, *wordbreak;
+  register int isdcl;
+  dTHX;
 
+  if (strlen(cmd) >
+      (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
+    return LIB$_INVARG;
   s = cmd;
   while (*s && isspace(*s)) s++;
-  if (check_img) {
-    if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
-      isdcl = 1;     /* no dev/dir separators (i.e. not a foreign command) */
-      for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
-        if (*cp == ':' || *cp == '[' || *cp == '<') {
-          isdcl = 0;
-          break;
-        }
+
+  if (*s == '@' || *s == '$') {
+    vmsspec[0] = *s;  rest = s + 1;
+    for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
+  }
+  else { cp = vmsspec; rest = s; }
+  if (*rest == '.' || *rest == '/') {
+    char *cp2;
+    for (cp2 = resspec;
+         *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
+         rest++, cp2++) *cp2 = *rest;
+    *cp2 = '\0';
+    if (do_tovmsspec(resspec,cp,0)) { 
+      s = vmsspec;
+      if (*rest) {
+        for (cp2 = vmsspec + strlen(vmsspec);
+             *rest && cp2 - vmsspec < sizeof vmsspec;
+             rest++, cp2++) *cp2 = *rest;
+        *cp2 = '\0';
       }
     }
   }
-  else isdcl = 1;
+  /* Intuit whether verb (first word of cmd) is a DCL command:
+   *   - if first nonspace char is '@', it's a DCL indirection
+   * otherwise
+   *   - if verb contains a filespec separator, it's not a DCL command
+   *   - if it doesn't, caller tells us whether to default to a DCL
+   *     command, or to a local image unless told it's DCL (by leading '$')
+   */
+  if (*s == '@') isdcl = 1;
+  else {
+    register char *filespec = strpbrk(s,":<[.;");
+    rest = wordbreak = strpbrk(s," \"\t/");
+    if (!wordbreak) wordbreak = s + strlen(s);
+    if (*s == '$') check_img = 0;
+    if (filespec && (filespec < wordbreak)) isdcl = 0;
+    else isdcl = !check_img;
+  }
+
   if (!isdcl) {
-    cmd = s;
-    while (*s && !isspace(*s)) s++;
-    rest = *s ? s : 0;
-    imgdsc.dsc$a_pointer = cmd;
-    imgdsc.dsc$w_length = s - cmd;
+    imgdsc.dsc$a_pointer = s;
+    imgdsc.dsc$w_length = wordbreak - s;
     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
-    if (retsts & 1) {
+    if (!(retsts&1)) {
+        _ckvmssts(lib$find_file_end(&cxt));
+        retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
+    if (!(retsts & 1) && *s == '$') {
+          _ckvmssts(lib$find_file_end(&cxt));
+      imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
+      retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
+          if (!(retsts&1)) {
       _ckvmssts(lib$find_file_end(&cxt));
+            retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
+          }
+    }
+    }
+    _ckvmssts(lib$find_file_end(&cxt));
+
+    if (retsts & 1) {
+      FILE *fp;
       s = resspec;
       while (*s && !isspace(*s)) s++;
       *s = '\0';
+
+      /* check that it's really not DCL with no file extension */
+      fp = fopen(resspec,"r","ctx=bin,shr=get");
+      if (fp) {
+        char b[4] = {0,0,0,0};
+        read(fileno(fp),b,4);
+        isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
+        fclose(fp);
+      }
+      if (check_img && isdcl) return RMS$_FNF;
+
       if (cando_by_name(S_IXUSR,0,resspec)) {
         New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
+        if (!isdcl) {
         strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
+        } else {
+            strcpy(VMScmd.dsc$a_pointer,"@");
+        }
         strcat(VMScmd.dsc$a_pointer,resspec);
         if (rest) strcat(VMScmd.dsc$a_pointer,rest);
         VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
@@ -3335,10 +3573,7 @@ setup_cmddsc(char *cmd, int check_img)
   }
   /* It's either a DCL command or we couldn't find a suitable image */
   VMScmd.dsc$w_length = strlen(cmd);
-  if (cmd == PL_Cmd) {
-    VMScmd.dsc$a_pointer = PL_Cmd;
-    PL_Cmd = Nullch;  /* Don't try to free twice in vms_execfree() */
-  }
+  if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
   else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
   if (!(retsts & 1)) {
     /* just hand off status values likely to be due to user error */
@@ -3357,12 +3592,12 @@ setup_cmddsc(char *cmd, int check_img)
 bool
 vms_do_aexec(SV *really,SV **mark,SV **sp)
 {
-  dTHR;
+  dTHX;
   if (sp > mark) {
     if (vfork_called) {           /* this follows a vfork - act Unixish */
       vfork_called--;
       if (vfork_called < 0) {
-        warn("Internal inconsistency in tracking vforks");
+        Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
         vfork_called = 0;
       }
       else return do_aexec(really,mark,sp);
@@ -3381,10 +3616,11 @@ bool
 vms_do_exec(char *cmd)
 {
 
+  dTHX;
   if (vfork_called) {             /* this follows a vfork - act Unixish */
     vfork_called--;
     if (vfork_called < 0) {
-      warn("Internal inconsistency in tracking vforks");
+      Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
       vfork_called = 0;
     }
     else return do_exec(cmd);
@@ -3399,10 +3635,12 @@ vms_do_exec(char *cmd)
       retsts = lib$do_command(&VMScmd);
 
     switch (retsts) {
-      case RMS$_FNF:
+      case RMS$_FNF: case RMS$_DNF:
         set_errno(ENOENT); break;
-      case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
+      case RMS$_DIR:
         set_errno(ENOTDIR); break;
+      case RMS$_DEV:
+        set_errno(ENODEV); break;
       case RMS$_PRV:
         set_errno(EACCES); break;
       case RMS$_SYN:
@@ -3416,10 +3654,10 @@ vms_do_exec(char *cmd)
     }
     set_vaxc_errno(retsts);
     if (ckWARN(WARN_EXEC)) {
-      warner(WARN_EXEC,"Can't exec \"%*s\": %s",
+      Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
              VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
     }
-    vms_execfree();
+    vms_execfree(aTHX);
   }
 
   return FALSE;
@@ -3433,7 +3671,7 @@ unsigned long int do_spawn(char *);
 unsigned long int
 do_aspawn(void *really,void **mark,void **sp)
 {
-  dTHR;
+  dTHX;
   if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
 
   return SS$_ABORT;
@@ -3445,6 +3683,7 @@ unsigned long int
 do_spawn(char *cmd)
 {
   unsigned long int sts, substs, hadcmd = 1;
+  dTHX;
 
   TAINT_ENV();
   TAINT_PROPER("spawn");
@@ -3458,10 +3697,12 @@ do_spawn(char *cmd)
   
   if (!(sts & 1)) {
     switch (sts) {
-      case RMS$_FNF:
+      case RMS$_FNF:  case RMS$_DNF:
         set_errno(ENOENT); break;
-      case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
+      case RMS$_DIR:
         set_errno(ENOTDIR); break;
+      case RMS$_DEV:
+        set_errno(ENODEV); break;
       case RMS$_PRV:
         set_errno(EACCES); break;
       case RMS$_SYN:
@@ -3475,13 +3716,13 @@ do_spawn(char *cmd)
     }
     set_vaxc_errno(sts);
     if (ckWARN(WARN_EXEC)) {
-      warner(WARN_EXEC,"Can't spawn \"%*s\": %s",
+      Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
              hadcmd ? VMScmd.dsc$w_length :  0,
              hadcmd ? VMScmd.dsc$a_pointer : "",
              Strerror(errno));
     }
   }
-  vms_execfree();
+  vms_execfree(aTHX);
   return substs;
 
 }  /* end of do_spawn() */
@@ -3517,7 +3758,7 @@ int
 my_flush(FILE *fp)
 {
     int res;
-    if ((res = fflush(fp)) == 0) {
+    if ((res = fflush(fp)) == 0 && fp) {
 #ifdef VMS_DO_SOCKETS
 	Stat_t s;
 	if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
@@ -3590,6 +3831,7 @@ static char __pw_namecache[UAI$S_IDENT+1];
  */
 static int fillpasswd (const char *name, struct passwd *pwd)
 {
+    dTHX;
     static struct {
         unsigned char length;
         char pw_gecos[UAI$S_OWNER+1];
@@ -3648,7 +3890,7 @@ static int fillpasswd (const char *name, struct passwd *pwd)
         pwd->pw_gid= uic.uic$v_group;
     }
     else
-      warn("getpwnam returned invalid UIC %#o for user \"%s\"");
+      Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
     pwd->pw_passwd=  pw_passwd;
     pwd->pw_gecos=   owner.pw_gecos;
     pwd->pw_dir=     defdev.pw_dir;
@@ -3674,6 +3916,7 @@ struct passwd *my_getpwnam(char *name)
     struct dsc$descriptor_s name_desc;
     union uicdef uic;
     unsigned long int status, sts;
+    dTHX;
                                   
     __pwdcache = __passwd_empty;
     if (!fillpasswd(name, &__pwdcache)) {
@@ -3713,6 +3956,7 @@ struct passwd *my_getpwuid(Uid_t uid)
     unsigned short lname;
     union uicdef uic;
     unsigned long int status;
+    dTHX;
 
     if (uid == (unsigned int) -1) {
       do {
@@ -3774,6 +4018,7 @@ struct passwd *my_getpwent()
 /*{{{void my_endpwent()*/
 void my_endpwent()
 {
+    dTHX;
     if (contxt) {
       _ckvmssts(sys$finish_rdb(&contxt));
       contxt= 0;
@@ -3903,6 +4148,27 @@ static long int utc_offset_secs;
 #  define RTL_USES_UTC 1
 #endif
 
+/*
+ * DEC C previous to 6.0 corrupts the behavior of the /prefix
+ * qualifier with the extern prefix pragma.  This provisional
+ * hack circumvents this prefix pragma problem in previous 
+ * precompilers.
+ */
+#if defined(__VMS_VER) && __VMS_VER >= 70000000 
+#  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
+#    pragma __extern_prefix save
+#    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
+#    define gmtime decc$__utctz_gmtime
+#    define localtime decc$__utctz_localtime
+#    define time decc$__utc_time
+#    pragma __extern_prefix restore
+
+     struct tm *gmtime(), *localtime();   
+
+#  endif
+#endif
+
+
 static time_t toutc_dst(time_t loc) {
   struct tm *rsltmp;
 
@@ -3911,7 +4177,7 @@ static time_t toutc_dst(time_t loc) {
   if (rsltmp->tm_isdst) loc -= 3600;
   return loc;
 }
-#define _toutc(secs)  ((secs) == -1 ? -1 : \
+#define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
        ((gmtime_emulation_type || my_time(NULL)), \
        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
        ((secs) - utc_offset_secs))))
@@ -3924,7 +4190,7 @@ static time_t toloc_dst(time_t utc) {
   if (rsltmp->tm_isdst) utc += 3600;
   return utc;
 }
-#define _toloc(secs)  ((secs) == -1 ? -1 : \
+#define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
        ((gmtime_emulation_type || my_time(NULL)), \
        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
        ((secs) + utc_offset_secs))))
@@ -3943,7 +4209,7 @@ static time_t toloc_dst(time_t utc) {
 /*{{{time_t my_time(time_t *timep)*/
 time_t my_time(time_t *timep)
 {
-  dTHR;
+  dTHX;
   time_t when;
   struct tm *tm_p;
 
@@ -3960,7 +4226,7 @@ time_t my_time(time_t *timep)
       gmtime_emulation_type++;
       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
         gmtime_emulation_type++;
-        warn("no UTC offset information; assuming local time is UTC");
+        Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
       }
       else { utc_offset_secs = atol(off); }
     }
@@ -3996,7 +4262,7 @@ time_t my_time(time_t *timep)
 struct tm *
 my_gmtime(const time_t *timep)
 {
-  dTHR;
+  dTHX;
   char *p;
   time_t when;
   struct tm *rsltmp;
@@ -4027,7 +4293,7 @@ my_gmtime(const time_t *timep)
 struct tm *
 my_localtime(const time_t *timep)
 {
-  dTHR;
+  dTHX;
   time_t when;
   struct tm *rsltmp;
 
@@ -4084,7 +4350,7 @@ static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
 int my_utime(char *file, struct utimbuf *utimes)
 {
-  dTHR;
+  dTHX;
   register int i;
   long int bintime[2], len = 2, lowbit, unixtime,
            secscale = 10000000; /* seconds --> 100 ns intervals */
@@ -4131,7 +4397,7 @@ int my_utime(char *file, struct utimbuf *utimes)
     /* If input was UTC; convert to local for sys svc */
     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
 #   endif
-    unixtime >> 1;  secscale << 1;
+    unixtime >>= 1;  secscale <<= 1;
     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
     if (!(retsts & 1)) {
       set_errno(EVMSERR);
@@ -4177,6 +4443,8 @@ int my_utime(char *file, struct utimbuf *utimes)
   }
   retsts = sys$search(&myfab,0,0);
   if (!(retsts & 1)) {
+    mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
+    myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
     set_vaxc_errno(retsts);
     if      (retsts == RMS$_PRV) set_errno(EACCES);
     else if (retsts == RMS$_FNF) set_errno(ENOENT);
@@ -4189,6 +4457,8 @@ int my_utime(char *file, struct utimbuf *utimes)
 
   retsts = sys$assign(&devdsc,&chan,0,0);
   if (!(retsts & 1)) {
+    mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
+    myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
     set_vaxc_errno(retsts);
     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
@@ -4213,6 +4483,8 @@ int my_utime(char *file, struct utimbuf *utimes)
   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
 #endif
   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
+  mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
+  myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
   _ckvmssts(sys$dassgn(chan));
   if (retsts & 1) retsts = iosb[0];
   if (!(retsts & 1)) {
@@ -4268,6 +4540,7 @@ static mydev_t encode_dev (const char *dev)
   mydev_t enc;
   char c;
   const char *q;
+  dTHX;
 
   if (!dev || !dev[0]) return 0;
 
@@ -4313,6 +4586,7 @@ static int
 is_null_device(name)
     const char *name;
 {
+    dTHX;
     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
        The underscore prefix, controller letter, and unit number are
        independently optional; for our purposes, the colon punctuation
@@ -4331,11 +4605,9 @@ is_null_device(name)
 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
  * subset of the applicable information.
  */
-/*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
-I32
-cando(I32 bit, I32 effective, Stat_t *statbufp)
+bool
+Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
 {
-  dTHR;
   if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
   else {
     char fname[NAM$C_MAXRSS+1];
@@ -4357,7 +4629,7 @@ cando(I32 bit, I32 effective, Stat_t *statbufp)
       return cando_by_name(bit,effective,fname);
     }
     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
-      warn("Can't get filespec - stale stat buffer?\n");
+      Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
       return FALSE;
     }
     _ckvmssts(retsts);
@@ -4367,9 +4639,9 @@ cando(I32 bit, I32 effective, Stat_t *statbufp)
 /*}}}*/
 
 
-/*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
+/*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
 I32
-cando_by_name(I32 bit, I32 effective, char *fname)
+cando_by_name(I32 bit, Uid_t effective, char *fname)
 {
   static char usrname[L_cuserid];
   static struct dsc$descriptor_s usrdsc =
@@ -4377,6 +4649,7 @@ cando_by_name(I32 bit, I32 effective, char *fname)
   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
   unsigned short int retlen;
+  dTHX;
   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
   union prvdef curprv;
   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
@@ -4407,26 +4680,14 @@ cando_by_name(I32 bit, I32 effective, char *fname)
   }
 
   switch (bit) {
-    case S_IXUSR:
-    case S_IXGRP:
-    case S_IXOTH:
-      access = ARM$M_EXECUTE;
-      break;
-    case S_IRUSR:
-    case S_IRGRP:
-    case S_IROTH:
-      access = ARM$M_READ;
-      break;
-    case S_IWUSR:
-    case S_IWGRP:
-    case S_IWOTH:
-      access = ARM$M_WRITE;
-      break;
-    case S_IDUSR:
-    case S_IDGRP:
-    case S_IDOTH:
-      access = ARM$M_DELETE;
-      break;
+    case S_IXUSR: case S_IXGRP: case S_IXOTH:
+      access = ARM$M_EXECUTE; break;
+    case S_IRUSR: case S_IRGRP: case S_IROTH:
+      access = ARM$M_READ; break;
+    case S_IWUSR: case S_IWGRP: case S_IWOTH:
+      access = ARM$M_WRITE; break;
+    case S_IDUSR: case S_IDGRP: case S_IDOTH:
+      access = ARM$M_DELETE; break;
     default:
       return FALSE;
   }
@@ -4457,6 +4718,12 @@ cando_by_name(I32 bit, I32 effective, char *fname)
   if (retsts == SS$_ACCONFLICT) {
     return TRUE;
   }
+
+#if defined(__ALPHA) && defined(__VMS_VER) && __VMS_VER == 70100022 &&  defined(__DECC_VER) && __DECC_VER == 6009001
+  /* XXX Hideous kluge to accomodate error in specific version of RTL;
+     we hope it'll be buried soon */
+  if (retsts == 114762) return TRUE;
+#endif
   _ckvmssts(retsts);
 
   return FALSE;  /* Should never get here */
@@ -4469,7 +4736,7 @@ cando_by_name(I32 bit, I32 effective, char *fname)
 int
 flex_fstat(int fd, Stat_t *statbufp)
 {
-  dTHR;
+  dTHX;
   if (!fstat(fd,(stat_t *) statbufp)) {
     if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
     statbufp->st_dev = encode_dev(statbufp->st_devnam);
@@ -4499,17 +4766,19 @@ flex_fstat(int fd, Stat_t *statbufp)
 }  /* end of flex_fstat() */
 /*}}}*/
 
-/*{{{ int flex_stat(char *fspec, Stat_t *statbufp)*/
+/*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
 int
-flex_stat(char *fspec, Stat_t *statbufp)
+flex_stat(const char *fspec, Stat_t *statbufp)
 {
-    dTHR;
+    dTHX;
     char fileified[NAM$C_MAXRSS+1];
+    char temp_fspec[NAM$C_MAXRSS+300];
     int retval = -1;
 
+    strcpy(temp_fspec, fspec);
     if (statbufp == (Stat_t *) &PL_statcache)
-      do_tovmsspec(fspec,namecache,0);
-    if (is_null_device(fspec)) { /* Fake a stat() for the null device */
+      do_tovmsspec(temp_fspec,namecache,0);
+    if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
       memset(statbufp,0,sizeof *statbufp);
       statbufp->st_dev = encode_dev("_NLA0:");
       statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
@@ -4528,12 +4797,12 @@ flex_stat(char *fspec, Stat_t *statbufp)
      * the file with null type, specify this by calling flex_stat() with
      * a '.' at the end of fspec.
      */
-    if (do_fileify_dirspec(fspec,fileified,0) != NULL) {
+    if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
       retval = stat(fileified,(stat_t *) statbufp);
       if (!retval && statbufp == (Stat_t *) &PL_statcache)
         strcpy(namecache,fileified);
     }
-    if (retval) retval = stat(fspec,(stat_t *) statbufp);
+    if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
     if (!retval) {
       statbufp->st_dev = encode_dev(statbufp->st_devnam);
 #     ifdef RTL_USES_UTC
@@ -4599,7 +4868,7 @@ my_getlogin()
  */
 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
 int
-rmscopy(char *spec_in, char *spec_out, int preserve_dates)
+Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
 {
     char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
          rsa[NAM$C_MAXRSS], ubf[32256];
@@ -4645,9 +4914,10 @@ rmscopy(char *spec_in, char *spec_out, int preserve_dates)
     if (!((sts = sys$open(&fab_in)) & 1)) {
       set_vaxc_errno(sts);
       switch (sts) {
-        case RMS$_FNF:
-        case RMS$_DIR:
+        case RMS$_FNF: case RMS$_DNF:
           set_errno(ENOENT); break;
+        case RMS$_DIR:
+          set_errno(ENOTDIR); break;
         case RMS$_DEV:
           set_errno(ENODEV); break;
         case RMS$_SYN:
@@ -4689,8 +4959,10 @@ rmscopy(char *spec_in, char *spec_out, int preserve_dates)
     if (!((sts = sys$create(&fab_out)) & 1)) {
       set_vaxc_errno(sts);
       switch (sts) {
-        case RMS$_DIR:
+        case RMS$_DNF:
           set_errno(ENOENT); break;
+        case RMS$_DIR:
+          set_errno(ENOTDIR); break;
         case RMS$_DEV:
           set_errno(ENODEV); break;
         case RMS$_SYN:
@@ -4770,14 +5042,14 @@ rmscopy(char *spec_in, char *spec_out, int preserve_dates)
  */
 
 void
-rmsexpand_fromperl(CV *cv)
+rmsexpand_fromperl(pTHX_ CV *cv)
 {
   dXSARGS;
   char *fspec, *defspec = NULL, *rslt;
   STRLEN n_a;
 
   if (!items || items > 2)
-    croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
+    Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
   fspec = SvPV(ST(0),n_a);
   if (!fspec || !*fspec) XSRETURN_UNDEF;
   if (items == 2) defspec = SvPV(ST(1),n_a);
@@ -4789,13 +5061,13 @@ rmsexpand_fromperl(CV *cv)
 }
 
 void
-vmsify_fromperl(CV *cv)
+vmsify_fromperl(pTHX_ CV *cv)
 {
   dXSARGS;
   char *vmsified;
   STRLEN n_a;
 
-  if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
+  if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
   ST(0) = sv_newmortal();
   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
@@ -4803,13 +5075,13 @@ vmsify_fromperl(CV *cv)
 }
 
 void
-unixify_fromperl(CV *cv)
+unixify_fromperl(pTHX_ CV *cv)
 {
   dXSARGS;
   char *unixified;
   STRLEN n_a;
 
-  if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
+  if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
   ST(0) = sv_newmortal();
   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
@@ -4817,13 +5089,13 @@ unixify_fromperl(CV *cv)
 }
 
 void
-fileify_fromperl(CV *cv)
+fileify_fromperl(pTHX_ CV *cv)
 {
   dXSARGS;
   char *fileified;
   STRLEN n_a;
 
-  if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
+  if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
   ST(0) = sv_newmortal();
   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
@@ -4831,13 +5103,13 @@ fileify_fromperl(CV *cv)
 }
 
 void
-pathify_fromperl(CV *cv)
+pathify_fromperl(pTHX_ CV *cv)
 {
   dXSARGS;
   char *pathified;
   STRLEN n_a;
 
-  if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
+  if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
   ST(0) = sv_newmortal();
   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
@@ -4845,13 +5117,13 @@ pathify_fromperl(CV *cv)
 }
 
 void
-vmspath_fromperl(CV *cv)
+vmspath_fromperl(pTHX_ CV *cv)
 {
   dXSARGS;
   char *vmspath;
   STRLEN n_a;
 
-  if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
+  if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
   ST(0) = sv_newmortal();
   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
@@ -4859,13 +5131,13 @@ vmspath_fromperl(CV *cv)
 }
 
 void
-unixpath_fromperl(CV *cv)
+unixpath_fromperl(pTHX_ CV *cv)
 {
   dXSARGS;
   char *unixpath;
   STRLEN n_a;
 
-  if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
+  if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
   ST(0) = sv_newmortal();
   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
@@ -4873,7 +5145,7 @@ unixpath_fromperl(CV *cv)
 }
 
 void
-candelete_fromperl(CV *cv)
+candelete_fromperl(pTHX_ CV *cv)
 {
   dXSARGS;
   char fspec[NAM$C_MAXRSS+1], *fsp;
@@ -4881,7 +5153,7 @@ candelete_fromperl(CV *cv)
   IO *io;
   STRLEN n_a;
 
-  if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
+  if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
 
   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
   if (SvTYPE(mysv) == SVt_PVGV) {
@@ -4905,7 +5177,7 @@ candelete_fromperl(CV *cv)
 }
 
 void
-rmscopy_fromperl(CV *cv)
+rmscopy_fromperl(pTHX_ CV *cv)
 {
   dXSARGS;
   char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
@@ -4918,7 +5190,7 @@ rmscopy_fromperl(CV *cv)
   STRLEN n_a;
 
   if (items < 2 || items > 3)
-    croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
+    Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
 
   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
   if (SvTYPE(mysv) == SVt_PVGV) {
@@ -4958,10 +5230,93 @@ rmscopy_fromperl(CV *cv)
   XSRETURN(1);
 }
 
+
+void
+mod2fname(CV *cv)
+{
+  dXSARGS;
+  char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
+       workbuff[NAM$C_MAXRSS*1 + 1];
+  int total_namelen = 3, counter, num_entries;
+  /* ODS-5 ups this, but we want to be consistent, so... */
+  int max_name_len = 39;
+  AV *in_array = (AV *)SvRV(ST(0));
+
+  num_entries = av_len(in_array);
+
+  /* All the names start with PL_. */
+  strcpy(ultimate_name, "PL_");
+
+  /* Clean up our working buffer */
+  Zero(work_name, sizeof(work_name), char);
+
+  /* Run through the entries and build up a working name */
+  for(counter = 0; counter <= num_entries; counter++) {
+    /* If it's not the first name then tack on a __ */
+    if (counter) {
+      strcat(work_name, "__");
+    }
+    strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
+			   PL_na));
+  }
+
+  /* Check to see if we actually have to bother...*/
+  if (strlen(work_name) + 3 <= max_name_len) {
+    strcat(ultimate_name, work_name);
+  } else {
+    /* It's too darned big, so we need to go strip. We use the same */
+    /* algorithm as xsubpp does. First, strip out doubled __ */
+    char *source, *dest, last;
+    dest = workbuff;
+    last = 0;
+    for (source = work_name; *source; source++) {
+      if (last == *source && last == '_') {
+	continue;
+      }
+      *dest++ = *source;
+      last = *source;
+    }
+    /* Go put it back */
+    strcpy(work_name, workbuff);
+    /* Is it still too big? */
+    if (strlen(work_name) + 3 > max_name_len) {
+      /* Strip duplicate letters */
+      last = 0;
+      dest = workbuff;
+      for (source = work_name; *source; source++) {
+	if (last == toupper(*source)) {
+	continue;
+	}
+	*dest++ = *source;
+	last = toupper(*source);
+      }
+      strcpy(work_name, workbuff);
+    }
+
+    /* Is it *still* too big? */
+    if (strlen(work_name) + 3 > max_name_len) {
+      /* Too bad, we truncate */
+      work_name[max_name_len - 2] = 0;
+    }
+    strcat(ultimate_name, work_name);
+  }
+
+  /* Okay, return it */
+  ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
+  XSRETURN(1);
+}
+
 void
 init_os_extras()
 {
   char* file = __FILE__;
+  dTHX;
+  char temp_buff[512];
+  if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
+    no_translate_barewords = TRUE;
+  } else {
+    no_translate_barewords = FALSE;
+  }
 
   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
@@ -4971,6 +5326,7 @@ init_os_extras()
   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
+  newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
 
   return;