Here's the patch for the piping changes. Note that since miniperl may
be doing subprocesses, we need to get the PERL_ROOT logical set up
early in the build and copy VMSPIPE.COM to PERL_ROOT:[000000]
installperl.
moves the VMSPIPE.COM to new PERL_ROOT:[000000]
manifest.
add vms/vmspipe.com
t/io/openpid.t
don't need to cripple the test anymore
vms/descrip_mms.template
set up Perl_root logical for the build
get VMSPIPE.COM moved
vms/test.com
turn off VMSish error messages (we get double copies from sys$output
and sys$error that confuse test routines)
vms/vms.c
mbx size settable by logical PERL_MBX_SIZE
extensive changes to safe_popen, Perl_my_pclose, popen_completion_ast
additional routines to pipe input and output between child
and Perl or between child and file
vms/vmspipe.com
command file wrapper for child process
If you read from a child process:
child's sys$input <- NL:
child's sys$output -> MBX -> EOF filter -> MBX -> Perl i/o
child's sys$error -> parent's stderr
The "EOF filter" is to remove extra EOF's from "grandchildren", to
snarf excess output from child when Perl closes the filehandle, and
to generate extra EOFs if Perl keeps reading after child terminates.
If you write to a child process:
child's sys$input <- MBX <- pending i/o queue <- MBX <- Perl i/o
child's sys$output -> parent's stdout
child's sys$error -> parent's stderr
The "pending i/o queue" is to prevent parent going into RWMBX when
child gets cranky and won't listen, and generates extra EOFs if
child keeps reading after Perl closes filehandle.
Piping to parent's stdout or stderr goes directly if the device is
non-file-structured (MBX or terminal), otherwise a MBX is created and
piped to a dup'ed file descriptor.
--- installperl.-orig Mon Mar 27 11:16:02 2000
+++ installperl. Mon Mar 27 11:12:36 2000
@@ -199,6 +199,9 @@
safe_unlink("$installbin/${perl}shr$exe_ext");
copy("perlshr$exe_ext", "$installbin/${perl}shr$exe_ext");
chmod(0755, "$installbin/${perl}shr$exe_ext");
+ safe_unlink("$installbin/vmspipe.com");
+ copy("vmspipe.com", "$installbin/vmspipe.com");
+ chmod(0755, "$installbin/vmspipe.com");
}
elsif ($^O eq 'mpeix') {
# MPE lacks hard links and requires that executables with special
--- manifest.-orig Mon Mar 27 11:16:11 2000
+++ manifest. Mon Mar 27 11:12:38 2000
@@ -1538,6 +1538,7 @@
vms/vms.c VMS-specific C code for Perl core
vms/vms_yfix.pl convert Unix perly.[ch] to VMS perly_[ch].vms
vms/vmsish.h VMS-specific C header for Perl core
+vms/vmspipe.com VMS-specific piped command helper script
vms/writemain.pl Generate perlmain.c from miniperlmain.c+extensions
vos/Changes Changes made to port Perl to the VOS operating system
vos/build.cm VOS command macro to build Perl
--- t/io/openpid.t-orig Tue Mar 28 10:49:13 2000
+++ t/io/openpid.t Mon Mar 27 11:12:40 2000
@@ -78,7 +78,6 @@
# send one expected line of text to child process and then wait for it
autoflush FH4 1;
print FH4 "ok 9\n";
-print "ok 9 # skip VMS\n" if $^O eq 'VMS';
print "# waiting for process $pid4 to exit\n";
$reap_pid = waitpid $pid4, 0;
print "# reaped pid $reap_pid != $pid4\nnot "
--- vms/descrip_mms.template-orig Mon Mar 27 11:15:35 2000
+++ vms/descrip_mms.template Mon Mar 27 11:12:41 2000
@@ -339,7 +339,7 @@
all : base extras x2p archcorefiles preplibrary perlpods
@ $(NOOP)
.endif
-base : miniperl perl
+base : vmspipe.com miniperl perl
@ $(NOOP)
extras : dynext libmods utils podxform
@ $(NOOP)
@@ -381,6 +381,14 @@
archcorefiles : $(ac) $(acth) $(ARCHAUTO)time.stamp
@ $(NOOP)
+
+.FIRST
+ IF F$TRNLNM("PERL_ROOT") .EQS. "" THEN XTEMP =
+F$TRNLNM(F$PARSE(F$ENV("DEFAULT"),,,"DEVICE")-":")+F$PARSE(F$ENV("DEFAULT"),,,"DIRECTORY")
+ - "][" - ".000000" - "]" - "000000." + ".]"
+ IF F$TRNLNM("PERL_ROOT") .EQS. "" THEN DEFINE/TRANS=CONCEAL PERL_ROOT 'XTEMP'
+ SHOW LOG PERL_ROOT
+
+vmspipe.com : [.vms]vmspipe.com
+ copy/log $(MMS$SOURCE) $(MMS$TARGET)
miniperl : $(DBG)miniperl$(E)
@ Continue
--- vms/test.com-orig Mon Mar 27 11:15:18 2000
+++ vms/test.com Mon Mar 27 11:15:11 2000
@@ -19,7 +19,7 @@
$ Exit 44
$ EndIf
$ EndIf
-$ Set Message /Facility/Severity/Identification/Text
+$ Set Message /NoFacility/NoSeverity/NoIdentification/NoText
$
$ exe = ".Exe"
$ If p1.nes."" Then exe = p1
@@ -108,7 +108,7 @@
use Config;
@compexcl=('cpp.t');
-@ioexcl=('argv.t','dup.t','fs.t','pipe.t','openpid.t');
+@ioexcl=('argv.t','dup.t','fs.t','pipe.t');
@libexcl=('db-btree.t','db-hash.t','db-recno.t',
'gdbm.t','io_dup.t', 'io_pipe.t', 'io_poll.t', 'io_sel.t',
'io_sock.t', 'io_unix.t',
--- vms/vms.c-orig Mon Mar 27 11:15:41 2000
+++ vms/vms.c Tue Mar 28 06:35:45 2000
@@ -14,6 +14,7 @@
#include <clidef.h>
#include <climsgdef.h>
#include <descrip.h>
+#include <devdef.h>
#include <dvidef.h>
#include <fibdef.h>
#include <float.h>
@@ -915,19 +919,35 @@
static void
create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
{
- static unsigned long int mbxbufsiz;
- long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
+ unsigned long int mbxbufsiz;
+ static unsigned long int syssize = 0;
+ unsigned long int dviitm = DVI$_DEVNAM;
dTHX;
+ char csize[LNM$C_NAMLENGTH+1];
- if (!mbxbufsiz) {
+ if (!syssize) {
+ unsigned long syiitm = SYI$_MAXBUF;
/*
* Get the SYSGEN parameter MAXBUF, and the smaller of it and the
- * preprocessor consant BUFSIZ from stdio.h as the size of the
+ * preprocessor consant BUFSIZ from stdio.h defaults as the size of the
* 'pipe' mailbox.
+ *
+ * If the logical 'PERL_MBX_SIZE' is defined
+ * use the value of the logical instead of BUFSIZ, but again
+ * keep the size between 128 and MAXBUF.
+ *
*/
- _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
- if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
+ _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
+ }
+
+ if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
+ mbxbufsiz = atoi(csize);
+ } else {
+ mbxbufsiz = BUFSIZ;
}
+ if (mbxbufsiz < 128) mbxbufsiz = 128;
+ if (mbxbufsiz > syssize) mbxbufsiz = syssize;
+
_ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
_ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
@@ -935,15 +955,78 @@
} /* end of create_mbx() */
+
/*{{{ my_popen and my_pclose*/
+
+typedef struct _iosb IOSB;
+typedef struct _iosb* pIOSB;
+typedef struct _pipe Pipe;
+typedef struct _pipe* pPipe;
+typedef struct pipe_details Info;
+typedef struct pipe_details* pInfo;
+typedef struct _srqp RQE;
+typedef struct _srqp* pRQE;
+typedef struct _tochildbuf CBuf;
+typedef struct _tochildbuf* pCBuf;
+
+struct _iosb {
+ unsigned short status;
+ unsigned short count;
+ unsigned long dvispec;
+};
+
+#pragma member_alignment save
+#pragma nomember_alignment quadword
+struct _srqp { /* VMS self-relative queue entry */
+ unsigned long qptr[2];
+};
+#pragma member_alignment restore
+static RQE RQE_ZERO = {0,0};
+
+struct _tochildbuf {
+ RQE q;
+ int eof;
+ unsigned short size;
+ char *buf;
+};
+
+struct _pipe {
+ int fd_out;
+ unsigned short chan_in;
+ unsigned short chan_out;
+ char *buf;
+ unsigned int bufsize;
+ IOSB iosb;
+ IOSB iosb2;
+ int *pipe_done;
+ int retry;
+ int type;
+ int shut_on_empty;
+ int need_wake;
+ pPipe *home;
+ pInfo info;
+ pCBuf curr;
+ pCBuf curr2;
+ RQE free;
+ RQE wait;
+};
+
+
struct pipe_details
{
- struct pipe_details *next;
+ pInfo next;
PerlIO *fp; /* stdio file pointer to pipe mailbox */
int pid; /* PID of subprocess */
int mode; /* == 'r' if pipe open for reading */
int done; /* subprocess has completed */
- unsigned long int completion; /* termination status of subprocess */
+ int closing; /* my_pclose is closing this pipe */
+ unsigned long completion; /* termination status of subprocess */
+ pPipe in; /* pipe in to sub */
+ pPipe out; /* pipe out of sub */
+ pPipe err; /* pipe of sub's sys$error */
+ int in_done; /* true when in pipe finished */
+ int out_done;
+ int err_done;
};
struct exit_control_block
@@ -955,45 +1038,23 @@
unsigned long int exit_status;
};
-static struct pipe_details *open_pipes = NULL;
-static $DESCRIPTOR(nl_desc, "NL:");
-static int waitpid_asleep = 0;
+#define RETRY_DELAY "0 ::0.20"
+#define MAX_RETRY 50
-/* Send an EOF to a mbx. N.B. We don't check that fp actually points
- * to a mbx; that's the caller's responsibility.
- */
-static unsigned long int
-pipe_eof(FILE *fp, int immediate)
-{
- char devnam[NAM$C_MAXRSS+1], *cp;
- unsigned long int chan, iosb[2], retsts, retsts2;
- struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
- dTHX;
+static int pipe_ef = 0; /* first call to safe_popen inits these*/
+static unsigned long mypid;
+static unsigned long delaytime[2];
+
+static pInfo open_pipes = NULL;
+static $DESCRIPTOR(nl_desc, "NL:");
- if (fgetname(fp,devnam,1)) {
- /* It oughta be a mailbox, so fgetname should give just the device
- * name, but just in case . . . */
- if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
- devdsc.dsc$w_length = strlen(devnam);
- _ckvmssts(sys$assign(&devdsc,&chan,0,0));
- retsts = sys$qiow(0,chan,IO$_WRITEOF|(immediate?IO$M_NOW|IO$M_NORSWAIT:0),
- iosb,0,0,0,0,0,0,0,0);
- if (retsts & 1) retsts = iosb[0];
- retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
- if (retsts & 1) retsts = retsts2;
- _ckvmssts(retsts);
- return retsts;
- }
- else _ckvmssts(vaxc$errno); /* Should never happen */
- return (unsigned long int) vaxc$errno;
-}
static unsigned long int
pipe_exit_routine()
{
- struct pipe_details *info;
+ pInfo info;
unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
- int sts, did_stuff;
+ int sts, did_stuff, need_eof;
dTHX;
/*
@@ -1006,11 +1067,12 @@
while (info) {
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;
+ if (info->in && !info->in->shut_on_empty) {
+ _ckvmssts(SYS$QIO(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
+ 0, 0, 0, 0, 0, 0));
+ did_stuff = 1;
}
+ _ckvmssts(sys$setast(1));
info = info->next;
}
if (did_stuff) sleep(1); /* wait for EOF to have an effect */
@@ -1035,7 +1097,6 @@
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;
@@ -1052,72 +1113,682 @@
{(struct exit_control_block *) 0,
pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
+static void pipe_mbxtofd_ast(pPipe p);
+static void pipe_tochild1_ast(pPipe p);
+static void pipe_tochild2_ast(pPipe p);
static void
-popen_completion_ast(struct pipe_details *thispipe)
+popen_completion_ast(pInfo info)
{
- thispipe->done = TRUE;
- if (waitpid_asleep) {
- waitpid_asleep = 0;
- sys$wake(0,0);
+ pInfo i = open_pipes;
+ int iss;
+
+ while (i) {
+ if (i == info) break;
+ i = i->next;
+ }
+ if (!i) return; /* unlinked, probably freed too */
+
+ info->completion &= 0x0FFFFFFF; /* strip off "control" field */
+ info->done = TRUE;
+
+/*
+ Writing to subprocess ...
+ if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
+
+ chan_out may be waiting for "done" flag, or hung waiting
+ for i/o completion to child...cancel the i/o. This will
+ put it into "snarf mode" (done but no EOF yet) that discards
+ input.
+
+ Output from subprocess (stdout, stderr) needs to be flushed and
+ shut down. We try sending an EOF, but if the mbx is full the pipe
+ routine should still catch the "shut_on_empty" flag, telling it to
+ use immediate-style reads so that "mbx empty" -> EOF.
+
+
+*/
+ if (info->in && !info->in_done) { /* only for mode=w */
+ if (info->in->shut_on_empty && info->in->need_wake) {
+ info->in->need_wake = FALSE;
+ _ckvmssts(SYS$DCLAST(pipe_tochild2_ast,info->in,0));
+ } else {
+ _ckvmssts(SYS$CANCEL(info->in->chan_out));
+ }
+ }
+
+ if (info->out && !info->out_done) { /* were we also piping output? */
+ info->out->shut_on_empty = TRUE;
+ iss = SYS$QIO(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0,
+0, 0, 0);
+ if (iss == SS$_MBFULL) iss = SS$_NORMAL;
+ _ckvmssts(iss);
+ }
+
+ if (info->err && !info->err_done) { /* we were piping stderr */
+ info->err->shut_on_empty = TRUE;
+ iss = SYS$QIO(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0,
+0, 0, 0, 0);
+ if (iss == SS$_MBFULL) iss = SS$_NORMAL;
+ _ckvmssts(iss);
}
+ _ckvmssts(SYS$SETEF(pipe_ef));
+
}
static unsigned long int setup_cmddsc(char *cmd, int check_img);
static void vms_execfree();
+/*
+ we actually differ from vmstrnenv since we use this to
+ get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
+ are pointing to the same thing
+*/
+
+static unsigned short
+popen_translate(char *logical, char *result)
+{
+ int iss;
+ $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
+ $DESCRIPTOR(d_log,"");
+ struct _il3 {
+ unsigned short length;
+ unsigned short code;
+ char * buffer_addr;
+ unsigned short *retlenaddr;
+ } itmlst[2];
+ unsigned short l, ifi;
+
+ d_log.dsc$a_pointer = logical;
+ d_log.dsc$w_length = strlen(logical);
+
+ itmlst[0].code = LNM$_STRING;
+ itmlst[0].length = 255;
+ itmlst[0].buffer_addr = result;
+ itmlst[0].retlenaddr = &l;
+
+ itmlst[1].code = 0;
+ itmlst[1].length = 0;
+ itmlst[1].buffer_addr = 0;
+ itmlst[1].retlenaddr = 0;
+
+ iss = SYS$TRNLNM(0, &d_table, &d_log, 0, itmlst);
+ if (iss == SS$_NOLOGNAM) {
+ iss = SS$_NORMAL;
+ l = 0;
+ }
+ if (!(iss&1)) lib$signal(iss);
+ result[l] = '\0';
+/*
+ logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
+ strip it off and return the ifi, if any
+*/
+ ifi = 0;
+ if (result[0] == 0x1b && result[1] == 0x00) {
+ memcpy(&ifi,result+2,2);
+ strcpy(result,result+4);
+ }
+ return ifi; /* this is the RMS internal file id */
+}
+
+#define MAX_DCL_SYMBOL 255
+static void pipe_infromchild_ast(pPipe p);
+
+/*
+ I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
+ inside an AST routine without worrying about reentrancy and which Perl
+ memory allocator is being used.
+
+ We read data and queue up the buffers, then spit them out one at a
+ time to the output mailbox when the output mailbox is ready for one.
+
+*/
+#define INITIAL_TOCHILDQUEUE 2
+
+static pPipe
+pipe_tochild_setup(char *rmbx, char *wmbx)
+{
+ pPipe p;
+ pCBuf b;
+ char mbx1[64], mbx2[64];
+ struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
+ DSC$K_CLASS_S, mbx1},
+ d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
+ DSC$K_CLASS_S, mbx2};
+ unsigned int dviitm = DVI$_DEVBUFSIZ;
+ int j, n;
+
+ New(1368, p, 1, Pipe);
+
+ create_mbx(&p->chan_in , &d_mbx1);
+ create_mbx(&p->chan_out, &d_mbx2);
+ _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
+
+ p->buf = 0;
+ p->shut_on_empty = FALSE;
+ p->need_wake = FALSE;
+ p->type = 0;
+ p->retry = 0;
+ p->iosb.status = SS$_NORMAL;
+ p->iosb2.status = SS$_NORMAL;
+ p->free = RQE_ZERO;
+ p->wait = RQE_ZERO;
+ p->curr = 0;
+ p->curr2 = 0;
+ p->info = 0;
+
+ n = sizeof(CBuf) + p->bufsize;
+
+ for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
+ _ckvmssts(LIB$GET_VM(&n, &b));
+ b->buf = (char *) b + sizeof(CBuf);
+ _ckvmssts(LIB$INSQHI(b, &p->free));
+ }
+
+ pipe_tochild2_ast(p);
+ pipe_tochild1_ast(p);
+ strcpy(wmbx, mbx1);
+ strcpy(rmbx, mbx2);
+ return p;
+}
+
+/* reads the MBX Perl is writing, and queues */
+
+static void
+pipe_tochild1_ast(pPipe p)
+{
+ pCBuf b = p->curr;
+ int iss = p->iosb.status;
+ int eof = (iss == SS$_ENDOFFILE);
+
+ if (p->retry) {
+ if (eof) {
+ p->shut_on_empty = TRUE;
+ b->eof = TRUE;
+ _ckvmssts(SYS$DASSGN(p->chan_in));
+ } else {
+ _ckvmssts(iss);
+ }
+
+ b->eof = eof;
+ b->size = p->iosb.count;
+ _ckvmssts(LIB$INSQHI(b, &p->wait));
+ if (p->need_wake) {
+ p->need_wake = FALSE;
+ _ckvmssts(SYS$DCLAST(pipe_tochild2_ast,p,0));
+ }
+ } else {
+ p->retry = 1; /* initial call */
+ }
+
+ if (eof) { /* flush the free queue, return when done */
+ int n = sizeof(CBuf) + p->bufsize;
+ while (1) {
+ iss = LIB$REMQTI(&p->free, &b);
+ if (iss == LIB$_QUEWASEMP) return;
+ _ckvmssts(iss);
+ _ckvmssts(LIB$FREE_VM(&n, &b));
+ }
+ }
+
+ iss = LIB$REMQTI(&p->free, &b);
+ if (iss == LIB$_QUEWASEMP) {
+ int n = sizeof(CBuf) + p->bufsize;
+ _ckvmssts(LIB$GET_VM(&n, &b));
+ b->buf = (char *) b + sizeof(CBuf);
+ } else {
+ _ckvmssts(iss);
+ }
+
+ p->curr = b;
+ iss = SYS$QIO(0,p->chan_in,
+ IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
+ &p->iosb,
+ pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
+ if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
+ _ckvmssts(iss);
+}
+
+
+/* writes queued buffers to output, waits for each to complete before
+ doing the next */
+
+static void
+pipe_tochild2_ast(pPipe p)
+{
+ pCBuf b = p->curr2;
+ int iss = p->iosb2.status;
+ int n = sizeof(CBuf) + p->bufsize;
+ int done = (p->info && p->info->done) ||
+ iss == SS$_CANCEL || iss == SS$_ABORT;
+
+ do {
+ if (p->type) { /* type=1 has old buffer, dispose */
+ if (p->shut_on_empty) {
+ _ckvmssts(LIB$FREE_VM(&n, &b));
+ } else {
+ _ckvmssts(LIB$INSQHI(b, &p->free));
+ }
+ p->type = 0;
+ }
+
+ iss = LIB$REMQTI(&p->wait, &b);
+ if (iss == LIB$_QUEWASEMP) {
+ if (p->shut_on_empty) {
+ if (done) {
+ _ckvmssts(SYS$DASSGN(p->chan_out));
+ *p->pipe_done = TRUE;
+ _ckvmssts(SYS$SETEF(pipe_ef));
+ } else {
+ _ckvmssts(SYS$QIO(0,p->chan_out,IO$_WRITEOF,
+ &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
+ }
+ return;
+ }
+ p->need_wake = TRUE;
+ return;
+ }
+ _ckvmssts(iss);
+ p->type = 1;
+ } while (done);
+
+
+ p->curr2 = b;
+ if (b->eof) {
+ _ckvmssts(SYS$QIO(0,p->chan_out,IO$_WRITEOF,
+ &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
+ } else {
+ _ckvmssts(SYS$QIO(0,p->chan_out,IO$_WRITEVBLK,
+ &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
+ }
+
+ return;
+
+}
+
+
+static pPipe
+pipe_infromchild_setup(char *rmbx, char *wmbx)
+{
+ pPipe p;
+ char mbx1[64], mbx2[64];
+ struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
+ DSC$K_CLASS_S, mbx1},
+ d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
+ DSC$K_CLASS_S, mbx2};
+ unsigned int dviitm = DVI$_DEVBUFSIZ;
+
+ New(1367, p, 1, Pipe);
+ create_mbx(&p->chan_in , &d_mbx1);
+ create_mbx(&p->chan_out, &d_mbx2);
+
+ _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
+ New(1367, p->buf, p->bufsize, char);
+ p->shut_on_empty = FALSE;
+ p->info = 0;
+ p->type = 0;
+ p->iosb.status = SS$_NORMAL;
+ pipe_infromchild_ast(p);
+
+ strcpy(wmbx, mbx1);
+ strcpy(rmbx, mbx2);
+ return p;
+}
+
+static void
+pipe_infromchild_ast(pPipe p)
+{
+ int iss = p->iosb.status;
+ int eof = (iss == SS$_ENDOFFILE);
+ int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
+ int kideof = (eof && (p->iosb.dvispec == p->info->pid));
+
+ if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
+ _ckvmssts(SYS$DASSGN(p->chan_out));
+ p->chan_out = 0;
+ }
+
+ /* read completed:
+ input shutdown if EOF from self (done or shut_on_empty)
+ output shutdown if closing flag set (my_pclose)
+ send data/eof from child or eof from self
+ otherwise, re-read (snarf of data from child)
+ */
+
+ if (p->type == 1) {
+ p->type = 0;
+ if (myeof && p->chan_in) { /* input shutdown */
+ _ckvmssts(SYS$DASSGN(p->chan_in));
+ p->chan_in = 0;
+ }
+
+ if (p->chan_out) {
+ if (myeof || kideof) { /* pass EOF to parent */
+ _ckvmssts(SYS$QIO(0,p->chan_out,IO$_WRITEOF, &p->iosb,
+ pipe_infromchild_ast, p,
+ 0, 0, 0, 0, 0, 0));
+ return;
+ } else if (eof) { /* eat EOF --- fall through to read*/
+
+ } else { /* transmit data */
+ _ckvmssts(SYS$QIO(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
+ pipe_infromchild_ast,p,
+ p->buf, p->iosb.count, 0, 0, 0, 0));
+ return;
+ }
+ }
+ }
+
+ /* everything shut? flag as done */
+
+ if (!p->chan_in && !p->chan_out) {
+ *p->pipe_done = TRUE;
+ _ckvmssts(SYS$SETEF(pipe_ef));
+ return;
+ }
+
+ /* write completed (or read, if snarfing from child)
+ if still have input active,
+ queue read...immediate mode if shut_on_empty so we get EOF if empty
+ otherwise,
+ check if Perl reading, generate EOFs as needed
+ */
+
+ if (p->type == 0) {
+ p->type = 1;
+ if (p->chan_in) {
+ iss = SYS$QIO(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW :
+0),&p->iosb,
+ pipe_infromchild_ast,p,
+ p->buf, p->bufsize, 0, 0, 0, 0);
+ if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
+ _ckvmssts(iss);
+ } else { /* send EOFs for extra reads */
+ p->iosb.status = SS$_ENDOFFILE;
+ p->iosb.dvispec = 0;
+ _ckvmssts(SYS$QIO(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
+ 0, 0, 0,
+ pipe_infromchild_ast, p, 0, 0, 0, 0));
+ }
+ }
+}
+
+static pPipe
+pipe_mbxtofd_setup(int fd, char *out)
+{
+ pPipe p;
+ char mbx[64];
+ unsigned long dviitm = DVI$_DEVBUFSIZ;
+ struct stat s;
+ struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
+ DSC$K_CLASS_S, mbx};
+
+ /* things like terminals and mbx's don't need this filter */
+ if (fd && fstat(fd,&s) == 0) {
+ unsigned long dviitm = DVI$_DEVCHAR, devchar;
+ struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
+ DSC$K_CLASS_S, s.st_dev};
+
+ _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
+ if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
+ strcpy(out, s.st_dev);
+ return 0;
+ }
+ }
+
+ New(1366, p, 1, Pipe);
+ p->fd_out = dup(fd);
+ create_mbx(&p->chan_in, &d_mbx);
+ _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
+ New(1366, p->buf, p->bufsize+1, char);
+ p->shut_on_empty = FALSE;
+ p->retry = 0;
+ p->info = 0;
+ strcpy(out, mbx);
+
+ _ckvmssts(SYS$QIO(0, p->chan_in, IO$_READVBLK, &p->iosb,
+ pipe_mbxtofd_ast, p,
+ p->buf, p->bufsize, 0, 0, 0, 0));
+
+ return p;
+}
+
+static void
+pipe_mbxtofd_ast(pPipe p)
+{
+ int iss = p->iosb.status;
+ int done = p->info->done;
+ int iss2;
+ int eof = (iss == SS$_ENDOFFILE);
+ int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
+ int err = !(iss&1) && !eof;
+
+
+ if (done && myeof) { /* end piping */
+ close(p->fd_out);
+ SYS$DASSGN(p->chan_in);
+ *p->pipe_done = TRUE;
+ _ckvmssts(SYS$SETEF(pipe_ef));
+ return;
+ }
+
+ if (!err && !eof) { /* good data to send to file */
+ p->buf[p->iosb.count] = '\n';
+ iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
+ if (iss2 < 0) {
+ p->retry++;
+ if (p->retry < MAX_RETRY) {
+ _ckvmssts(SYS$SETIMR(0,delaytime,pipe_mbxtofd_ast,p));
+ return;
+ }
+ }
+ p->retry = 0;
+ } else if (err) {
+ _ckvmssts(iss);
+ }
+
+
+ iss = SYS$QIO(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),
+&p->iosb,
+ pipe_mbxtofd_ast, p,
+ p->buf, p->bufsize, 0, 0, 0, 0);
+ if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
+ _ckvmssts(iss);
+}
+
+
+
static PerlIO *
safe_popen(char *cmd, char *mode)
{
static int handler_set_up = FALSE;
- char mbxname[64];
- unsigned short int chan;
unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
+ unsigned int table = LIB$K_CLI_GLOBAL_SYM;
+ char *p, symbol[MAX_DCL_SYMBOL+1];
+ char in[512], out[512], err[512], mbx[512];
dTHX;
- struct pipe_details *info;
- struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
- DSC$K_CLASS_S, mbxname},
- cmddsc = {0, DSC$K_DTYPE_T,
- DSC$K_CLASS_S, 0};
-
+ 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};
+
+ $DESCRIPTOR(cmddsc,"@PERL_ROOT:[000000]VMSPIPE.COM;");
+ $DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD");
+ $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
+ $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
+
+ /* once-per-program initialization...
+ note that the SETAST calls and the dual test of pipe_ef
+ makes sure that only the FIRST thread through here does
+ the initialization...all other threads wait until it's
+ done.
+
+ Yeah, uglier than a pthread call, it's got all the stuff inline
+ rather than in a separate routine.
+ */
+
+ if (!pipe_ef) {
+ _ckvmssts(SYS$SETAST(0));
+ if (!pipe_ef) {
+ unsigned long int pidcode = JPI$_PID;
+ $DESCRIPTOR(d_delay, RETRY_DELAY);
+ _ckvmssts(lib$get_ef(&pipe_ef));
+ _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
+ _ckvmssts(SYS$BINTIM(&d_delay, delaytime));
+ }
+ if (!handler_set_up) {
+ _ckvmssts(sys$dclexh(&pipe_exitblock));
+ handler_set_up = TRUE;
+ }
+ _ckvmssts(SYS$SETAST(1));
+ }
if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
- New(1301,info,1,struct pipe_details);
+ New(1301,info,1,Info);
- /* create mailbox */
- create_mbx(&chan,&namdsc);
+ info->mode = *mode;
+ info->done = FALSE;
+ info->completion = 0;
+ info->closing = FALSE;
+ info->in = 0;
+ info->out = 0;
+ info->err = 0;
+ info->in_done = TRUE;
+ info->out_done = TRUE;
+ info->err_done = TRUE;
+
+ if (*mode == 'r') { /* piping from subroutine */
+ in[0] = '\0';
+
+ info->out = pipe_infromchild_setup(mbx,out);
+ if (info->out) {
+ info->out->pipe_done = &info->out_done;
+ info->out_done = FALSE;
+ info->out->info = info;
+ }
+ info->fp = PerlIO_open(mbx, mode);
+ if (!info->fp && info->out) {
+ SYS$CANCEL(info->out->chan_out);
+
+ while (!info->out_done) {
+ int done;
+ _ckvmssts(SYS$SETAST(0));
+ done = info->out_done;
+ if (!done) _ckvmssts(SYS$CLREF(pipe_ef));
+ _ckvmssts(SYS$SETAST(1));
+ if (!done) _ckvmssts(SYS$WAITFR(pipe_ef));
+ }
- /* open a FILE* onto it */
- info->fp = PerlIO_open(mbxname, mode);
+ if (info->out->buf) Safefree(info->out->buf);
+ Safefree(info->out);
+ Safefree(info);
+ return Nullfp;
+ }
- /* give up other channel onto it */
- _ckvmssts(sys$dassgn(chan));
+ 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 { /* piping to subroutine */
+ int melded;
+
+ info->in = pipe_tochild_setup(in,mbx);
+ info->fp = PerlIO_open(mbx, mode);
+ if (info->in) {
+ info->in->pipe_done = &info->in_done;
+ info->in_done = FALSE;
+ info->in->info = info;
+ }
+ if (!info->fp && info->in) {
+ info->done = TRUE;
+ _ckvmssts(SYS$QIOW(0,info->in->chan_in, IO$_WRITEOF, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0));
+
+ while (!info->in_done) {
+ int done;
+ _ckvmssts(SYS$SETAST(0));
+ done = info->in_done;
+ if (!done) _ckvmssts(SYS$CLREF(pipe_ef));
+ _ckvmssts(SYS$SETAST(1));
+ if (!done) _ckvmssts(SYS$WAITFR(pipe_ef));
+ }
- if (!info->fp)
+ if (info->in->buf) Safefree(info->in->buf);
+ Safefree(info->in);
+ Safefree(info);
return Nullfp;
+ }
- info->mode = *mode;
- info->done = FALSE;
- info->completion=0;
+ /* if SYS$ERROR == SYS$OUTPUT, use only one mbx */
- if (*mode == 'r') {
- _ckvmssts(lib$spawn(&VMScmd, &nl_desc, &namdsc, &flags,
- 0 /* name */, &info->pid, &info->completion,
- 0, popen_completion_ast,info,0,0,0));
+ 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;
+ }
}
- else {
- _ckvmssts(lib$spawn(&VMScmd, &namdsc, 0 /* sys$output */, &flags,
- 0 /* name */, &info->pid, &info->completion,
- 0, popen_completion_ast,info,0,0,0));
}
- vms_execfree();
- if (!handler_set_up) {
- _ckvmssts(sys$dclexh(&pipe_exitblock));
- handler_set_up = TRUE;
+ info->out = pipe_mbxtofd_setup(fileno(stdout), out);
+ if (info->out) {
+ info->out->pipe_done = &info->out_done;
+ 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';
+ }
}
+ d_out.dsc$w_length = strlen(out); /* lib$spawn sets SYS$OUTPUT so can meld*/
+
+ symbol[MAX_DCL_SYMBOL] = '\0';
+
+ strncpy(symbol, in, MAX_DCL_SYMBOL);
+ d_symbol.dsc$w_length = strlen(symbol);
+ _ckvmssts(LIB$SET_SYMBOL(&d_sym_in, &d_symbol, &table));
+
+ strncpy(symbol, err, MAX_DCL_SYMBOL);
+ d_symbol.dsc$w_length = strlen(symbol);
+ _ckvmssts(LIB$SET_SYMBOL(&d_sym_err, &d_symbol, &table));
+
+
+ p = VMScmd.dsc$a_pointer;
+ while (*p && *p != '\n') p++;
+ *p = '\0'; /* truncate on \n */
+ p = VMScmd.dsc$a_pointer;
+ while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
+ if (*p == '$') p++; /* remove leading $ */
+ while (*p == ' ' || *p == '\t') p++;
+ strncpy(symbol, p, MAX_DCL_SYMBOL);
+ d_symbol.dsc$w_length = strlen(symbol);
+ _ckvmssts(LIB$SET_SYMBOL(&d_sym_cmd, &d_symbol, &table));
+
+ _ckvmssts(SYS$SETAST(0));
info->next=open_pipes; /* prepend to list */
open_pipes=info;
+ _ckvmssts(SYS$SETAST(1));
+ _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &d_out, &flags,
+ 0, &info->pid, &info->completion,
+ 0, popen_completion_ast,info,0,0,0));
+
+ /* once the subprocess is spawned, its copied the symbols and
+ we can get rid of ours */
+
+ _ckvmssts(LIB$DELETE_SYMBOL(&d_sym_cmd, &table));
+ _ckvmssts(LIB$DELETE_SYMBOL(&d_sym_in, &table));
+ _ckvmssts(LIB$DELETE_SYMBOL(&d_sym_err, &table));
+
+ vms_execfree();
PL_forkprocess = info->pid;
return info->fp;
@@ -1139,9 +1810,9 @@
/*{{{ I32 my_pclose(FILE *fp)*/
I32 Perl_my_pclose(pTHX_ FILE *fp)
{
- struct pipe_details *info, *last = NULL;
+ pInfo info, last = NULL;
unsigned long int retsts;
- int need_eof;
+ int done, iss;
for (info = open_pipes; info != NULL; last = info, info = info->next)
if (info->fp == fp) break;
@@ -1154,21 +1825,67 @@
/* 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));
- need_eof = info->mode != 'r' && !info->done;
- _ckvmssts(sys$setast(1));
- if (need_eof) pipe_eof(info->fp,0);
+ * produce an EOF record in the mailbox.
+ *
+ * well, at least sometimes it *does*, so we have to watch out for
+ * the first EOF closing the pipe (and DASSGN'ing the channel)...
+ */
+
+ fsync(fileno(info->fp)); /* first, flush data */
+
+ _ckvmssts(SYS$SETAST(0));
+ info->closing = TRUE;
+ done = info->done && info->in_done && info->out_done && info->err_done;
+ /* hanging on write to Perl's input? cancel it */
+ if (info->mode == 'r' && info->out && !info->out_done) {
+ if (info->out->chan_out) {
+ _ckvmssts(SYS$CANCEL(info->out->chan_out));
+ if (!info->out->chan_in) { /* EOF generation, need AST */
+ _ckvmssts(SYS$DCLAST(pipe_infromchild_ast,info->out,0));
+ }
+ }
+ }
+ if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't
+had one yet */
+ _ckvmssts(SYS$QIO(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
+ 0, 0, 0, 0, 0, 0));
+ _ckvmssts(SYS$SETAST(1));
PerlIO_close(info->fp);
- if (info->done) retsts = info->completion;
- else waitpid(info->pid,(int *) &retsts,0);
+ /*
+ we have to wait until subprocess completes, but ALSO wait until all
+ the i/o completes...otherwise we'll be freeing the "info" structure
+ that the i/o ASTs could still be using...
+ */
+
+ while (!done) {
+ _ckvmssts(SYS$SETAST(0));
+ done = info->done && info->in_done && info->out_done && info->err_done;
+ if (!done) _ckvmssts(SYS$CLREF(pipe_ef));
+ _ckvmssts(SYS$SETAST(1));
+ if (!done) _ckvmssts(SYS$WAITFR(pipe_ef));
+ }
+ retsts = info->completion;
/* 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));
+
+ /* free buffers and structures */
+
+ if (info->in) {
+ if (info->in->buf) Safefree(info->in->buf);
+ Safefree(info->in);
+ }
+ if (info->out) {
+ if (info->out->buf) Safefree(info->out->buf);
+ Safefree(info->out);
+ }
+ if (info->err) {
+ if (info->err->buf) Safefree(info->err->buf);
+ Safefree(info->err);
+ }
Safefree(info);
return retsts;
@@ -1180,7 +1897,8 @@
Pid_t
my_waitpid(Pid_t pid, int *statusp, int flags)
{
- struct pipe_details *info;
+ pInfo info;
+ int done;
dTHX;
for (info = open_pipes; info != NULL; info = info->next)
@@ -1188,8 +1906,11 @@
if (info != NULL) { /* we know about this child */
while (!info->done) {
- waitpid_asleep = 1;
- sys$hiber();
+ _ckvmssts(SYS$SETAST(0));
+ done = info->done;
+ if (!done) _ckvmssts(SYS$CLREF(pipe_ef));
+ _ckvmssts(SYS$SETAST(1));
+ if (!done) _ckvmssts(SYS$WAITFR(pipe_ef));
}
*statusp = info->completion;
@@ -1212,6 +1933,7 @@
_ckvmssts(sys$schdwk(0,0,interval,0));
_ckvmssts(sys$hiber());
}
+ if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
_ckvmssts(sts);
/* There's no easy way to find the termination status a child we're
--- vms/vmspipe.com-orig Mon Mar 27 11:15:50 2000
+++ vms/vmspipe.com Mon Mar 27 11:13:06 2000
@@ -0,0 +1,18 @@
+$! 'f$verify(0)
+$! --- protect against nonstandard definitions ---
+$ perl_define = "define/nolog"
+$ perl_on = "on error then exit $STATUS"
+$ 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'
+$ 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_cmd
+$ perl_on
+$ 'cmd
+$ perl_exit '$STATUS'
--
Drexel University \V --Chuck Lane
----------------->--------*------------<[EMAIL PROTECTED]
(215) 895-1545 / \ Particle Physics [EMAIL PROTECTED]
FAX: (215) 895-5934 /~~~~~~~~~~~ [EMAIL PROTECTED]
