Resync with mainline post RC1

[perl5.git] / vms / vms.c

diff --git a/vms/vms.c b/vms/vms.c
index f1f62bd..c18ca49 100644 (file)
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -68,6 +68,9 @@
 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 #endif
 
+#if defined(NEED_AN_H_ERRNO)
+dEXT int h_errno;
+#endif
 
 struct itmlst_3 {
   unsigned short int buflen;
@@ -103,7 +106,7 @@ int
 vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 {
-    char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
+    char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
     unsigned char acmode;
@@ -138,6 +141,7 @@ vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
     }
     lnmdsc.dsc$w_length = cp1 - lnm;
     lnmdsc.dsc$a_pointer = uplnm;
+    uplnm[lnmdsc.dsc$w_length] = '\0';
     secure = flags & PERL__TRNENV_SECURE;
     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
     if (!tabvec || !*tabvec) tabvec = env_tables;
@@ -207,6 +211,19 @@ vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
         retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
         if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
         if (retsts == SS$_NOLOGNAM) continue;
+        /* PPFs have a prefix */
+        if (
+#if INTSIZE == 4
+             *((int *)uplnm) == *((int *)"SYS$")                    &&
+#endif
+             eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
+             ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
+               (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
+               (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
+               (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
+          memcpy(eqv,eqv+4,eqvlen-4);
+          eqvlen -= 4;
+        }
         break;
       }
     }
@@ -988,9 +1005,9 @@ pipe_exit_routine()
 
     while (info) {
       int need_eof;
-      _ckvmssts(SYS$SETAST(0));
+      _ckvmssts(sys$setast(0));
       need_eof = info->mode != 'r' && !info->done;
-      _ckvmssts(SYS$SETAST(1));
+      _ckvmssts(sys$setast(1));
       if (need_eof) {
         if (pipe_eof(info->fp, 1) & 1) did_stuff = 1;
       }
@@ -1001,26 +1018,26 @@ pipe_exit_routine()
     did_stuff = 0;
     info = open_pipes;
     while (info) {
-      _ckvmssts(SYS$SETAST(0));
+      _ckvmssts(sys$setast(0));
       if (!info->done) { /* Tap them gently on the shoulder . . .*/
         sts = sys$forcex(&info->pid,0,&abort);
         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts); 
         did_stuff = 1;
       }
-      _ckvmssts(SYS$SETAST(1));
+      _ckvmssts(sys$setast(1));
       info = info->next;
     }
     if (did_stuff) sleep(1);    /* wait for them to respond */
 
     info = open_pipes;
     while (info) {
-      _ckvmssts(SYS$SETAST(0));
+      _ckvmssts(sys$setast(0));
       if (!info->done) {  /* We tried to be nice . . . */
         sts = sys$delprc(&info->pid,0);
         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts); 
         info->done = 1; /* so my_pclose doesn't try to write EOF */
       }
-      _ckvmssts(SYS$SETAST(1));
+      _ckvmssts(sys$setast(1));
       info = info->next;
     }
 
@@ -1138,9 +1155,9 @@ I32 Perl_my_pclose(pTHX_ FILE *fp)
     /* If we were writing to a subprocess, insure that someone reading from
      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
      * produce an EOF record in the mailbox.  */
-    _ckvmssts(SYS$SETAST(0));
+    _ckvmssts(sys$setast(0));
     need_eof = info->mode != 'r' && !info->done;
-    _ckvmssts(SYS$SETAST(1));
+    _ckvmssts(sys$setast(1));
     if (need_eof) pipe_eof(info->fp,0);
     PerlIO_close(info->fp);
 
@@ -1148,10 +1165,10 @@ I32 Perl_my_pclose(pTHX_ FILE *fp)
     else waitpid(info->pid,(int *) &retsts,0);
 
     /* remove from list of open pipes */
-    _ckvmssts(SYS$SETAST(0));
+    _ckvmssts(sys$setast(0));
     if (last) last->next = info->next;
     else open_pipes = info->next;
-    _ckvmssts(SYS$SETAST(1));
+    _ckvmssts(sys$setast(1));
     Safefree(info);
 
     return retsts;
@@ -2160,12 +2177,16 @@ static char *do_tovmsspec(char *path, char *buf, int ts) {
     else if (!infront && *cp2 == '.') {
       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
-      else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) { /* handle "../" */
-        if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; 
+      else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
+        if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
         else if (*(cp1-2) == '[') *(cp1-1) = '-';
-        else {
-/*          if (*(cp1-1) != '.') *(cp1++) = '.'; */
-          *(cp1++) = '-';
+        else {  /* back up over previous directory name */
+          cp1--;
+          while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
+          if (*(cp1-1) == '[') {
+            memcpy(cp1,"000000.",7);
+            cp1 += 7;
+          }
         }
         cp2 += 2;
         if (cp2 == dirend) break;