X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=vms%2Fvms.c;h=1150ea3859835b6cc109569e4f4f7af8c509081f;hb=7dc9aaa56b11c3e04f31eb9de23451166e23126f;hp=cda75720fe84fc672ba1159d80133ee95724c225;hpb=95678dd58021da848cf512f7ec611b96d55a8e9c;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/vms/vms.c b/vms/vms.c
index cda7572..1150ea3 100644
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -1,11 +1,15 @@
 /* vms.c
  *
  * VMS-specific routines for perl5
+ * Version: 5.7.0
  *
- * Last revised: 20-Aug-1999 by Charles Bailey  bailey@newman.upenn.edu
- * Version: 5.5.60
+ * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name, 
+ *             and Perl_cando by Craig Berry
+ * 29-Aug-2000 Charles Lane's piping improvements rolled in
+ * 20-Aug-1999 revisions by Charles Bailey  bailey@newman.upenn.edu
  */
 
+#include <accdef.h>
 #include <acedef.h>
 #include <acldef.h>
 #include <armdef.h>
@@ -26,6 +30,7 @@
 #include <libdef.h>
 #include <lib$routines.h>
 #include <lnmdef.h>
+#include <msgdef.h>
 #include <prvdef.h>
 #include <psldef.h>
 #include <rms.h>
@@ -46,6 +51,9 @@
 #  define SS$_NOSUCHOBJECT 2696
 #endif
 
+/* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
+#define PERLIO_NOT_STDIO 0 
+
 /* Don't replace system definitions of vfork, getenv, and stat, 
  * code below needs to get to the underlying CRTL routines. */
 #define DONT_MASK_RTL_CALLS
@@ -57,6 +65,11 @@
 #  define WARN_INTERNAL WARN_MISC
 #endif
 
+#if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
+#  define RTL_USES_UTC 1
+#endif
+
+
 /* gcc's header files don't #define direct access macros
  * corresponding to VAXC's variant structs */
 #ifdef __GNUC__
@@ -90,6 +103,9 @@ struct itmlst_3 {
 #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)
 
+/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
+#define PERL_LNM_MAX_ALLOWED_INDEX 127
+
 static char *__mystrtolower(char *str)
 {
   if (str) for (; *str; ++str) *str= tolower(*str);
@@ -112,9 +128,13 @@ 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};
 
+#ifndef RTL_USES_UTC
+static int tz_updated = 1;
+#endif
+
 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 int
-Perl_vmstrnenv(pTHX_ const char *lnm, char *eqv, unsigned long int idx,
+Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 {
     char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
@@ -127,20 +147,29 @@ Perl_vmstrnenv(pTHX_ 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)
+#if defined(PERL_IMPLICIT_CONTEXT)
+    pTHX = NULL;
+#  if defined(USE_5005THREADS)
     /* 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);
+      aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
     } else {
-      thr = NULL;
+      aTHX = NULL;
     }
+# else
+    if (PL_curinterp) {
+      aTHX = PERL_GET_INTERP;
+    } else {
+      aTHX = NULL;
+    }
+
+#  endif
 #endif
 
-    if (!lnm || !eqv || idx > LNM$_MAX_INDEX) {
+    if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) {
       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
     }
     for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
@@ -197,13 +226,13 @@ Perl_vmstrnenv(pTHX_ const char *lnm, char *eqv, unsigned long int idx,
 	      /* 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 defined(USE_5005THREADS)
 	      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)
+#if defined(USE_5005THREADS)
 	      } else {
 		  Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
 	      }
@@ -278,7 +307,7 @@ 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;
     unsigned long int idx = 0;
-    int trnsuccess;
+    int trnsuccess, success, secure, saverr, savvmserr;
     SV *tmpsv;
 
     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
@@ -302,16 +331,25 @@ Perl_my_getenv(pTHX_ const char *lnm, bool sys)
         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,
+      if (sys) {
+        /* Impose security constraints only if tainting */
+        secure = PL_curinterp ? PL_tainting : will_taint;
+        saverr = errno;  savvmserr = vaxc$errno;
+      }
+      else secure = 0;
+      success = vmstrnenv(lnm,eqv,idx,
+                          secure ? fildev : NULL,
 #ifdef SECURE_INTERNAL_GETENV
-                    sys ? PERL__TRNENV_SECURE : 0
+                          secure ? PERL__TRNENV_SECURE : 0
 #else
-                                                0
+			  0
 #endif
-                                                 )) return eqv;
-      else return Nullch;
+			                                     );
+      /* Discard NOLOGNAM on internal calls since we're often looking
+       * for an optional name, and this "error" often shows up as the
+       * (bogus) exit status for a die() call later on.  */
+      if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
+      return success ? eqv : Nullch;
     }
 
 }  /* end of my_getenv() */
@@ -320,12 +358,12 @@ Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 
 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
 char *
-my_getenv_len(const char *lnm, unsigned long *len, bool sys)
+Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
 {
-    dTHX;
     char *buf, *cp1, *cp2;
     unsigned long idx = 0;
     static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
+    int secure, saverr, savvmserr;
     SV *tmpsv;
     
     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
@@ -349,25 +387,31 @@ 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,
+      if (sys) {
+        /* Impose security constraints only if tainting */
+        secure = PL_curinterp ? PL_tainting : will_taint;
+        saverr = errno;  savvmserr = vaxc$errno;
+      }
+      else secure = 0;
+      *len = vmstrnenv(lnm,buf,idx,
+                       secure ? fildev : NULL,
 #ifdef SECURE_INTERNAL_GETENV
-                           sys ? PERL__TRNENV_SECURE : 0
+                       secure ? PERL__TRNENV_SECURE : 0
 #else
-                                                       0
+                                                      0
 #endif
-                                                         )))
-	  return buf;
-      else
-	  return Nullch;
+		                                       );
+      /* Discard NOLOGNAM on internal calls since we're often looking
+       * for an optional name, and this "error" often shows up as the
+       * (bogus) exit status for a die() call later on.  */
+      if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
+      return *len ? buf : Nullch;
     }
 
 }  /* end of my_getenv_len() */
 /*}}}*/
 
-static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
+static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
 
 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
 
@@ -378,9 +422,9 @@ prime_env_iter(void)
  * find, in preparation for iterating over it.
  */
 {
-  dTHX;
   static int primed = 0;
   HV *seenhv = NULL, *envhv;
+  SV *sv = NULL;
   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
   unsigned short int chan;
 #ifndef CLI$M_TRUSTED
@@ -395,11 +439,34 @@ prime_env_iter(void)
   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam); 
-#if defined(USE_THREADS) || defined(USE_ITHREADS)
+#if defined(PERL_IMPLICIT_CONTEXT)
+  pTHX;
+#endif
+#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
   static perl_mutex primenv_mutex;
   MUTEX_INIT(&primenv_mutex);
 #endif
 
+#if defined(PERL_IMPLICIT_CONTEXT)
+    /* 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 */
+#if defined(USE_5005THREADS)
+    if (PL_curinterp) {
+      aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
+    } else {
+      aTHX = NULL;
+    }
+#else
+    if (PL_curinterp) {
+      aTHX = PERL_GET_INTERP;
+    } else {
+      aTHX = NULL;
+    }
+#endif
+#endif
+
   if (primed || !PL_envgv) return;
   MUTEX_LOCK(&primenv_mutex);
   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
@@ -431,8 +498,9 @@ prime_env_iter(void)
         }
         else {
           start++;
-          (void) hv_store(envhv,environ[j],start - environ[j] - 1,
-                          newSVpv(start,0),0);
+          sv = newSVpv(start,0);
+          SvTAINTED_on(sv);
+          (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
         }
       }
       continue;
@@ -521,7 +589,9 @@ prime_env_iter(void)
         continue;
       }
       PERL_HASH(hash,key,keylen);
-      hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
+      sv = newSVpvn(cp2,cp1 - cp2 + 1);
+      SvTAINTED_on(sv);
+      hv_store(envhv,key,keylen,sv,hash);
       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
     }
     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
@@ -531,7 +601,9 @@ prime_env_iter(void)
       int trnlen, i;
       for (i = 0; ppfs[i]; i++) {
         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
-        hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
+        sv = newSVpv(eqv,trnlen);
+        SvTAINTED_on(sv);
+        hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
       }
     }
   }
@@ -554,7 +626,7 @@ prime_env_iter(void)
  * Like setenv() returns 0 for success, non-zero on error.
  */
 int
-vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
+Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
 {
     char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
@@ -564,7 +636,6 @@ 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);
@@ -584,7 +655,7 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
             if ((cp1 = strchr(environ[i],'=')) && 
                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
 #ifdef HAS_SETENV
-              return setenv(lnm,eqv,1) ? vaxc$errno : 0;
+              return setenv(lnm,"",1) ? vaxc$errno : 0;
             }
           }
           ivenv = 1; retsts = SS$_NOLOGNAM;
@@ -692,19 +763,56 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
 void
 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
 {
-  if (lnm && *lnm && strlen(lnm) == 7) {
-    char uplnm[8];
-    int i;
-    for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
-    if (!strcmp(uplnm,"DEFAULT")) {
-      if (eqv && *eqv) chdir(eqv);
-      return;
+    if (lnm && *lnm) {
+      int len = strlen(lnm);
+      if  (len == 7) {
+        char uplnm[8];
+        int i;
+        for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
+        if (!strcmp(uplnm,"DEFAULT")) {
+          if (eqv && *eqv) chdir(eqv);
+          return;
+        }
+    } 
+#ifndef RTL_USES_UTC
+    if (len == 6 || len == 2) {
+      char uplnm[7];
+      int i;
+      for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
+      uplnm[len] = '\0';
+      if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
+      if (!strcmp(uplnm,"TZ")) tz_updated = 1;
     }
+#endif
   }
   (void) vmssetenv(lnm,eqv,NULL);
 }
 /*}}}*/
 
+/*{{{static void vmssetuserlnm(char *name, char *eqv);
+/*  vmssetuserlnm
+ *  sets a user-mode logical in the process logical name table
+ *  used for redirection of sys$error
+ */
+void
+Perl_vmssetuserlnm(pTHX_ char *name, char *eqv)
+{
+    $DESCRIPTOR(d_tab, "LNM$PROCESS");
+    struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
+    unsigned long int iss, attr = LNM$M_CONFINE;
+    unsigned char acmode = PSL$C_USER;
+    struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
+                                 {0, 0, 0, 0}};
+    d_name.dsc$a_pointer = name;
+    d_name.dsc$w_length = strlen(name);
+
+    lnmlst[0].buflen = strlen(eqv);
+    lnmlst[0].bufadr = eqv;
+
+    iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
+    if (!(iss&1)) lib$signal(iss);
+}
+/*}}}*/
 
 
 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
@@ -718,7 +826,7 @@ Perl_my_setenv(pTHX_ char *lnm,char *eqv)
  *  be upcased by the caller.
  */
 char *
-my_crypt(const char *textpasswd, const char *usrname)
+Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
 {
 #   ifndef UAI$C_PREFERRED_ALGORITHM
 #     define UAI$C_PREFERRED_ALGORITHM 127
@@ -798,12 +906,11 @@ Perl_do_rmdir(pTHX_ char *name)
  */
 /*{{{int kill_file(char *name)*/
 int
-kill_file(char *name)
+Perl_kill_file(pTHX_ 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;
@@ -900,10 +1007,9 @@ kill_file(char *name)
 
 /*{{{int my_mkdir(char *,Mode_t)*/
 int
-my_mkdir(char *dir, Mode_t mode)
+Perl_my_mkdir(pTHX_ char *dir, Mode_t mode)
 {
   STRLEN dirlen = strlen(dir);
-  dTHX;
 
   /* zero length string sometimes gives ACCVIO */
   if (dirlen == 0) return -1;
@@ -924,10 +1030,9 @@ my_mkdir(char *dir, Mode_t mode)
 
 /*{{{int my_chdir(char *)*/
 int
-my_chdir(char *dir)
+Perl_my_chdir(pTHX_ char *dir)
 {
   STRLEN dirlen = strlen(dir);
-  dTHX;
 
   /* zero length string sometimes gives ACCVIO */
   if (dirlen == 0) return -1;
@@ -954,7 +1059,6 @@ my_tmpfile(void)
 {
   FILE *fp;
   char *cp;
-  dTHX;
 
   if ((fp = tmpfile())) return fp;
 
@@ -969,24 +1073,45 @@ my_tmpfile(void)
 /*}}}*/
 
 
+#ifndef HOMEGROWN_POSIX_SIGNALS
+/*
+ * The C RTL's sigaction fails to check for invalid signal numbers so we 
+ * help it out a bit.  The docs are correct, but the actual routine doesn't
+ * do what the docs say it will.
+ */
+/*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
+int
+Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act, 
+                   struct sigaction* oact)
+{
+  if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
+	SETERRNO(EINVAL, SS$_INVARG);
+	return -1;
+  }
+  return sigaction(sig, act, oact);
+}
+/*}}}*/
+#endif
+
+/* default piping mailbox size */
+#define PERL_BUFSIZ        512
+
+
 static void
-create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
+create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
 {
   unsigned long int mbxbufsiz;
   static unsigned long int syssize = 0;
   unsigned long int dviitm = DVI$_DEVNAM;
-  dTHX;
   char csize[LNM$C_NAMLENGTH+1];
   
   if (!syssize) {
     unsigned long syiitm = SYI$_MAXBUF;
     /*
-     * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
-     * preprocessor consant BUFSIZ from stdio.h defaults as the size of the
-     * 'pipe' mailbox.
+     * Get the SYSGEN parameter MAXBUF
      *
      * If the logical 'PERL_MBX_SIZE' is defined
-     * use the value of the logical instead of BUFSIZ, but again
+     * use the value of the logical instead of PERL_BUFSIZ, but 
      * keep the size between 128 and MAXBUF.
      *
      */
@@ -996,7 +1121,7 @@ create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
       mbxbufsiz = atoi(csize);
   } else {
-      mbxbufsiz = BUFSIZ;
+      mbxbufsiz = PERL_BUFSIZ;
   }
   if (mbxbufsiz < 128) mbxbufsiz = 128;
   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
@@ -1062,6 +1187,10 @@ struct _pipe {
     pInfo          info;
     pCBuf          curr;
     pCBuf          curr2;
+#if defined(PERL_IMPLICIT_CONTEXT)
+    void	    *thx;	    /* Either a thread or an interpreter */
+                                    /* pointer, depending on how we're built */
+#endif
 };
 
 
@@ -1103,12 +1232,11 @@ static $DESCRIPTOR(nl_desc, "NL:");
 
 
 static unsigned long int
-pipe_exit_routine()
+pipe_exit_routine(pTHX)
 {
     pInfo info;
     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
     int sts, did_stuff, need_eof;
-    dTHX;
 
     /* 
      first we try sending an EOF...ignore if doesn't work, make sure we
@@ -1173,7 +1301,6 @@ static void pipe_tochild2_ast(pPipe p);
 static void
 popen_completion_ast(pInfo info)
 {
-  dTHX;
   pInfo i = open_pipes;
   int iss;
 
@@ -1205,9 +1332,9 @@ popen_completion_ast(pInfo info)
   if (info->in && !info->in_done) {               /* only for mode=w */
         if (info->in->shut_on_empty && info->in->need_wake) {
             info->in->need_wake = FALSE;
-            _ckvmssts(sys$dclast(pipe_tochild2_ast,info->in,0));
+            _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
         } else {
-            _ckvmssts(sys$cancel(info->in->chan_out));
+            _ckvmssts_noperl(sys$cancel(info->in->chan_out));
         }
   }
 
@@ -1215,20 +1342,20 @@ popen_completion_ast(pInfo info)
       info->out->shut_on_empty = TRUE;
       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
-      _ckvmssts(iss);
+      _ckvmssts_noperl(iss);
   }
 
   if (info->err && !info->err_done) {        /* we were piping stderr */
         info->err->shut_on_empty = TRUE;
         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
-        _ckvmssts(iss);
+        _ckvmssts_noperl(iss);
   }
-  _ckvmssts(sys$setef(pipe_ef));
+  _ckvmssts_noperl(sys$setef(pipe_ef));
 
 }
 
-static unsigned long int setup_cmddsc(char *cmd, int check_img);
+static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img);
 static void vms_execfree(pTHX);
 
 /*
@@ -1238,7 +1365,7 @@ static void vms_execfree(pTHX);
 */
 
 static unsigned short
-popen_translate(char *logical, char *result)
+popen_translate(pTHX_ char *logical, char *result)
 {
     int iss;
     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
@@ -1298,9 +1425,8 @@ static void pipe_infromchild_ast(pPipe p);
 #define INITIAL_TOCHILDQUEUE  2
 
 static pPipe
-pipe_tochild_setup(char *rmbx, char *wmbx)
+pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
 {
-    dTHX;
     pPipe p;
     pCBuf b;
     char mbx1[64], mbx2[64];
@@ -1313,8 +1439,8 @@ pipe_tochild_setup(char *rmbx, char *wmbx)
 
     New(1368, p, 1, Pipe);
 
-    create_mbx(&p->chan_in , &d_mbx1);
-    create_mbx(&p->chan_out, &d_mbx2);
+    create_mbx(aTHX_ &p->chan_in , &d_mbx1);
+    create_mbx(aTHX_ &p->chan_out, &d_mbx2);
     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
 
     p->buf           = 0;
@@ -1329,6 +1455,9 @@ pipe_tochild_setup(char *rmbx, char *wmbx)
     p->curr          = 0;
     p->curr2         = 0;
     p->info          = 0;
+#ifdef PERL_IMPLICIT_CONTEXT
+    p->thx	     = aTHX;
+#endif
 
     n = sizeof(CBuf) + p->bufsize;
 
@@ -1350,10 +1479,12 @@ pipe_tochild_setup(char *rmbx, char *wmbx)
 static void
 pipe_tochild1_ast(pPipe p)
 {
-    dTHX;
     pCBuf b = p->curr;
     int iss = p->iosb.status;
     int eof = (iss == SS$_ENDOFFILE);
+#ifdef PERL_IMPLICIT_CONTEXT
+    pTHX = p->thx;
+#endif
 
     if (p->retry) {
         if (eof) {
@@ -1410,12 +1541,14 @@ pipe_tochild1_ast(pPipe p)
 static void
 pipe_tochild2_ast(pPipe p)
 {
-    dTHX;
     pCBuf b = p->curr2;
     int iss = p->iosb2.status;
     int n = sizeof(CBuf) + p->bufsize;
     int done = (p->info && p->info->done) ||
               iss == SS$_CANCEL || iss == SS$_ABORT;
+#if defined(PERL_IMPLICIT_CONTEXT)
+    pTHX = p->thx;
+#endif
 
     do {
         if (p->type) {         /* type=1 has old buffer, dispose */
@@ -1463,9 +1596,8 @@ pipe_tochild2_ast(pPipe p)
 
 
 static pPipe
-pipe_infromchild_setup(char *rmbx, char *wmbx)
+pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
 {
-    dTHX;
     pPipe p;
     char mbx1[64], mbx2[64];
     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
@@ -1475,8 +1607,8 @@ pipe_infromchild_setup(char *rmbx, char *wmbx)
     unsigned int dviitm = DVI$_DEVBUFSIZ;
 
     New(1367, p, 1, Pipe);
-    create_mbx(&p->chan_in , &d_mbx1);
-    create_mbx(&p->chan_out, &d_mbx2);
+    create_mbx(aTHX_ &p->chan_in , &d_mbx1);
+    create_mbx(aTHX_ &p->chan_out, &d_mbx2);
 
     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
     New(1367, p->buf, p->bufsize, char);
@@ -1484,6 +1616,9 @@ pipe_infromchild_setup(char *rmbx, char *wmbx)
     p->info   = 0;
     p->type   = 0;
     p->iosb.status = SS$_NORMAL;
+#if defined(PERL_IMPLICIT_CONTEXT)
+    p->thx = aTHX;
+#endif
     pipe_infromchild_ast(p);
 
     strcpy(wmbx, mbx1);
@@ -1494,11 +1629,13 @@ pipe_infromchild_setup(char *rmbx, char *wmbx)
 static void
 pipe_infromchild_ast(pPipe p)
 {
-    dTHX;
     int iss = p->iosb.status;
     int eof = (iss == SS$_ENDOFFILE);
     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
+#if defined(PERL_IMPLICIT_CONTEXT)
+    pTHX = p->thx;
+#endif
 
     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
         _ckvmssts(sys$dassgn(p->chan_out));
@@ -1570,9 +1707,8 @@ pipe_infromchild_ast(pPipe p)
 }
 
 static pPipe
-pipe_mbxtofd_setup(int fd, char *out)
+pipe_mbxtofd_setup(pTHX_ int fd, char *out)
 {
-    dTHX;
     pPipe p;
     char mbx[64];
     unsigned long dviitm = DVI$_DEVBUFSIZ;
@@ -1595,7 +1731,7 @@ pipe_mbxtofd_setup(int fd, char *out)
 
     New(1366, p, 1, Pipe);
     p->fd_out = dup(fd);
-    create_mbx(&p->chan_in, &d_mbx);
+    create_mbx(aTHX_ &p->chan_in, &d_mbx);
     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
     New(1366, p->buf, p->bufsize+1, char);
     p->shut_on_empty = FALSE;
@@ -1613,14 +1749,15 @@ pipe_mbxtofd_setup(int fd, char *out)
 static void
 pipe_mbxtofd_ast(pPipe p)
 {
-    dTHX;
     int iss = p->iosb.status;
     int done = p->info->done;
     int iss2;
     int eof = (iss == SS$_ENDOFFILE);
     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
     int err = !(iss&1) && !eof;
-
+#if defined(PERL_IMPLICIT_CONTEXT)
+    pTHX = p->thx;
+#endif
 
     if (done && myeof) {               /* end piping */
         close(p->fd_out);
@@ -1663,9 +1800,21 @@ struct _pipeloc {
 };
 static pPLOC  head_PLOC = 0;
 
+void
+free_pipelocs(pTHX_ void *head)
+{
+    pPLOC p, pnext;
+
+    p = (pPLOC) head;
+    while (p) {
+        pnext = p->next;
+        Safefree(p);
+        p = pnext;
+    }
+}
 
 static void
-store_pipelocs()
+store_pipelocs(pTHX)
 {
     int    i;
     pPLOC  p;
@@ -1729,12 +1878,12 @@ store_pipelocs()
         p->dir[NAM$C_MAXRSS] = '\0';
     }
 #endif
-
+    Perl_call_atexit(aTHX_ &free_pipelocs, head_PLOC);
 }
 
 
 static char *
-find_vmspipe(void)
+find_vmspipe(pTHX)
 {
     static int   vmspipe_file_status = 0;
     static char  vmspipe_file[NAM$C_MAXRSS+1];
@@ -1776,7 +1925,7 @@ find_vmspipe(void)
 }
 
 static FILE *
-vmspipe_tempfile(void)
+vmspipe_tempfile(pTHX)
 {
     char file[NAM$C_MAXRSS+1];
     FILE *fp;
@@ -1817,17 +1966,19 @@ vmspipe_tempfile(void)
     fprintf(fp,"$ perl_del    = \"delete\"\n");
     fprintf(fp,"$ pif         = \"if\"\n");
     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
-    fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define sys$input  'perl_popen_in'\n");
-    fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define sys$error  'perl_popen_err'\n");
+    fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
+    fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
+    fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
     fprintf(fp,"$ cmd = perl_popen_cmd\n");
     fprintf(fp,"$!  --- get rid of global symbols\n");
     fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
     fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
+    fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
     fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n");
     fprintf(fp,"$ perl_on\n");
     fprintf(fp,"$ 'cmd\n");
     fprintf(fp,"$ perl_status = $STATUS\n");
-    fprintf(fp,"$ perl_del 'perl_cfile'\n");
+    fprintf(fp,"$ perl_del  'perl_cfile'\n");
     fprintf(fp,"$ perl_exit 'perl_status'\n");
     fsync(fileno(fp));
 
@@ -1853,9 +2004,8 @@ vmspipe_tempfile(void)
 
 
 static PerlIO *
-safe_popen(char *cmd, char *mode)
+safe_popen(pTHX_ char *cmd, char *mode)
 {
-    dTHX;
     static int handler_set_up = FALSE;
     unsigned long int sts, flags=1;  /* nowait - gnu c doesn't allow &1 */
     unsigned int table = LIB$K_CLI_GLOBAL_SYM;
@@ -1866,12 +2016,12 @@ safe_popen(char *cmd, char *mode)
     pInfo info;
     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
                                       DSC$K_CLASS_S, symbol};
-    struct dsc$descriptor_s d_out = {0, DSC$K_DTYPE_T,
-                                      DSC$K_CLASS_S, out};
     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
                                       DSC$K_CLASS_S, 0};
+
     $DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD");
     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
+    $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
                             
     /* once-per-program initialization...
@@ -1903,11 +2053,11 @@ safe_popen(char *cmd, char *mode)
     /* see if we can find a VMSPIPE.COM */
 
     tfilebuf[0] = '@';
-    vmspipe = find_vmspipe();
+    vmspipe = find_vmspipe(aTHX);
     if (vmspipe) {
         strcpy(tfilebuf+1,vmspipe);
     } else {        /* uh, oh...we're in tempfile hell */
-        tpipe = vmspipe_tempfile();
+        tpipe = vmspipe_tempfile(aTHX);
         if (!tpipe) {       /* a fish popular in Boston */
             if (ckWARN(WARN_PIPE)) {
                 Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
@@ -1919,7 +2069,32 @@ safe_popen(char *cmd, char *mode)
     vmspipedsc.dsc$a_pointer = tfilebuf;
     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
 
-    if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
+    sts = setup_cmddsc(aTHX_ cmd,0);
+    if (!(sts & 1)) { 
+      switch (sts) {
+        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$_PRV:
+          set_errno(EACCES); break;
+        case RMS$_SYN:
+          set_errno(EINVAL); break;
+        case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
+          set_errno(E2BIG); break;
+        case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
+          _ckvmssts(sts); /* fall through */
+        default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
+          set_errno(EVMSERR); 
+      }
+      set_vaxc_errno(sts);
+      if (ckWARN(WARN_PIPE)) {
+        Perl_warner(aTHX_ WARN_PIPE,"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
+      }
+      return Nullfp; 
+    }
     New(1301,info,1,Info);
         
     info->mode = *mode;
@@ -1932,11 +2107,11 @@ safe_popen(char *cmd, char *mode)
     info->in_done    = TRUE;
     info->out_done   = TRUE;
     info->err_done   = TRUE;
+    in[0] = out[0] = err[0] = '\0';
 
     if (*mode == 'r') {             /* piping from subroutine */
-        in[0] = '\0';
 
-        info->out = pipe_infromchild_setup(mbx,out);
+        info->out = pipe_infromchild_setup(aTHX_ mbx,out);
         if (info->out) {
             info->out->pipe_done = &info->out_done;
             info->out_done = FALSE;
@@ -1953,15 +2128,15 @@ safe_popen(char *cmd, char *mode)
                 if (!done) _ckvmssts(sys$clref(pipe_ef));
                 _ckvmssts(sys$setast(1));
                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
-    }
+            }
 
             if (info->out->buf) Safefree(info->out->buf);
             Safefree(info->out);
             Safefree(info);
             return Nullfp;
-    }
+        }
 
-        info->err = pipe_mbxtofd_setup(fileno(stderr), err);
+        info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
         if (info->err) {
             info->err->pipe_done = &info->err_done;
             info->err_done = FALSE;
@@ -1969,9 +2144,8 @@ safe_popen(char *cmd, char *mode)
         }
 
     } else {                        /* piping to subroutine , mode=w*/
-        int melded;
 
-        info->in = pipe_tochild_setup(in,mbx);
+        info->in = pipe_tochild_setup(aTHX_ in,mbx);
         info->fp  = PerlIO_open(mbx, mode);
         if (info->in) {
             info->in->pipe_done = &info->in_done;
@@ -1997,40 +2171,24 @@ safe_popen(char *cmd, char *mode)
             if (info->in->buf) Safefree(info->in->buf);
             Safefree(info->in);
             Safefree(info);
-        return Nullfp;
+            return Nullfp;
         }
         
-        /* if SYS$ERROR == SYS$OUTPUT, use only one mbx */
-        
-        melded = FALSE;
-        fgetname(stderr, err);
-        if (strncmp(err,"SYS$ERROR:",10) == 0) {
-            fgetname(stdout, out);
-            if (strncmp(out,"SYS$OUTPUT:",11) == 0) {
-                if (popen_translate("SYS$OUTPUT",out) == popen_translate("SYS$ERROR",err)) {
-                    melded = TRUE;
-                }
-    }
-    }
 
-        info->out = pipe_mbxtofd_setup(fileno(stdout), out);
+        info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
         if (info->out) {
             info->out->pipe_done = &info->out_done;
             info->out_done = FALSE;
             info->out->info = info;
         }
-        if (!melded) {
-            info->err = pipe_mbxtofd_setup(fileno(stderr), err);
-            if (info->err) {
-                info->err->pipe_done = &info->err_done;
-                info->err_done = FALSE;
-                info->err->info = info;
-    }
-        } else {
-            err[0] = '\0';
-    }
+
+        info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
+        if (info->err) {
+            info->err->pipe_done = &info->err_done;
+            info->err_done = FALSE;
+            info->err->info = info;
+        }
     }
-    d_out.dsc$w_length = strlen(out);   /* lib$spawn sets SYS$OUTPUT so can meld*/
 
     symbol[MAX_DCL_SYMBOL] = '\0';
 
@@ -2042,6 +2200,9 @@ safe_popen(char *cmd, char *mode)
     d_symbol.dsc$w_length = strlen(symbol);
     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
 
+    strncpy(symbol, out, MAX_DCL_SYMBOL);
+    d_symbol.dsc$w_length = strlen(symbol);
+    _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
 
     p = VMScmd.dsc$a_pointer;
     while (*p && *p != '\n') p++;
@@ -2058,7 +2219,7 @@ safe_popen(char *cmd, char *mode)
     info->next=open_pipes;  /* prepend to list */
     open_pipes=info;
     _ckvmssts(sys$setast(1));
-    _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &d_out, &flags,
+    _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
                       0, &info->pid, &info->completion,
                       0, popen_completion_ast,info,0,0,0));
 
@@ -2072,7 +2233,7 @@ safe_popen(char *cmd, char *mode)
     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
-
+    _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
     vms_execfree(aTHX);
         
     PL_forkprocess = info->pid;
@@ -2080,22 +2241,21 @@ safe_popen(char *cmd, char *mode)
 }  /* end of safe_popen */
 
 
-/*{{{  FILE *my_popen(char *cmd, char *mode)*/
-FILE *
+/*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
+PerlIO *
 Perl_my_popen(pTHX_ char *cmd, char *mode)
 {
     TAINT_ENV();
     TAINT_PROPER("popen");
     PERL_FLUSHALL_FOR_CHILD;
-    return safe_popen(cmd,mode);
+    return safe_popen(aTHX_ cmd,mode);
 }
 
 /*}}}*/
 
-/*{{{  I32 my_pclose(FILE *fp)*/
-I32 Perl_my_pclose(pTHX_ FILE *fp)
+/*{{{  I32 my_pclose(PerlIO *fp)*/
+I32 Perl_my_pclose(pTHX_ PerlIO *fp)
 {
-    dTHX;
     pInfo info, last = NULL;
     unsigned long int retsts;
     int done, iss;
@@ -2117,7 +2277,7 @@ I32 Perl_my_pclose(pTHX_ FILE *fp)
      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
      */
 
-     fsync(fileno(info->fp));   /* first, flush data */
+     PerlIO_flush(info->fp);   /* first, flush data */
 
     _ckvmssts(sys$setast(0));
      info->closing = TRUE;
@@ -2178,14 +2338,26 @@ I32 Perl_my_pclose(pTHX_ FILE *fp)
 
 }  /* end of my_pclose() */
 
-/* sort-of waitpid; use only with popen() */
+#if defined(__CRTL_VER) && __CRTL_VER >= 70100322
+  /* Roll our own prototype because we want this regardless of whether
+   * _VMS_WAIT is defined.
+   */
+  __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
+#endif
+/* sort-of waitpid; special handling of pipe clean-up for subprocesses 
+   created with popen(); otherwise partially emulate waitpid() unless 
+   we have a suitable one from the CRTL that came with VMS 7.2 and later.
+   Also check processes not considered by the CRTL waitpid().
+ */
 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
 Pid_t
-my_waitpid(Pid_t pid, int *statusp, int flags)
+Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
 {
     pInfo info;
     int done;
-    dTHX;
+    int sts;
+    
+    if (statusp) *statusp = 0;
     
     for (info = open_pipes; info != NULL; info = info->next)
         if (info->pid == pid) break;
@@ -2199,37 +2371,140 @@ my_waitpid(Pid_t pid, int *statusp, int flags)
           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
       }
 
-      *statusp = info->completion;
+      if (statusp) *statusp = info->completion;
       return pid;
+
     }
-    else {  /* we haven't heard of this child */
+    else {  /* this child is not one of our own pipe children */
+
+#if defined(__CRTL_VER) && __CRTL_VER >= 70100322
+
+      /* waitpid() became available in the CRTL as of VMS 7.0, but only
+       * in 7.2 did we get a version that fills in the VMS completion
+       * status as Perl has always tried to do.
+       */
+
+      sts = __vms_waitpid( pid, statusp, flags );
+
+      if ( sts == 0 || !(sts == -1 && errno == ECHILD) ) 
+         return sts;
+
+      /* If the real waitpid tells us the child does not exist, we 
+       * fall through here to implement waiting for a child that 
+       * was created by some means other than exec() (say, spawned
+       * from DCL) or to wait for a process that is not a subprocess 
+       * of the current process.
+       */
+
+#endif /* defined(__CRTL_VER) && __CRTL_VER >= 70100322 */
+
       $DESCRIPTOR(intdsc,"0 00:00:01");
-      unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
-      unsigned long int interval[2],sts;
+      unsigned long int ownercode = JPI$_OWNER, ownerpid;
+      unsigned long int pidcode = JPI$_PID, mypid;
+      unsigned long int interval[2];
+      int termination_mbu = 0;
+      unsigned short qio_iosb[4];
+      unsigned int jpi_iosb[2];
+      struct itmlst_3 jpilist[3] = { 
+          {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
+          {sizeof(termination_mbu), JPI$_TMBU,  &termination_mbu, 0},
+          {                      0,         0,                 0, 0} 
+      };
+      char trmmbx[NAM$C_DVI+1];
+      $DESCRIPTOR(trmmbxdsc,trmmbx);
+      struct accdef trmmsg;
+      unsigned short int mbxchan;
+
+      if (pid <= 0) {
+        /* Sorry folks, we don't presently implement rooting around for 
+           the first child we can find, and we definitely don't want to
+           pass a pid of -1 to $getjpi, where it is a wildcard operation.
+         */
+        set_errno(ENOTSUP); 
+        return -1;
+      }
+
+      /* Get the owner of the child so I can warn if it's not mine, plus
+       * get the termination mailbox.  If the process doesn't exist or I
+       * don't have the privs to look at it, I can go home early.
+       */
+      sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
+      if (sts & 1) sts = jpi_iosb[0];
+      if (!(sts & 1)) {
+        switch (sts) {
+            case SS$_NONEXPR:
+                set_errno(ECHILD);
+                break;
+            case SS$_NOPRIV:
+                set_errno(EACCES);
+                break;
+            default:
+                _ckvmssts(sts);
+        }
+        set_vaxc_errno(sts);
+        return -1;
+      }
 
       if (ckWARN(WARN_EXEC)) {
-        _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
-        _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
+        /* remind folks they are asking for non-standard waitpid behavior */
+        _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
         if (ownerpid != mypid)
-          Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
+          Perl_warner(aTHX_ WARN_EXEC,
+                      "waitpid: process %x is not a child of process %x",
+                      pid,mypid);
       }
 
-      _ckvmssts(sys$bintim(&intdsc,interval));
-      while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
-        _ckvmssts(sys$schdwk(0,0,interval,0));
-        _ckvmssts(sys$hiber());
+      /* It's possible to have a mailbox unit number but no actual mailbox; we 
+       * check for this by assigning a channel to it, which we need anyway.
+       */
+      if (termination_mbu != 0) {
+          sprintf(trmmbx, "MBA%d:", termination_mbu);
+          trmmbxdsc.dsc$w_length = strlen(trmmbx);
+          sts = sys$assign(&trmmbxdsc, &mbxchan, 0, 0);
+          if (sts == SS$_NOSUCHDEV) {
+              termination_mbu = 0; /* set up to take "no mailbox" case */
+              sts = SS$_NORMAL;
+          }
+          _ckvmssts(sts);
       }
-      if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
-      _ckvmssts(sts);
-
-      /* There's no easy way to find the termination status a child we're
-       * not aware of beforehand.  If we're really interested in the future,
-       * we can go looking for a termination mailbox, or chase after the
-       * accounting record for the process.
+      /* If the process doesn't have a termination mailbox, then simply check
+       * on it once a second until it's not there anymore.
        */
-      *statusp = 0;
+      if (termination_mbu == 0) {
+          _ckvmssts(sys$bintim(&intdsc,interval));
+          while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
+            _ckvmssts(sys$schdwk(0,0,interval,0));
+            _ckvmssts(sys$hiber());
+          }
+          if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
+      } 
+      else {
+        /* If we do have a termination mailbox, post reads to it until we get a
+         * termination message, discarding messages of the wrong type or for other
+         * processes.  If there is a place to put the final status, then do so.
+         */
+          sts = SS$_NORMAL;
+          while (sts & 1) {
+              memset((void *) &trmmsg, 0, sizeof(trmmsg));
+              sts = sys$qiow(0,mbxchan,IO$_READVBLK,&qio_iosb,0,0,
+                             &trmmsg,ACC$K_TERMLEN,0,0,0,0);
+              if (sts & 1) sts = qio_iosb[0];
+
+              if ( sts & 1 
+                   && trmmsg.acc$w_msgtyp == MSG$_DELPROC 
+                   && trmmsg.acc$l_pid == pid ) {
+
+                  if (statusp) *statusp = trmmsg.acc$l_finalsts;
+                  sts = sys$dassgn(mbxchan);
+                  break;
+              }
+          }
+      } /* termination_mbu ? */
+
+      _ckvmssts(sts);
       return pid;
-    }
+
+    } /* else one of our own pipe children */
                     
 }  /* end of waitpid() */
 /*}}}*/
@@ -2497,6 +2772,10 @@ static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
       dir[--dirlen] = '\0';
       dir[dirlen-1] = ']';
     }
+    if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) {
+      dir[--dirlen] = '\0';
+      dir[dirlen-1] = '>';
+    }
 
     if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
       /* If we've got an explicit filename, we can just shuffle the string. */
@@ -2719,6 +2998,7 @@ static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
           else if (ts) New(1312,retspec,retlen+16,char);
           else retspec = __fileify_retbuf;
           cp1 = strstr(esa,"][");
+          if (!cp1) cp1 = strstr(esa,"]<");
           dirlen = cp1 - esa;
           memcpy(retspec,esa,dirlen);
           if (!strncmp(cp1+2,"000000]",7)) {
@@ -3338,7 +3618,7 @@ static void mp_expand_wild_cards(pTHX_ char *item,
 
 static int background_process(int argc, char **argv);
 
-static void pipe_and_fork(char **cmargv);
+static void pipe_and_fork(pTHX_ char **cmargv);
 
 /*{{{ void getredirection(int *ac, char ***av)*/
 static void
@@ -3402,7 +3682,7 @@ mp_getredirection(pTHX_ int *ac, char ***av)
 	    {
 	    if (j+1 >= argc)
 		{
-		PerlIO_printf(Perl_debug_log,"No input file after < on command line");
+		fprintf(stderr,"No input file after < on command line");
 		exit(LIB$_WRONUMARG);
 		}
 	    in = argv[++j];
@@ -3417,7 +3697,7 @@ mp_getredirection(pTHX_ int *ac, char ***av)
 	    {
 	    if (j+1 >= argc)
 		{
-		PerlIO_printf(Perl_debug_log,"No output file after > on command line");
+		fprintf(stderr,"No output file after > on command line");
 		exit(LIB$_WRONUMARG);
 		}
 	    out = argv[++j];
@@ -3437,7 +3717,7 @@ mp_getredirection(pTHX_ int *ac, char ***av)
 		out = 1 + ap;
 	    if (j >= argc)
 		{
-		PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
+		fprintf(stderr,"No output file after > or >> on command line");
 		exit(LIB$_WRONUMARG);
 		}
 	    continue;
@@ -3459,7 +3739,7 @@ mp_getredirection(pTHX_ int *ac, char ***av)
 		    err = 2 + ap;
 	    if (j >= argc)
 		{
-		PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
+		fprintf(stderr,"No output file after 2> or 2>> on command line");
 		exit(LIB$_WRONUMARG);
 		}
 	    continue;
@@ -3468,7 +3748,7 @@ mp_getredirection(pTHX_ int *ac, char ***av)
 	    {
 	    if (j+1 >= argc)
 		{
-		PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
+		fprintf(stderr,"No command into which to pipe on command line");
 		exit(LIB$_WRONUMARG);
 		}
 	    cmargc = argc-(j+1);
@@ -3499,10 +3779,10 @@ mp_getredirection(pTHX_ int *ac, char ***av)
 	{
 	if (out != NULL)
 	    {
-	    PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
+	    fprintf(stderr,"'|' and '>' may not both be specified on command line");
 	    exit(LIB$_INVARGORD);
 	    }
-	pipe_and_fork(cmargv);
+	pipe_and_fork(aTHX_ cmargv);
 	}
 	
     /* Check for input from a pipe (mailbox) */
@@ -3518,7 +3798,7 @@ mp_getredirection(pTHX_ int *ac, char ***av)
 	/* Input from a pipe, reopen it in binary mode to disable	*/
 	/* carriage control processing.	 				*/
 
-	PerlIO_getname(stdin, mbxname);
+	fgetname(stdin, mbxname);
 	mbxnam.dsc$a_pointer = mbxname;
 	mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);	
 	lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
@@ -3532,35 +3812,39 @@ mp_getredirection(pTHX_ int *ac, char ***av)
 	freopen(mbxname, "rb", stdin);
 	if (errno != 0)
 	    {
-	    PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
+	    fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
 	    exit(vaxc$errno);
 	    }
 	}
     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
 	{
-	PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
+	fprintf(stderr,"Can't open input file %s as stdin",in);
 	exit(vaxc$errno);
 	}
     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
 	{	
-	PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
+	fprintf(stderr,"Can't open output file %s as stdout",out);
 	exit(vaxc$errno);
 	}
+	if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
+
     if (err != NULL) {
         if (strcmp(err,"&1") == 0) {
-            dup2(fileno(stdout), fileno(Perl_debug_log));
+            dup2(fileno(stdout), fileno(stderr));
+            Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
         } else {
 	FILE *tmperr;
 	if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
 	    {
-	    PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
+	    fprintf(stderr,"Can't open error file %s as stderr",err);
 	    exit(vaxc$errno);
 	    }
 	    fclose(tmperr);
-	    if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
+           if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
 		{
 		exit(vaxc$errno);
 		}
+	    Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
 	}
         }
 #ifdef ARGPROC_DEBUG
@@ -3731,7 +4015,7 @@ static struct exit_control_block exit_block =
     0
     };
 
-static void pipe_and_fork(char **cmargv)
+static void pipe_and_fork(pTHX_ char **cmargv)
 {
     char subcmd[2048];
     $DESCRIPTOR(cmddsc, "");
@@ -3750,7 +4034,7 @@ static void pipe_and_fork(char **cmargv)
     cmddsc.dsc$a_pointer = subcmd;
     cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
 
-	create_mbx(&child_chan,&mbxdsc);
+	create_mbx(aTHX_ &child_chan,&mbxdsc);
 #ifdef ARGPROC_DEBUG
     PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
     PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
@@ -3830,17 +4114,19 @@ 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;
+#if defined(PERL_IMPLICIT_CONTEXT)
+  pTHX = NULL;
+#endif
   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
                                  {          0,                0,    0,      0} };
 
-  _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
-  _ckvmssts(iosb[0]);
+  _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
+  _ckvmssts_noperl(iosb[0]);
   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
     if (iprv[i]) {           /* Running image installed with privs? */
-      _ckvmssts(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
+      _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
       will_taint = TRUE;
       break;
     }
@@ -3865,8 +4151,8 @@ vms_image_init(int *argcp, char ***argvp)
       if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
       jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
       jpilist[1].buflen = rsz * sizeof(unsigned long int);
-      _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
-      _ckvmssts(iosb[0]);
+      _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
+      _ckvmssts_noperl(iosb[0]);
     }
     mask = jpilist[1].bufadr;
     /* Check attribute flags for each identifier (2nd longword); protected
@@ -3922,12 +4208,12 @@ vms_image_init(int *argcp, char ***argvp)
     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
     tabvec[tabidx]->dsc$a_pointer = NULL;
-    _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
+    _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
   }
   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
 
   getredirection(argcp,argvp);
-#if defined(USE_THREADS) && defined(__DECC)
+#if defined(USE_5005THREADS) && ( defined(__DECC) || defined(__DECCXX) )
   {
 # include <reentrancy.h>
   (void) decc$set_reentrancy(C$C_MULTITHREAD);
@@ -4178,8 +4464,7 @@ closedir(DIR *dd)
  *  Collect all the version numbers for the current file.
  */
 static void
-collectversions(dd)
-    DIR *dd;
+collectversions(pTHX_ DIR *dd)
 {
     struct dsc$descriptor_s	pat;
     struct dsc$descriptor_s	res;
@@ -4187,7 +4472,6 @@ collectversions(dd)
     char *p, *text, buff[sizeof dd->entry.d_name];
     int i;
     unsigned long context, tmpsts;
-    dTHX;
 
     /* Convenient shorthand. */
     e = &dd->entry;
@@ -4234,7 +4518,7 @@ collectversions(dd)
  */
 /*{{{ struct dirent *readdir(DIR *dd)*/
 struct dirent *
-readdir(DIR *dd)
+Perl_readdir(pTHX_ DIR *dd)
 {
     struct dsc$descriptor_s	res;
     char *p, buff[sizeof dd->entry.d_name];
@@ -4279,7 +4563,7 @@ readdir(DIR *dd)
 
     dd->entry.d_namlen = strlen(dd->entry.d_name);
     dd->entry.vms_verscount = 0;
-    if (dd->vms_wantversions) collectversions(dd);
+    if (dd->vms_wantversions) collectversions(aTHX_ dd);
     return &dd->entry;
 
 }  /* end of readdir() */
@@ -4301,10 +4585,9 @@ telldir(DIR *dd)
  */
 /*{{{ void seekdir(DIR *dd,long count)*/
 void
-seekdir(DIR *dd, long count)
+Perl_seekdir(pTHX_ DIR *dd, long count)
 {
     int vms_wantversions;
-    dTHX;
 
     /* If we haven't done anything yet... */
     if (dd->count == 0)
@@ -4381,9 +4664,8 @@ vms_execfree(pTHX) {
 }
 
 static char *
-setup_argstr(SV *really, SV **mark, SV **sp)
+setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
 {
-  dTHX;
   char *junk, *tmps = Nullch;
   register size_t cmdlen = 0;
   size_t rlen;
@@ -4424,9 +4706,10 @@ setup_argstr(SV *really, SV **mark, SV **sp)
 
 }  /* end of setup_argstr() */
 
+#define MAX_DCL_LINE_LENGTH   255
 
 static unsigned long int
-setup_cmddsc(char *cmd, int check_img)
+setup_cmddsc(pTHX_ char *cmd, int check_img)
 {
   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
   $DESCRIPTOR(defdsc,".EXE");
@@ -4436,11 +4719,9 @@ setup_cmddsc(char *cmd, int check_img)
   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
   register char *s, *rest, *cp, *wordbreak;
   register int isdcl;
-  dTHX;
 
-  if (strlen(cmd) >
-      (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
-    return LIB$_INVARG;
+  if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
+    return CLI$_BUFOVF;                /* continuation lines currently unsupported */
   s = cmd;
   while (*s && isspace(*s)) s++;
 
@@ -4520,14 +4801,14 @@ setup_cmddsc(char *cmd, int check_img)
       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 ");
+            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);
-        return retsts;
+        return (VMScmd.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
       }
       else retsts = RMS$_PRV;
     }
@@ -4544,16 +4825,15 @@ setup_cmddsc(char *cmd, int check_img)
     else { _ckvmssts(retsts); }
   }
 
-  return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
+  return (VMScmd.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
 
 }  /* end of setup_cmddsc() */
 
 
 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
 bool
-vms_do_aexec(SV *really,SV **mark,SV **sp)
+Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
 {
-  dTHX;
   if (sp > mark) {
     if (vfork_called) {           /* this follows a vfork - act Unixish */
       vfork_called--;
@@ -4564,7 +4844,7 @@ vms_do_aexec(SV *really,SV **mark,SV **sp)
       else return do_aexec(really,mark,sp);
     }
                                            /* no vfork - act VMSish */
-    return vms_do_exec(setup_argstr(really,mark,sp));
+    return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
 
   }
 
@@ -4574,10 +4854,9 @@ vms_do_aexec(SV *really,SV **mark,SV **sp)
 
 /* {{{bool vms_do_exec(char *cmd) */
 bool
-vms_do_exec(char *cmd)
+Perl_vms_do_exec(pTHX_ char *cmd)
 {
 
-  dTHX;
   if (vfork_called) {             /* this follows a vfork - act Unixish */
     vfork_called--;
     if (vfork_called < 0) {
@@ -4592,7 +4871,7 @@ vms_do_exec(char *cmd)
 
     TAINT_ENV();
     TAINT_PROPER("exec");
-    if ((retsts = setup_cmddsc(cmd,1)) & 1)
+    if ((retsts = setup_cmddsc(aTHX_ cmd,1)) & 1)
       retsts = lib$do_command(&VMScmd);
 
     switch (retsts) {
@@ -4606,7 +4885,7 @@ vms_do_exec(char *cmd)
         set_errno(EACCES); break;
       case RMS$_SYN:
         set_errno(EINVAL); break;
-      case CLI$_BUFOVF:
+      case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
         set_errno(E2BIG); break;
       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
         _ckvmssts(retsts); /* fall through */
@@ -4626,14 +4905,13 @@ vms_do_exec(char *cmd)
 }  /* end of vms_do_exec() */
 /*}}}*/
 
-unsigned long int do_spawn(char *);
+unsigned long int Perl_do_spawn(pTHX_ char *);
 
 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
 unsigned long int
-do_aspawn(void *really,void **mark,void **sp)
+Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
 {
-  dTHX;
-  if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
+  if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
 
   return SS$_ABORT;
 }  /* end of do_aspawn() */
@@ -4641,10 +4919,9 @@ do_aspawn(void *really,void **mark,void **sp)
 
 /* {{{unsigned long int do_spawn(char *cmd) */
 unsigned long int
-do_spawn(char *cmd)
+Perl_do_spawn(pTHX_ char *cmd)
 {
   unsigned long int sts, substs, hadcmd = 1;
-  dTHX;
 
   TAINT_ENV();
   TAINT_PROPER("spawn");
@@ -4652,8 +4929,13 @@ do_spawn(char *cmd)
     hadcmd = 0;
     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
   }
-  else if ((sts = setup_cmddsc(cmd,0)) & 1) {
-    sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
+  else {
+    sts = setup_cmddsc(aTHX_ cmd,0);
+    if (sts & 1) {
+        sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
+    } else {
+        substs = sts; /* didn't spawn, use command setup failure for return */
+    }
   }
   
   if (!(sts & 1)) {
@@ -4668,7 +4950,7 @@ do_spawn(char *cmd)
         set_errno(EACCES); break;
       case RMS$_SYN:
         set_errno(EINVAL); break;
-      case CLI$_BUFOVF:
+      case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
         set_errno(E2BIG); break;
       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
         _ckvmssts(sts); /* fall through */
@@ -4689,34 +4971,106 @@ do_spawn(char *cmd)
 }  /* end of do_spawn() */
 /*}}}*/
 
+
+static unsigned int *sockflags, sockflagsize;
+
+/*
+ * Shim fdopen to identify sockets for my_fwrite later, since the stdio
+ * routines found in some versions of the CRTL can't deal with sockets.
+ * We don't shim the other file open routines since a socket isn't
+ * likely to be opened by a name.
+ */
+/*{{{ FILE *my_fdopen(int fd, const char *mode)*/
+FILE *my_fdopen(int fd, const char *mode)
+{
+  FILE *fp = fdopen(fd, (char *) mode);
+
+  if (fp) {
+    unsigned int fdoff = fd / sizeof(unsigned int);
+    struct stat sbuf; /* native stat; we don't need flex_stat */
+    if (!sockflagsize || fdoff > sockflagsize) {
+      if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
+      else           New  (1324,sockflags,fdoff+2,unsigned int);
+      memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
+      sockflagsize = fdoff + 2;
+    }
+    if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
+      sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
+  }
+  return fp;
+
+}
+/*}}}*/
+
+
+/*
+ * Clear the corresponding bit when the (possibly) socket stream is closed.
+ * There still a small hole: we miss an implicit close which might occur
+ * via freopen().  >> Todo
+ */
+/*{{{ int my_fclose(FILE *fp)*/
+int my_fclose(FILE *fp) {
+  if (fp) {
+    unsigned int fd = fileno(fp);
+    unsigned int fdoff = fd / sizeof(unsigned int);
+
+    if (sockflagsize && fdoff <= sockflagsize)
+      sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
+  }
+  return fclose(fp);
+}
+/*}}}*/
+
+
 /* 
  * A simple fwrite replacement which outputs itmsz*nitm chars without
  * introducing record boundaries every itmsz chars.
+ * We are using fputs, which depends on a terminating null.  We may
+ * well be writing binary data, so we need to accommodate not only
+ * data with nulls sprinkled in the middle but also data with no null 
+ * byte at the end.
  */
-/*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
+/*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
 int
-my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
+my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
 {
-  register char *cp, *end;
+  register char *cp, *end, *cpd, *data;
+  register unsigned int fd = fileno(dest);
+  register unsigned int fdoff = fd / sizeof(unsigned int);
+  int retval;
+  int bufsize = itmsz * nitm + 1;
+
+  if (fdoff < sockflagsize &&
+      (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
+    if (write(fd, src, itmsz * nitm) == EOF) return EOF;
+    return nitm;
+  }
+
+  _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
+  memcpy( data, src, itmsz*nitm );
+  data[itmsz*nitm] = '\0';
 
-  end = (char *)src + itmsz * nitm;
+  end = data + itmsz * nitm;
+  retval = (int) nitm; /* on success return # items written */
 
-  while ((char *)src <= end) {
-    for (cp = src; cp <= end; cp++) if (!*cp) break;
-    if (fputs(src,dest) == EOF) return EOF;
+  cpd = data;
+  while (cpd <= end) {
+    for (cp = cpd; cp <= end; cp++) if (!*cp) break;
+    if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
     if (cp < end)
-      if (fputc('\0',dest) == EOF) return EOF;
-    src = cp + 1;
+      if (fputc('\0',dest) == EOF) { retval = EOF; break; }
+    cpd = cp + 1;
   }
 
-  return nitm;
+  if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
+  return retval;
 
 }  /* end of my_fwrite() */
 /*}}}*/
 
 /*{{{ int my_flush(FILE *fp)*/
 int
-my_flush(FILE *fp)
+Perl_my_flush(pTHX_ FILE *fp)
 {
     int res;
     if ((res = fflush(fp)) == 0 && fp) {
@@ -4726,6 +5080,13 @@ my_flush(FILE *fp)
 #endif
 	    res = fsync(fileno(fp));
     }
+/*
+ * If the flush succeeded but set end-of-file, we need to clear
+ * the error because our caller may check ferror().  BTW, this 
+ * probably means we just flushed an empty file.
+ */
+    if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
+
     return res;
 }
 /*}}}*/
@@ -4790,9 +5151,8 @@ static char __pw_namecache[UAI$S_IDENT+1];
 /*
  * This routine does most of the work extracting the user information.
  */
-static int fillpasswd (const char *name, struct passwd *pwd)
+static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
 {
-    dTHX;
     static struct {
         unsigned char length;
         char pw_gecos[UAI$S_OWNER+1];
@@ -4872,15 +5232,14 @@ static int fillpasswd (const char *name, struct passwd *pwd)
  * Get information for a named user.
 */
 /*{{{struct passwd *getpwnam(char *name)*/
-struct passwd *my_getpwnam(char *name)
+struct passwd *Perl_my_getpwnam(pTHX_ char *name)
 {
     struct dsc$descriptor_s name_desc;
     union uicdef uic;
     unsigned long int status, sts;
-    dTHX;
                                   
     __pwdcache = __passwd_empty;
-    if (!fillpasswd(name, &__pwdcache)) {
+    if (!fillpasswd(aTHX_ name, &__pwdcache)) {
       /* We still may be able to determine pw_uid and pw_gid */
       name_desc.dsc$w_length=  strlen(name);
       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
@@ -4911,13 +5270,12 @@ struct passwd *my_getpwnam(char *name)
  * Called by my_getpwent with uid=-1 to list all users.
 */
 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
-struct passwd *my_getpwuid(Uid_t uid)
+struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
 {
     const $DESCRIPTOR(name_desc,__pw_namecache);
     unsigned short lname;
     union uicdef uic;
     unsigned long int status;
-    dTHX;
 
     if (uid == (unsigned int) -1) {
       do {
@@ -4957,7 +5315,7 @@ struct passwd *my_getpwuid(Uid_t uid)
     __pwdcache.pw_uid =  uic.uic$l_uic;
     __pwdcache.pw_gid =  uic.uic$v_group;
 
-    fillpasswd(__pw_namecache, &__pwdcache);
+    fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
     return &__pwdcache;
 
 }  /* end of my_getpwuid() */
@@ -4967,7 +5325,7 @@ struct passwd *my_getpwuid(Uid_t uid)
  * Get information for next user.
 */
 /*{{{struct passwd *my_getpwent()*/
-struct passwd *my_getpwent()
+struct passwd *Perl_my_getpwent(pTHX)
 {
     return (my_getpwuid((unsigned int) -1));
 }
@@ -4977,9 +5335,8 @@ struct passwd *my_getpwent()
  * Finish searching rights database for users.
 */
 /*{{{void my_endpwent()*/
-void my_endpwent()
+void Perl_my_endpwent(pTHX)
 {
-    dTHX;
     if (contxt) {
       _ckvmssts(sys$finish_rdb(&contxt));
       contxt= 0;
@@ -5105,9 +5462,6 @@ static long int utc_offset_secs;
 #undef localtime
 #undef time
 
-#if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
-#  define RTL_USES_UTC 1
-#endif
 
 /*
  * DEC C previous to 6.0 corrupts the behavior of the /prefix
@@ -5156,6 +5510,289 @@ static time_t toloc_dst(time_t utc) {
        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
        ((secs) + utc_offset_secs))))
 
+#ifndef RTL_USES_UTC
+/*
+  
+    ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical 
+        DST starts on 1st sun of april      at 02:00  std time
+            ends on last sun of october     at 02:00  dst time
+    see the UCX management command reference, SET CONFIG TIMEZONE
+    for formatting info.
+
+    No, it's not as general as it should be, but then again, NOTHING
+    will handle UK times in a sensible way. 
+*/
+
+
+/* 
+    parse the DST start/end info:
+    (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
+*/
+
+static char *
+tz_parse_startend(char *s, struct tm *w, int *past)
+{
+    int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
+    int ly, dozjd, d, m, n, hour, min, sec, j, k;
+    time_t g;
+
+    if (!s)    return 0;
+    if (!w) return 0;
+    if (!past) return 0;
+
+    ly = 0;
+    if (w->tm_year % 4        == 0) ly = 1;
+    if (w->tm_year % 100      == 0) ly = 0;
+    if (w->tm_year+1900 % 400 == 0) ly = 1;
+    if (ly) dinm[1]++;
+
+    dozjd = isdigit(*s);
+    if (*s == 'J' || *s == 'j' || dozjd) {
+        if (!dozjd && !isdigit(*++s)) return 0;
+        d = *s++ - '0';
+        if (isdigit(*s)) {
+            d = d*10 + *s++ - '0';
+            if (isdigit(*s)) {
+                d = d*10 + *s++ - '0';
+            }
+        }
+        if (d == 0) return 0;
+        if (d > 366) return 0;
+        d--;
+        if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
+        g = d * 86400;
+        dozjd = 1;
+    } else if (*s == 'M' || *s == 'm') {
+        if (!isdigit(*++s)) return 0;
+        m = *s++ - '0';
+        if (isdigit(*s)) m = 10*m + *s++ - '0';
+        if (*s != '.') return 0;
+        if (!isdigit(*++s)) return 0;
+        n = *s++ - '0';
+        if (n < 1 || n > 5) return 0;
+        if (*s != '.') return 0;
+        if (!isdigit(*++s)) return 0;
+        d = *s++ - '0';
+        if (d > 6) return 0;
+    }
+
+    if (*s == '/') {
+        if (!isdigit(*++s)) return 0;
+        hour = *s++ - '0';
+        if (isdigit(*s)) hour = 10*hour + *s++ - '0';
+        if (*s == ':') {
+            if (!isdigit(*++s)) return 0;
+            min = *s++ - '0';
+            if (isdigit(*s)) min = 10*min + *s++ - '0';
+            if (*s == ':') {
+                if (!isdigit(*++s)) return 0;
+                sec = *s++ - '0';
+                if (isdigit(*s)) sec = 10*sec + *s++ - '0';
+            }
+        }
+    } else {
+        hour = 2;
+        min = 0;
+        sec = 0;
+    }
+
+    if (dozjd) {
+        if (w->tm_yday < d) goto before;
+        if (w->tm_yday > d) goto after;
+    } else {
+        if (w->tm_mon+1 < m) goto before;
+        if (w->tm_mon+1 > m) goto after;
+
+        j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
+        k = d - j; /* mday of first d */
+        if (k <= 0) k += 7;
+        k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
+        if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
+        if (w->tm_mday < k) goto before;
+        if (w->tm_mday > k) goto after;
+    }
+
+    if (w->tm_hour < hour) goto before;
+    if (w->tm_hour > hour) goto after;
+    if (w->tm_min  < min)  goto before;
+    if (w->tm_min  > min)  goto after;
+    if (w->tm_sec  < sec)  goto before;
+    goto after;
+
+before:
+    *past = 0;
+    return s;
+after:
+    *past = 1;
+    return s;
+}
+
+
+
+
+/*  parse the offset:   (+|-)hh[:mm[:ss]]  */
+
+static char *
+tz_parse_offset(char *s, int *offset)
+{
+    int hour = 0, min = 0, sec = 0;
+    int neg = 0;
+    if (!s) return 0;
+    if (!offset) return 0;
+
+    if (*s == '-') {neg++; s++;}
+    if (*s == '+') s++;
+    if (!isdigit(*s)) return 0;
+    hour = *s++ - '0';
+    if (isdigit(*s)) hour = hour*10+(*s++ - '0');
+    if (hour > 24) return 0;
+    if (*s == ':') {
+        if (!isdigit(*++s)) return 0;
+        min = *s++ - '0';
+        if (isdigit(*s)) min = min*10 + (*s++ - '0');
+        if (min > 59) return 0;
+        if (*s == ':') {
+            if (!isdigit(*++s)) return 0;
+            sec = *s++ - '0';
+            if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
+            if (sec > 59) return 0;
+        }
+    }
+
+    *offset = (hour*60+min)*60 + sec;
+    if (neg) *offset = -*offset;
+    return s;
+}
+
+/*
+    input time is w, whatever type of time the CRTL localtime() uses.
+    sets dst, the zone, and the gmtoff (seconds)
+
+    caches the value of TZ and UCX$TZ env variables; note that 
+    my_setenv looks for these and sets a flag if they're changed
+    for efficiency. 
+
+    We have to watch out for the "australian" case (dst starts in
+    october, ends in april)...flagged by "reverse" and checked by
+    scanning through the months of the previous year.
+
+*/
+
+static int
+tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
+{
+    time_t when;
+    struct tm *w2;
+    char *s,*s2;
+    char *dstzone, *tz, *s_start, *s_end;
+    int std_off, dst_off, isdst;
+    int y, dststart, dstend;
+    static char envtz[1025];  /* longer than any logical, symbol, ... */
+    static char ucxtz[1025];
+    static char reversed = 0;
+
+    if (!w) return 0;
+
+    if (tz_updated) {
+        tz_updated = 0;
+        reversed = -1;  /* flag need to check  */
+        envtz[0] = ucxtz[0] = '\0';
+        tz = my_getenv("TZ",0);
+        if (tz) strcpy(envtz, tz);
+        tz = my_getenv("UCX$TZ",0);
+        if (tz) strcpy(ucxtz, tz);
+        if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
+    }
+    tz = envtz;
+    if (!*tz) tz = ucxtz;
+
+    s = tz;
+    while (isalpha(*s)) s++;
+    s = tz_parse_offset(s, &std_off);
+    if (!s) return 0;
+    if (!*s) {                  /* no DST, hurray we're done! */
+        isdst = 0;
+        goto done;
+    }
+
+    dstzone = s;
+    while (isalpha(*s)) s++;
+    s2 = tz_parse_offset(s, &dst_off);
+    if (s2) {
+        s = s2;
+    } else {
+        dst_off = std_off - 3600;
+    }
+
+    if (!*s) {      /* default dst start/end?? */
+        if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
+            s = strchr(ucxtz,',');
+        }
+        if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
+    }
+    if (*s != ',') return 0;
+
+    when = *w;
+    when = _toutc(when);      /* convert to utc */
+    when = when - std_off;    /* convert to pseudolocal time*/
+
+    w2 = localtime(&when);
+    y = w2->tm_year;
+    s_start = s+1;
+    s = tz_parse_startend(s_start,w2,&dststart);
+    if (!s) return 0;
+    if (*s != ',') return 0;
+
+    when = *w;
+    when = _toutc(when);      /* convert to utc */
+    when = when - dst_off;    /* convert to pseudolocal time*/
+    w2 = localtime(&when);
+    if (w2->tm_year != y) {   /* spans a year, just check one time */
+        when += dst_off - std_off;
+        w2 = localtime(&when);
+    }
+    s_end = s+1;
+    s = tz_parse_startend(s_end,w2,&dstend);
+    if (!s) return 0;
+
+    if (reversed == -1) {  /* need to check if start later than end */
+        int j, ds, de;
+
+        when = *w;
+        if (when < 2*365*86400) {
+            when += 2*365*86400;
+        } else {
+            when -= 365*86400;
+        }
+        w2 =localtime(&when);
+        when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
+
+        for (j = 0; j < 12; j++) {
+            w2 =localtime(&when);
+            (void) tz_parse_startend(s_start,w2,&ds);
+            (void) tz_parse_startend(s_end,w2,&de);
+            if (ds != de) break;
+            when += 30*86400;
+        }
+        reversed = 0;
+        if (de && !ds) reversed = 1;
+    }
+
+    isdst = dststart && !dstend;
+    if (reversed) isdst = dststart  || !dstend;
+
+done:
+    if (dst)    *dst = isdst;
+    if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
+    if (isdst)  tz = dstzone;
+    if (zone) {
+        while(isalpha(*tz))  *zone++ = *tz++;
+        *zone = '\0';
+    }
+    return 1;
+}
+
+#endif /* !RTL_USES_UTC */
 
 /* my_time(), my_localtime(), my_gmtime()
  * By default traffic in UTC time values, using CRTL gmtime() or
@@ -5168,9 +5805,8 @@ static time_t toloc_dst(time_t utc) {
  */
 
 /*{{{time_t my_time(time_t *timep)*/
-time_t my_time(time_t *timep)
+time_t Perl_my_time(pTHX_ time_t *timep)
 {
-  dTHX;
   time_t when;
   struct tm *tm_p;
 
@@ -5187,6 +5823,7 @@ time_t my_time(time_t *timep)
       gmtime_emulation_type++;
       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
         gmtime_emulation_type++;
+        utc_offset_secs = 0;
         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
       }
       else { utc_offset_secs = atol(off); }
@@ -5221,9 +5858,8 @@ time_t my_time(time_t *timep)
 
 /*{{{struct tm *my_gmtime(const time_t *timep)*/
 struct tm *
-my_gmtime(const time_t *timep)
+Perl_my_gmtime(pTHX_ const time_t *timep)
 {
-  dTHX;
   char *p;
   time_t when;
   struct tm *rsltmp;
@@ -5252,11 +5888,11 @@ my_gmtime(const time_t *timep)
 
 /*{{{struct tm *my_localtime(const time_t *timep)*/
 struct tm *
-my_localtime(const time_t *timep)
+Perl_my_localtime(pTHX_ const time_t *timep)
 {
-  dTHX;
-  time_t when;
+  time_t when, whenutc;
   struct tm *rsltmp;
+  int dst, offset;
 
   if (timep == NULL) {
     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
@@ -5272,15 +5908,24 @@ my_localtime(const time_t *timep)
 # endif
   /* CRTL localtime() wants UTC as input, does tz correction itself */
   return localtime(&when);
-# else
+  
+# else /* !RTL_USES_UTC */
+  whenutc = when;
 # ifdef VMSISH_TIME
-  if (!VMSISH_TIME) when = _toloc(when);   /*  Input was UTC */
+  if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
+  if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
 # endif
+  dst = -1;
+#ifndef RTL_USES_UTC
+  if (tz_parse(&when, &dst, 0, &offset)) {   /* truelocal determines DST*/
+      when = whenutc - offset;                   /* pseudolocal time*/
+  }
 # endif
   /* CRTL localtime() wants local time as input, so does no tz correction */
   rsltmp = localtime(&when);
-  if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
+  if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
   return rsltmp;
+# endif
 
 } /*  end of my_localtime() */
 /*}}}*/
@@ -5309,9 +5954,8 @@ my_localtime(const time_t *timep)
 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)
+int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
 {
-  dTHX;
   register int i;
   long int bintime[2], len = 2, lowbit, unixtime,
            secscale = 10000000; /* seconds --> 100 ns intervals */
@@ -5432,7 +6076,7 @@ int my_utime(char *file, struct utimbuf *utimes)
   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
 
   memset((void *) &myfib, 0, sizeof myfib);
-#ifdef __DECC
+#if defined(__DECC) || defined(__DECCXX)
   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
   /* This prevents the revision time of the file being reset to the current
@@ -5494,14 +6138,13 @@ int my_utime(char *file, struct utimbuf *utimes)
  * on the first call.
  */
 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
-static mydev_t encode_dev (const char *dev)
+static mydev_t encode_dev (pTHX_ const char *dev)
 {
   int i;
   unsigned long int f;
   mydev_t enc;
   char c;
   const char *q;
-  dTHX;
 
   if (!dev || !dev[0]) return 0;
 
@@ -5547,7 +6190,6 @@ 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
@@ -5569,6 +6211,7 @@ is_null_device(name)
 bool
 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
 {
+  char fname_phdev[NAM$C_MAXRSS+1];
   if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
   else {
     char fname[NAM$C_MAXRSS+1];
@@ -5587,7 +6230,15 @@ Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
                              &namdsc,&namdsc.dsc$w_length,0,0);
     if (retsts & 1) {
       fname[namdsc.dsc$w_length] = '\0';
-      return cando_by_name(bit,effective,fname);
+/* 
+ * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
+ * but if someone has redefined that logical, Perl gets very lost.  Since
+ * we have the physical device name from the stat buffer, just paste it on.
+ */
+      strcpy( fname_phdev, statbufp->st_devnam );
+      strcat( fname_phdev, strrchr(fname, ':') );
+
+      return cando_by_name(bit,effective,fname_phdev);
     }
     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
       Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
@@ -5602,7 +6253,7 @@ Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
 
 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
 I32
-cando_by_name(I32 bit, Uid_t effective, char *fname)
+Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
 {
   static char usrname[L_cuserid];
   static struct dsc$descriptor_s usrdsc =
@@ -5610,7 +6261,6 @@ cando_by_name(I32 bit, Uid_t 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},
@@ -5656,7 +6306,7 @@ cando_by_name(I32 bit, Uid_t effective, char *fname)
   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
-      retsts == RMS$_DIR        || retsts == RMS$_DEV) {
+      retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
     set_vaxc_errno(retsts);
     if (retsts == SS$_NOPRIV) set_errno(EACCES);
     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
@@ -5679,12 +6329,6 @@ 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 */
@@ -5695,12 +6339,11 @@ cando_by_name(I32 bit, Uid_t effective, char *fname)
 
 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
 int
-flex_fstat(int fd, Stat_t *statbufp)
+Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
 {
-  dTHX;
   if (!fstat(fd,(stat_t *) statbufp)) {
     if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
-    statbufp->st_dev = encode_dev(statbufp->st_devnam);
+    statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
 #   ifdef RTL_USES_UTC
 #   ifdef VMSISH_TIME
     if (VMSISH_TIME) {
@@ -5729,19 +6372,19 @@ flex_fstat(int fd, Stat_t *statbufp)
 
 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
 int
-flex_stat(const char *fspec, Stat_t *statbufp)
+Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
 {
-    dTHX;
     char fileified[NAM$C_MAXRSS+1];
     char temp_fspec[NAM$C_MAXRSS+300];
     int retval = -1;
 
+    if (!fspec) return retval;
     strcpy(temp_fspec, fspec);
     if (statbufp == (Stat_t *) &PL_statcache)
       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_dev = encode_dev(aTHX_ "_NLA0:");
       statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
       statbufp->st_uid = 0x00010001;
       statbufp->st_gid = 0x0001;
@@ -5765,7 +6408,7 @@ flex_stat(const char *fspec, Stat_t *statbufp)
     }
     if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
     if (!retval) {
-      statbufp->st_dev = encode_dev(statbufp->st_devnam);
+      statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
 #     ifdef RTL_USES_UTC
 #     ifdef VMSISH_TIME
       if (VMSISH_TIME) {
@@ -6118,7 +6761,7 @@ candelete_fromperl(pTHX_ CV *cv)
 
   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
   if (SvTYPE(mysv) == SVt_PVGV) {
-    if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
+    if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
       ST(0) = &PL_sv_no;
       XSRETURN(1);
@@ -6155,7 +6798,7 @@ rmscopy_fromperl(pTHX_ CV *cv)
 
   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
   if (SvTYPE(mysv) == SVt_PVGV) {
-    if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
+    if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
       ST(0) = &PL_sv_no;
       XSRETURN(1);
@@ -6171,7 +6814,7 @@ rmscopy_fromperl(pTHX_ CV *cv)
   }
   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
   if (SvTYPE(mysv) == SVt_PVGV) {
-    if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
+    if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
       ST(0) = &PL_sv_no;
       XSRETURN(1);
@@ -6193,7 +6836,7 @@ rmscopy_fromperl(pTHX_ CV *cv)
 
 
 void
-mod2fname(CV *cv)
+mod2fname(pTHX_ CV *cv)
 {
   dXSARGS;
   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
@@ -6268,10 +6911,48 @@ mod2fname(CV *cv)
 }
 
 void
+hushexit_fromperl(pTHX_ CV *cv)
+{
+    dXSARGS;
+
+    if (items > 0) {
+        VMSISH_HUSHED = SvTRUE(ST(0));
+    }
+    ST(0) = boolSV(VMSISH_HUSHED);
+    XSRETURN(1);
+}
+
+void  
+Perl_sys_intern_dup(pTHX_ struct interp_intern *src, 
+                          struct interp_intern *dst)
+{
+    memcpy(dst,src,sizeof(struct interp_intern));
+}
+
+void  
+Perl_sys_intern_clear(pTHX)
+{
+}
+
+void  
+Perl_sys_intern_init(pTHX)
+{
+    int ix = RAND_MAX;
+    float x;
+
+    VMSISH_HUSHED = 0;
+
+    x = (float)ix;
+    MY_INV_RAND_MAX = 1./x;
+}
+
+
+
+void
 init_os_extras()
 {
-  char* file = __FILE__;
   dTHX;
+  char* file = __FILE__;
   char temp_buff[512];
   if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
     no_translate_barewords = TRUE;
@@ -6289,8 +6970,9 @@ init_os_extras()
   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
+  newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
 
-  store_pipelocs();
+  store_pipelocs(aTHX);
 
   return;
 }