Further VMS piping fixes from Charles Lane:

In summary, error messages produced when a subprocess terminated
abnormally were being sent not just to the parent process, but to
grandparents, because of default values for error output that were
not completely overridden when the subprocess was started.

This patch fixes this behavior by defining user-mode (i.e., temporary
for the duration of the program) logical names for SYS$OUTPUT and
SYS$ERROR when they are (re)opened inside Perl.  And a bunch of other
changes to make it so that the user-mode logicals are the ones that
control where Perl's error messages go if it terminates abnormally.

I also added some gratuitous fixes to the indentation of braces in
the piping code.  It just looked ugly, before.

p4raw-id: //depot/perl@8257

diff --git a/doio.c b/doio.c
index 1ac381b..94a4329 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -476,6 +476,15 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            SV *sv;
 
            PerlLIO_dup2(PerlIO_fileno(fp), fd);
+#ifdef VMS
+           if (fd != PerlIO_fileno(PerlIO_stdin())) {
+             char newname[FILENAME_MAX+1];
+             if (fgetname(fp, newname)) {
+               if (fd == PerlIO_fileno(PerlIO_stdout())) Perl_vmssetuserlnm("SYS$OUTPUT", newname);
+               if (fd == PerlIO_fileno(PerlIO_stderr())) Perl_vmssetuserlnm("SYS$ERROR",  newname);
+             }
+           }
+#endif
            LOCK_FDPID_MUTEX;
            sv = *av_fetch(PL_fdpid,PerlIO_fileno(fp),TRUE);
            (void)SvUPGRADE(sv, SVt_IV);

diff --git a/vms/vms.c b/vms/vms.c
index fec955c..7872bdd 100644 (file)
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -733,6 +733,30 @@ Perl_my_setenv(pTHX_ char *lnm,char *eqv)
 }
 /*}}}*/
 
+/*{{{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(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 = 0;
+    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)*/
@@ -1846,17 +1870,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 sys$input  'perl_popen_in'\n");
+    fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user 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));
 
@@ -1895,12 +1921,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...
@@ -1961,9 +1987,9 @@ 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);
         if (info->out) {
@@ -1982,13 +2008,13 @@ 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);
         if (info->err) {
@@ -1998,7 +2024,6 @@ safe_popen(char *cmd, char *mode)
         }
 
     } else {                        /* piping to subroutine , mode=w*/
-        int melded;
 
         info->in = pipe_tochild_setup(in,mbx);
         info->fp  = PerlIO_open(mbx, mode);
@@ -2026,21 +2051,9 @@ 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);
         if (info->out) {
@@ -2048,18 +2061,14 @@ safe_popen(char *cmd, char *mode)
             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(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';
 
@@ -2071,6 +2080,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++;
@@ -2087,7 +2099,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));
 
@@ -2101,7 +2113,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;
@@ -3575,9 +3587,12 @@ mp_getredirection(pTHX_ int *ac, char ***av)
        PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
        exit(vaxc$errno);
        }
+       if (out != NULL) Perl_vmssetuserlnm("SYS$OUTPUT",out);
+
     if (err != NULL) {
         if (strcmp(err,"&1") == 0) {
             dup2(fileno(stdout), fileno(Perl_debug_log));
+            Perl_vmssetuserlnm("SYS$ERROR","SYS$OUTPUT");
         } else {
        FILE *tmperr;
        if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
@@ -3590,6 +3605,7 @@ mp_getredirection(pTHX_ int *ac, char ***av)
                {
                exit(vaxc$errno);
                }
+           Perl_vmssetuserlnm("SYS$ERROR",err);
        }
         }
 #ifdef ARGPROC_DEBUG

diff --git a/vms/vmsish.h b/vms/vmsish.h
index 8d2a628..17c5a00 100644 (file)
--- a/vms/vmsish.h
+++ b/vms/vmsish.h
@@ -709,6 +709,7 @@ int Perl_rmscopy (pTHX_ char *, char *, int);
 #endif
 char * my_getenv_len (const char *, unsigned long *, bool);
 int    vmssetenv (char *, char *, struct dsc$descriptor_s **);
+void   Perl_vmssetuserlnm(char *name, char *eqv);
 char * my_crypt (const char *, const char *);
 Pid_t  my_waitpid (Pid_t, int *, int);
 char * my_gconvert (double, int, int, char *);

diff --git a/vms/vmspipe.com b/vms/vmspipe.com
index bbb4461..652783e 100644 (file)
--- a/vms/vmspipe.com
+++ b/vms/vmspipe.com
@@ -6,12 +6,14 @@ $ perl_exit   = "exit"
 $ perl_del    = "delete"
 $ pif         = "if"
 $!  --- define i/o redirection (sys$output set by lib$spawn)
-$ pif perl_popen_in  .nes. "" then perl_define sys$input  'perl_popen_in'
-$ pif perl_popen_err .nes. "" then perl_define sys$error  'perl_popen_err'
+$ pif perl_popen_in  .nes. "" then perl_define/user sys$input  'perl_popen_in'
+$ pif perl_popen_err .nes. "" then perl_define/user sys$error  'perl_popen_err'
+$ pif perl_popen_out .nes. "" then perl_define      sys$output 'perl_popen_out'
 $ cmd = perl_popen_cmd
 $!  --- get rid of global symbols
 $ perl_del/symbol/global perl_popen_in
 $ perl_del/symbol/global perl_popen_err
+$ perl_del/symbol/global perl_popen_out
 $ perl_del/symbol/global perl_popen_cmd
 $ perl_on
 $ 'cmd