Bypass PERL_INC_VERSION_LIST until we support in in Configure.Com

[p5sagit/p5-mst-13.2.git] / vms / vms.c

diff --git a/vms/vms.c b/vms/vms.c
index c80de00..a498e16 100644 (file)
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -2,7 +2,7 @@
  *
  * VMS-specific routines for perl5
  *
- * Last revised: 24-Feb-2000 by Charles Bailey  bailey@newman.upenn.edu
+ * Last revised: 20-Aug-1999 by Charles Bailey  bailey@newman.upenn.edu
  * Version: 5.5.60
  */
 
@@ -273,6 +273,8 @@ Perl_my_getenv(pTHX_ const char *lnm, bool sys)
         idx = strtoul(cp2+1,NULL,0);
         lnm = uplnm;
       }
+      /* Impose security constraints only if tainting */
+      if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
       if (vmstrnenv(lnm,eqv,idx,
                     sys ? fildev : NULL,
 #ifdef SECURE_INTERNAL_GETENV
@@ -319,6 +321,8 @@ my_getenv_len(const char *lnm, unsigned long *len, bool sys)
         idx = strtoul(cp2+1,NULL,0);
         lnm = buf;
       }
+      /* Impose security constraints only if tainting */
+      if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
       if ((*len = vmstrnenv(lnm,buf,idx,
                            sys ? fildev : NULL,
 #ifdef SECURE_INTERNAL_GETENV
@@ -612,6 +616,12 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
         }
         else {
           if (!*eqv) eqvdsc.dsc$w_length = 1;
+         if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
+           eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
+           if (ckWARN(WARN_MISC)) {
+             Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
+           }
+         }
           retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
         }
       }
@@ -977,7 +987,10 @@ pipe_exit_routine()
     info = open_pipes;
 
     while (info) {
-      if (info->mode != 'r' && !info->done) {
+      _ckvmssts(SYS$SETAST(0));
+      need_eof = info->mode != 'r' && !info->done;
+      _ckvmssts(SYS$SETAST(1));
+      if (need_eof) {
         if (pipe_eof(info->fp, 1) & 1) did_stuff = 1;
       }
       info = info->next;
@@ -987,22 +1000,26 @@ pipe_exit_routine()
     did_stuff = 0;
     info = open_pipes;
     while (info) {
+      _ckvmssts(SYS$SETAST(0));
       if (!info->done) { /* Tap them gently on the shoulder . . .*/
         sts = sys$forcex(&info->pid,0,&abort);
         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts); 
         did_stuff = 1;
       }
+      _ckvmssts(SYS$SETAST(1));
       info = info->next;
     }
     if (did_stuff) sleep(1);    /* wait for them to respond */
 
     info = open_pipes;
     while (info) {
+      _ckvmssts(SYS$SETAST(0));
       if (!info->done) {  /* We tried to be nice . . . */
         sts = sys$delprc(&info->pid,0);
         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts); 
         info->done = 1; /* so my_pclose doesn't try to write EOF */
       }
+      _ckvmssts(SYS$SETAST(1));
       info = info->next;
     }
 
@@ -1106,6 +1123,7 @@ I32 Perl_my_pclose(pTHX_ FILE *fp)
 {
     struct pipe_details *info, *last = NULL;
     unsigned long int retsts;
+    int need_eof;
     
     for (info = open_pipes; info != NULL; last = info, info = info->next)
         if (info->fp == fp) break;
@@ -1119,15 +1137,20 @@ I32 Perl_my_pclose(pTHX_ FILE *fp)
     /* If we were writing to a subprocess, insure that someone reading from
      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
      * produce an EOF record in the mailbox.  */
-    if (info->mode != 'r' && !info->done) pipe_eof(info->fp,0);
+    _ckvmssts(SYS$SETAST(0));
+    need_eof = info->mode != 'r' && !info->done;
+    _ckvmssts(SYS$SETAST(1));
+    if (need_eof) pipe_eof(info->fp,0);
     PerlIO_close(info->fp);
 
     if (info->done) retsts = info->completion;
     else waitpid(info->pid,(int *) &retsts,0);
 
     /* remove from list of open pipes */
+    _ckvmssts(SYS$SETAST(0));
     if (last) last->next = info->next;
     else open_pipes = info->next;
+    _ckvmssts(SYS$SETAST(1));
     Safefree(info);
 
     return retsts;
@@ -1592,13 +1615,14 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
           /* Yes; fake the fnb bits so we'll check type below */
           dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
         }
-        else {
-          if (dirfab.fab$l_sts != RMS$_FNF) {
-            set_errno(EVMSERR);
-            set_vaxc_errno(dirfab.fab$l_sts);
+        else { /* No; just work with potential name */
+          if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
+          else { 
+            set_errno(EVMSERR);  set_vaxc_errno(dirfab.fab$l_sts);
+            dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
+            dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
             return NULL;
           }
-          dirnam = savnam; /* No; just work with potential name */
         }
       }
       if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
@@ -1614,6 +1638,8 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) { 
           /* Something other than .DIR[;1].  Bzzt. */
+          dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
+          dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
           set_errno(ENOTDIR);
           set_vaxc_errno(RMS$_DIR);
           return NULL;
@@ -1626,6 +1652,8 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
         else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
         else retspec = __fileify_retbuf;
         strcpy(retspec,esa);
+        dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
+        dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
         return retspec;
       }
       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
@@ -1634,7 +1662,11 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
         dirnam.nam$b_esl -= 9;
       }
       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
-      if (cp1 == NULL) return NULL; /* should never happen */
+      if (cp1 == NULL) { /* should never happen */
+        dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
+        dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
+        return NULL;
+      }
       term = *cp1;
       *cp1 = '\0';
       retlen = strlen(esa);
@@ -1651,6 +1683,8 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
           /* Go back and expand rooted logical name */
           dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
           if (!(sys$parse(&dirfab) & 1)) {
+            dirnam.nam$l_rlf = NULL;
+            dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
             set_errno(EVMSERR);
             set_vaxc_errno(dirfab.fab$l_sts);
             return NULL;
@@ -1695,6 +1729,8 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
           strcpy(cp2+9,cp1);
         }
       }
+      dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
+      dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
       /* We've set up the string up through the filename.  Add the
          type and version, and we're done. */
       strcat(retspec,".DIR;1");
@@ -1847,6 +1883,8 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts)
         savnam = dirnam;
         if (!(sys$search(&dirfab)&1)) {  /* Does the file really exist? */
           if (dirfab.fab$l_sts != RMS$_FNF) {
+            dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
+            dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
             set_errno(EVMSERR);
             set_vaxc_errno(dirfab.fab$l_sts);
             return NULL;
@@ -1859,6 +1897,8 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts)
         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) { 
           /* Something other than .DIR[;1].  Bzzt. */
+          dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
+          dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
           set_errno(ENOTDIR);
           set_vaxc_errno(RMS$_DIR);
           return NULL;
@@ -1878,6 +1918,8 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts)
       else if (ts) New(1314,retpath,retlen,char);
       else retpath = __pathify_retbuf;
       strcpy(retpath,esa);
+      dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
+      dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
       /* $PARSE may have upcased filespec, so convert output to lower
        * case if input contained any lowercase characters. */
       if (haslower) __mystrtolower(retpath);
@@ -2117,16 +2159,12 @@ 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')) {
-        if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
+      else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) { /* handle "../" */
+        if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; 
         else if (*(cp1-2) == '[') *(cp1-1) = '-';
-        else {  /* back up over previous directory name */
-          cp1--;
-          while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
-          if (*(cp1-1) == '[') {
-            memcpy(cp1,"000000.",7);
-            cp1 += 7;
-          }
+        else {
+/*          if (*(cp1-1) != '.') *(cp1++) = '.'; */
+          *(cp1++) = '-';
         }
         cp2 += 2;
         if (cp2 == dirend) break;
@@ -4247,7 +4285,7 @@ int my_utime(char *file, struct utimbuf *utimes)
     /* If input was UTC; convert to local for sys svc */
     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
 #   endif
-    unixtime >> 1;  secscale << 1;
+    unixtime >>= 1;  secscale <<= 1;
     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
     if (!(retsts & 1)) {
       set_errno(EVMSERR);
@@ -4293,6 +4331,8 @@ int my_utime(char *file, struct utimbuf *utimes)
   }
   retsts = sys$search(&myfab,0,0);
   if (!(retsts & 1)) {
+    mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
+    myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
     set_vaxc_errno(retsts);
     if      (retsts == RMS$_PRV) set_errno(EACCES);
     else if (retsts == RMS$_FNF) set_errno(ENOENT);
@@ -4305,6 +4345,8 @@ int my_utime(char *file, struct utimbuf *utimes)
 
   retsts = sys$assign(&devdsc,&chan,0,0);
   if (!(retsts & 1)) {
+    mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
+    myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
     set_vaxc_errno(retsts);
     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
@@ -4329,6 +4371,8 @@ int my_utime(char *file, struct utimbuf *utimes)
   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
 #endif
   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
+  mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
+  myfab.fab$b_dns = 0;  (void) sys$parse(&myfab,0,0);
   _ckvmssts(sys$dassgn(chan));
   if (retsts & 1) retsts = iosb[0];
   if (!(retsts & 1)) {