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

diff --git a/vms/vms.c b/vms/vms.c
index a498e16..40348e0 100644
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -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);
@@ -100,10 +113,10 @@ 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;
@@ -138,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;
@@ -207,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;
       }
     }
@@ -223,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
@@ -367,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
@@ -715,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:
@@ -741,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;
@@ -815,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;
@@ -880,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.
@@ -894,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)
@@ -987,9 +1060,10 @@ pipe_exit_routine()
     info = open_pipes;
 
     while (info) {
-      _ckvmssts(SYS$SETAST(0));
+      int need_eof;
+      _ckvmssts(sys$setast(0));
       need_eof = info->mode != 'r' && !info->done;
-      _ckvmssts(SYS$SETAST(1));
+      _ckvmssts(sys$setast(1));
       if (need_eof) {
         if (pipe_eof(info->fp, 1) & 1) did_stuff = 1;
       }
@@ -1000,26 +1074,26 @@ pipe_exit_routine()
     did_stuff = 0;
     info = open_pipes;
     while (info) {
-      _ckvmssts(SYS$SETAST(0));
+      _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));
+      _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));
+      _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));
+      _ckvmssts(sys$setast(1));
       info = info->next;
     }
 
@@ -1046,7 +1120,7 @@ popen_completion_ast(struct pipe_details *thispipe)
 }
 
 static unsigned long int setup_cmddsc(char *cmd, int check_img);
-static void vms_execfree();
+static void vms_execfree(pTHX);
 
 static PerlIO *
 safe_popen(char *cmd, char *mode)
@@ -1093,7 +1167,7 @@ safe_popen(char *cmd, char *mode)
                      0, popen_completion_ast,info,0,0,0));
     }
 
-    vms_execfree();
+    vms_execfree(aTHX);
     if (!handler_set_up) {
       _ckvmssts(sys$dclexh(&pipe_exitblock));
       handler_set_up = TRUE;
@@ -1137,9 +1211,9 @@ 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.  */
-    _ckvmssts(SYS$SETAST(0));
+    _ckvmssts(sys$setast(0));
     need_eof = info->mode != 'r' && !info->done;
-    _ckvmssts(SYS$SETAST(1));
+    _ckvmssts(sys$setast(1));
     if (need_eof) pipe_eof(info->fp,0);
     PerlIO_close(info->fp);
 
@@ -1147,10 +1221,10 @@ I32 Perl_my_pclose(pTHX_ FILE *fp)
     else waitpid(info->pid,(int *) &retsts,0);
 
     /* remove from list of open pipes */
-    _ckvmssts(SYS$SETAST(0));
+    _ckvmssts(sys$setast(0));
     if (last) last->next = info->next;
     else open_pipes = info->next;
-    _ckvmssts(SYS$SETAST(1));
+    _ckvmssts(sys$setast(1));
     Safefree(info);
 
     return retsts;
@@ -1251,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];
@@ -1298,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;
     }  
@@ -1390,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); }
 
 
@@ -1431,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;
@@ -1442,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;
@@ -1468,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] = ']';
     }
@@ -1498,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,'/');
       }
@@ -1525,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';
@@ -1743,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;
@@ -1929,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];
@@ -2059,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;
@@ -2159,12 +2232,16 @@ static char *do_tovmsspec(char *path, char *buf, int ts) {
     else if (!infront && *cp2 == '.') {
       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
-      else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) { /* handle "../" */
-        if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; 
+      else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
+        if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
         else if (*(cp1-2) == '[') *(cp1-1) = '-';
-        else {
-/*          if (*(cp1-1) != '.') *(cp1++) = '.'; */
-          *(cp1++) = '-';
+        else {  /* back up over previous directory name */
+          cp1--;
+          while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
+          if (*(cp1-1) == '[') {
+            memcpy(cp1,"000000.",7);
+            cp1 += 7;
+          }
         }
         cp2 += 2;
         if (cp2 == dirend) break;
@@ -2199,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;
@@ -2227,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;
@@ -2256,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)
@@ -2302,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);
 
@@ -2313,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
@@ -2518,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")))
 	    {
@@ -2530,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)
@@ -2559,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)
@@ -2637,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;
@@ -2914,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;
@@ -3073,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];
@@ -3214,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);
@@ -3326,7 +3407,7 @@ my_vfork()
 
 
 static void
-vms_execfree() {
+vms_execfree(pTHX) {
   if (PL_Cmd) {
     if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
     PL_Cmd = Nullch;
@@ -3388,6 +3469,7 @@ setup_cmddsc(char *cmd, int check_img)
 {
   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;
@@ -3443,18 +3525,44 @@ setup_cmddsc(char *cmd, int check_img)
     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)) {
+        _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);
@@ -3527,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:
@@ -3547,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;
@@ -3587,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:
@@ -3610,7 +3722,7 @@ do_spawn(char *cmd)
              Strerror(errno));
     }
   }
-  vms_execfree();
+  vms_execfree(aTHX);
   return substs;
 
 }  /* end of do_spawn() */
@@ -4568,26 +4680,14 @@ cando_by_name(I32 bit, Uid_t 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;
   }
@@ -4618,6 +4718,12 @@ cando_by_name(I32 bit, Uid_t 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 */
@@ -4762,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];
@@ -4808,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:
@@ -4852,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:
@@ -5121,6 +5230,82 @@ 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()
 {
@@ -5141,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;