Close VMS security hole

p4raw-id: //depot/perl@857

diff --git a/vms/vms.c b/vms/vms.c
index f57762e..5879f7f 100644 (file)
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -11,6 +11,7 @@
 #include <armdef.h>
 #include <atrdef.h>
 #include <chpdef.h>
+#include <clidef.h>
 #include <climsgdef.h>
 #include <descrip.h>
 #include <dvidef.h>
@@ -174,7 +175,9 @@ my_getenv(char *lnm)
 }  /* end of my_getenv() */
 /*}}}*/
 
-static FILE *safe_popen(char *, char *);
+static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
+
+static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
 
 /*{{{ void prime_env_iter() */
 void
@@ -186,10 +189,19 @@ prime_env_iter(void)
   dTHR;
   static int primed = 0;
   HV *envhv = GvHVn(envgv);
-  FILE *sholog;
-  char eqv[LNM$C_NAMLENGTH+1],*start,*end;
+  PerlIO *sholog;
+  char eqv[LNM$C_NAMLENGTH+1],mbxnam[LNM$C_NAMLENGTH+1],*start,*end;
+  unsigned short int chan;
+#ifndef CLI$M_TRUSTED
+#  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
+#endif
+  unsigned long int flags = CLI$M_NOWAIT | CLI$M_NOCLISYM | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
+  unsigned long int retsts, substs = 0, wakect = 0;
   STRLEN eqvlen;
   SV *oldrs, *linesv, *eqvsv;
+  $DESCRIPTOR(cmddsc,"Show Logical *"); $DESCRIPTOR(nldsc,"_NLA0:");
+  $DESCRIPTOR(clidsc,"DCL");            $DESCRIPTOR(tabdsc,"DCLTABLES");
+  $DESCRIPTOR(mbxdsc,mbxnam); 
 #ifdef USE_THREADS
   static perl_mutex primenv_mutex = PTHREAD_MUTEX_INITIALIZER;
 #endif
@@ -198,7 +210,7 @@ prime_env_iter(void)
   MUTEX_LOCK(&primenv_mutex);
   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
   /* Perform a dummy fetch as an lval to insure that the hash table is
-   * set up.  Otherwise, the hv_store() will turn into a nullop */
+   * set up.  Otherwise, the hv_store() will turn into a nullop. */
   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
   /* Also, set up the four "special" keys that the CRTL defines,
    * whether or not underlying logical names exist. */
@@ -208,20 +220,39 @@ prime_env_iter(void)
   (void) hv_fetch(envhv,"USER",4,TRUE);
 
   /* Now, go get the logical names */
-  if ((sholog = safe_popen("$ Show Logical *","r")) == Nullfp) {
+  create_mbx(&chan,&mbxdsc);
+  if ((sholog = PerlIO_open(mbxnam,"r")) != Nullfp) {
+    if ((retsts = sys$dassgn(chan)) & 1) {
+      /* Be certain that subprocess is using the CLI and command tables we
+       * expect, and don't pass symbols through so that we insure that
+       * "Show Logical" can't be subverted.
+       */
+      do {
+        retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,0,&substs,
+                           0,&riseandshine,0,0,&clidsc,&tabdsc);
+        flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
+      } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
+    }
+  }
+  if (sholog == Nullfp || !(retsts & 1)) {
+    if (sholog != Nullfp) PerlIO_close(sholog);
     MUTEX_UNLOCK(&primenv_mutex);
-    _ckvmssts(vaxc$errno);
+    _ckvmssts(sholog == Nullfp ? vaxc$errno : retsts);
   }
-  /* We use Perl's sv_gets to read from the pipe, since safe_popen is
+  /* We use Perl's sv_gets to read from the pipe, since PerlIO_open is
    * tied to Perl's I/O layer, so it may not return a simple FILE * */
   oldrs = rs;
   rs = newSVpv("\n",1);
   linesv = newSVpv("",0);
   while (1) {
     if ((start = sv_gets(linesv,sholog,0)) == Nullch) {
-      my_pclose(sholog);
+      PerlIO_close(sholog);
       SvREFCNT_dec(linesv); SvREFCNT_dec(rs); rs = oldrs;
       primed = 1;
+      /* Wait for subprocess to clean up (we know subproc won't return 0) */
+      while (substs == 0) { sys$hiber(); wakect++;}
+      if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
+      _ckvmssts(substs);
       MUTEX_UNLOCK(&primenv_mutex);
       return;
     }
@@ -578,7 +609,7 @@ popen_completion_ast(struct pipe_details *thispipe)
   }
 }
 
-static FILE *
+static PerlIO *
 safe_popen(char *cmd, char *mode)
 {
     static int handler_set_up = FALSE;