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

diff --git a/vms/vms.c b/vms/vms.c
index f88fd9d..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;
@@ -131,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;
@@ -200,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;
       }
     }
@@ -216,7 +250,7 @@ vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 
 /*{{{ 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
@@ -266,6 +300,8 @@ Perl_my_getenv(pTHX_ 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
@@ -312,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
@@ -356,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
@@ -605,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);
         }
       }
@@ -698,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:
@@ -724,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;
@@ -798,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;
@@ -863,6 +904,9 @@ 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,
    * so we'll allow it for a gain in portability.
@@ -877,6 +921,52 @@ 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)
@@ -970,7 +1060,11 @@ pipe_exit_routine()
     info = open_pipes;
 
     while (info) {
-      if (info->mode != 'r' && !info->done) {
+      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;
@@ -980,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;
     }
 
@@ -1021,13 +1119,16 @@ 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,
@@ -1036,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 */
@@ -1062,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;
@@ -1101,6 +1197,7 @@ 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;
@@ -1114,15 +1211,20 @@ I32 Perl_my_pclose(pTHX_ 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,0);
+    _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;
@@ -1223,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];
@@ -1270,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;
     }  
@@ -1362,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); }
 
 
@@ -1403,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;
@@ -1414,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;
@@ -1440,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] = ']';
     }
@@ -1470,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,'/');
       }
@@ -1497,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';
@@ -1587,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))) {
@@ -1609,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;
@@ -1621,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) {
@@ -1629,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);
@@ -1646,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;
@@ -1690,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");
@@ -1702,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;
@@ -1721,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] */
@@ -1841,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;
@@ -1853,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;
@@ -1872,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);
@@ -1881,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];
@@ -2011,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;
@@ -2155,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;
@@ -2183,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;
@@ -2212,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)
@@ -2258,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);
 
@@ -2269,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
@@ -2474,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")))
 	    {
@@ -2486,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)
@@ -2515,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)
@@ -2593,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;
@@ -2870,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;
@@ -3029,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];
@@ -3170,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);
@@ -3281,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) {
@@ -3344,44 +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);
@@ -3392,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 */
@@ -3457,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:
@@ -3477,7 +3657,7 @@ vms_do_exec(char *cmd)
       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;
@@ -3517,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:
@@ -3540,7 +3722,7 @@ do_spawn(char *cmd)
              Strerror(errno));
     }
   }
-  vms_execfree();
+  vms_execfree(aTHX);
   return substs;
 
 }  /* end of do_spawn() */
@@ -3576,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))
@@ -3966,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;
 
@@ -3974,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))))
@@ -3987,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))))
@@ -4194,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);
@@ -4240,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);
@@ -4252,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);
@@ -4276,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)) {
@@ -4396,9 +4605,8 @@ 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
-Perl_cando(pTHX_ I32 bit, I32 effective, Stat_t *statbufp)
+bool
+Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
 {
   if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
   else {
@@ -4431,9 +4639,9 @@ Perl_cando(pTHX_ 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 =
@@ -4472,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;
   }
@@ -4522,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 */
@@ -4666,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];
@@ -4712,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:
@@ -4756,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:
@@ -5025,10 +5230,93 @@ rmscopy_fromperl(pTHX_ 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,"$");
@@ -5038,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;