integrate cfgperl and vmsperl contents into mainline

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

diff --git a/vms/vms.c b/vms/vms.c
index 338db26..f1f62bd 100644 (file)
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -619,8 +619,7 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
          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);
+             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);
@@ -988,7 +987,11 @@ pipe_exit_routine()
     info = open_pipes;
 
     while (info) {
-      if (info->mode != 'r' && !info->done) {
+      int need_eof;
+      _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;
@@ -998,22 +1001,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;
     }
 
@@ -1117,6 +1124,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;
@@ -1130,15 +1138,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,1);
+    _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;
@@ -2506,6 +2519,9 @@ getredirection(int *ac, char ***av)
        exit(vaxc$errno);
        }
     if (err != NULL) {
+        if (strcmp(err,"&1") == 0) {
+            dup2(fileno(stdout), fileno(Perl_debug_log));
+        } else {
        FILE *tmperr;
        if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
            {
@@ -2518,6 +2534,7 @@ getredirection(int *ac, char ***av)
                exit(vaxc$errno);
                }
        }
+        }
 #ifdef ARGPROC_DEBUG
     PerlIO_printf(Perl_debug_log, "Arglist:\n");
     for (j = 0; j < *ac;  ++j)
@@ -3376,6 +3393,7 @@ setup_cmddsc(char *cmd, int check_img)
 {
   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
   $DESCRIPTOR(defdsc,".EXE");
+  $DESCRIPTOR(defdsc2,".");
   $DESCRIPTOR(resdsc,resspec);
   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
@@ -3431,18 +3449,44 @@ setup_cmddsc(char *cmd, int check_img)
     imgdsc.dsc$a_pointer = s;
     imgdsc.dsc$w_length = wordbreak - s;
     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
+    if (!(retsts&1)) {
+        _ckvmssts(lib$find_file_end(&cxt));
+        retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
     if (!(retsts & 1) && *s == '$') {
+          _ckvmssts(lib$find_file_end(&cxt));
       imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
       retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
+          if (!(retsts&1)) {
       _ckvmssts(lib$find_file_end(&cxt));
+            retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
+          }
     }
+    }
+    _ckvmssts(lib$find_file_end(&cxt));
+
     if (retsts & 1) {
+      FILE *fp;
       s = resspec;
       while (*s && !isspace(*s)) s++;
       *s = '\0';
+
+      /* check that it's really not DCL with no file extension */
+      fp = fopen(resspec,"r","ctx=bin,shr=get");
+      if (fp) {
+        char b[4] = {0,0,0,0};
+        read(fileno(fp),b,4);
+        isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
+        fclose(fp);
+      }
+      if (check_img && isdcl) return RMS$_FNF;
+
       if (cando_by_name(S_IXUSR,0,resspec)) {
         New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
+        if (!isdcl) {
         strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
+        } else {
+            strcpy(VMScmd.dsc$a_pointer,"@");
+        }
         strcat(VMScmd.dsc$a_pointer,resspec);
         if (rest) strcat(VMScmd.dsc$a_pointer,rest);
         VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);