Okay,
"Though I've beaten you and flayed you
by the living hacks that made you
you're a better piece of code, VMS Perl."
Time to get this off of my desk and out where the rest of you can find all
the bugs and misfeatures :-) I applied this patch to a fresh copy
of pre56-3, adding other patches for this and that, and it build with
no errors and the test suite shows errors in
lib/vmsfspec
lib/filespec
(both known, and nothing to do with piping).
While my last "progress report" post on the subject laid out just about
all of the major issues, there's a couple of little nitty gritty bits that
didn't get mentioned...
When doing the piping, I use a wrapper file VMSPIPE.COM...that file has
to be put in place early in the build so that MINIPERL can find it; and
since we find it with PERL_ROOT, we need to define PERL_ROOT either before
or early in the build. A bit of tricky DCL in a .FIRST section of
DESCRIP.MMS does this.
To make the "installperl." stuff simpler, I'm putting VMSPIPE in
PERL_ROOT:[000000] at the same time that we install executables there,
rather than in PERL_ROOT:[LIB]. I doubt the change is significant.
Dan, I *think* the only place changes are needed to accomodate threading
are where we have "one time initialization" stuff:
static int initted = 0;
if (!initted) {
initted = 1;
....blah blah blah...
}
(actually unlikely to cause a problem, but I feel better when there's NO
possibility of a race condition). Can you point me to relevant code for
handling this? Something like:
static int initted = 0;
if (!initted) {
_global_lock_this_bit();
if (!initted) {
initted = 1;
....blah blah blah...
}
_global_unlock_this_bit();
}
I can find suitable pthreads calls, but threads in Perl has it's own
peculiar idiom....
Patch follows:
--- installperl.orig Fri Mar 10 12:44:30 2000
+++ installperl Fri Mar 10 12:44:12 2000
@@ -183,6 +183,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
--- t/io/openpid.t-orig Fri Mar 3 12:29:12 2000
+++ t/io/openpid.t Fri Mar 3 12:29:02 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 Wed Mar 8 18:44:56 2000
+++ vms/descrip_mms.template Fri Mar 10 12:44:12 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/vms.c-orig Fri Mar 3 11:01:39 2000
+++ vms/vms.c Fri Mar 10 12:45:22 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>
@@ -898,19 +910,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));
@@ -918,15 +946,48 @@
} /* 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;
+
+struct _iosb {
+ unsigned short status;
+ unsigned short count;
+ unsigned long dvispec;
+};
+
+
+struct _pipe {
+ int done;
+ int fd_out;
+ unsigned short chan_in;
+ unsigned short chan_out;
+ char *buf;
+ unsigned int bufsize;
+ IOSB iosb;
+ int retry;
+ int type;
+ pPipe *home;
+ pInfo info;
+};
+
+
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 */
+ int closing; /* my_pclose is closing this pipe */
unsigned long int completion; /* termination status of subprocess */
+ pPipe in, out, err;
};
struct exit_control_block
@@ -938,45 +999,36 @@
unsigned long int exit_status;
};
-static struct pipe_details *open_pipes = NULL;
+
+
+static pInfo open_pipes = NULL;
static $DESCRIPTOR(nl_desc, "NL:");
-static int waitpid_asleep = 0;
/* 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)
+pipe_eof(pInfo info)
{
- 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};
+ unsigned long int retsts = SS$_NOIOCHAN;
dTHX;
- 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;
+ _ckvmssts(SYS$SETAST(0));
+ if (info->mode == 'w' && info->in) {
+ retsts = sys$qio(0,info->in->chan_in,IO$_WRITEOF|IO$M_NOW|IO$M_NORSWAIT,
+ 0,0,0,0,0,0,0,0,0);
}
- else _ckvmssts(vaxc$errno); /* Should never happen */
- return (unsigned long int) vaxc$errno;
+ _ckvmssts(SYS$SETAST(1));
+
+ return retsts;
}
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;
/*
@@ -987,12 +1039,8 @@
info = open_pipes;
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->mode != 'r') {
+ if (pipe_eof(info) & 1) did_stuff = 1;
}
info = info->next;
}
@@ -1031,76 +1079,483 @@
return retsts;
}
+static int pipe_ef = 0;
+static unsigned long mypid;
+
static struct exit_control_block pipe_exitblock =
{(struct exit_control_block *) 0,
pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
+static void
+pipe_mbxtofd_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;
+ while (i) {
+ if (i == info) break;
+ i = i->next;
}
+ if (!i) return; /* unlinked, probably freed too */
+
+ info->done = TRUE;
+ info->completion &= 0x0FFFFFFF; /* strip off "control" field */
+
+/*
+ reading from subprocess ... put an EOF in the pipe from subproc to
+ us to tell the piping code to shut down
+*/
+ if (info->mode == 'r') {
+ _ckvmssts(SYS$QIO(0,info->out->chan_in,IO$_WRITEOF|IO$M_NOW|IO$M_NORSWAIT, 0, 0,
+0, 0, 0, 0, 0, 0, 0));
+ info->out->done = TRUE;
+ }
+/*
+ writing to subprocess ... two situations:
+ my_pclose already called: EOF has been sent, all i/o from us done
+ my_pclose not called yet: snarf all further output
+ any output from subprocess (stdout, stderr) needs to be flushed and
+ shut down.
+
+*/
+ else
+ {
+ if (info->closing) { /* my_pclose already called, no snarf */
+ _ckvmssts(SYS$DASSGN(info->in->chan_in));
+ Safefree(info->in->buf);
+ Safefree(info->in);
+ info->in = 0;
+ } else { /* my_pclose not called, start snarf of i/o */
+ info->in->done = TRUE;
+ _ckvmssts(SYS$QIO(0,info->in->chan_in,IO$_READVBLK,&info->in->iosb,
+ pipe_mbxtofd_ast, info->in,
+ info->in->buf, info->in->bufsize, 0,0,0,0));
+ }
+
+ if (info->out) { /* we were also piping output */
+ info->out->done = TRUE;
+ _ckvmssts(SYS$QIO(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0,
+0, 0, 0, 0, 0));
+ }
+ }
+ if (info->err) { /* we were piping stderr */
+ info->err->done = TRUE;
+ _ckvmssts(SYS$QIO(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0,
+0, 0, 0, 0, 0));
+ }
+ _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 RETRY_DELAY "0 ::0.20"
+#define MAX_RETRY 50
+#define MAX_DCL_SYMBOL 255
+static void pipe_infromchild_ast(pPipe p);
+
+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->type = 2;
+ p->done = FALSE;
+ 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, type = p->type;
+
+ if (type == 1) { /* got data, write it out */
+ if (iss == SS$_CANCEL || iss == SS$_ABORT) {
+ goto shutdown;
+ } else if (iss == SS$_ENDOFFILE) {
+ if (p->iosb.dvispec == mypid) { /* EOF at subproc completion */
+ if (!p->info->closing) {
+ _ckvmssts(SYS$QIO(0,p->chan_out,IO$_WRITEOF, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0));
+ }
+ goto shutdown;
+ } else if (p->iosb.dvispec == p->info->pid) { /* ah, it's the kid */
+ p->type = 2;
+ if (p->info->closing) {
+ type = 2;
+ iss = SS$_NORMAL;
+ } else {
+ _ckvmssts(SYS$QIO(0,p->chan_out,IO$_WRITEOF, &p->iosb,
+ pipe_infromchild_ast,p,
+ 0, 0, 0, 0, 0, 0));
+ }
+ } else { /* a grandkid? ignore */
+ type = 2; /* go back to reading */
+ iss = SS$_NORMAL;
+ }
+ } else if (!(iss&1)) {
+ _ckvmssts(iss);
+ } else {
+ p->type = 2;
+ if (p->info->closing) {
+ type = 2; /* skip to read */
+ } else {
+ _ckvmssts(SYS$QIO(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
+ pipe_infromchild_ast,p,
+ p->buf, p->iosb.count, 0, 0, 0, 0));
+ }
+ }
+ }
+
+ if (type == 2) { /* read from input */
+ if (iss == SS$_CANCEL || iss == SS$_ABORT) {
+ goto shutdown;
+ } else if (!(iss&1)) {
+ _ckvmssts(iss);
+ } else {
+ p->type = 1;
+ _ckvmssts(SYS$QIO(0,p->chan_in,IO$_READVBLK,&p->iosb,
+ pipe_infromchild_ast,p,
+ p->buf, p->bufsize, 0, 0, 0, 0));
+ }
+ }
+ return;
+
+shutdown:
+ iss = SYS$DASSGN(p->chan_in);
+ iss = SYS$DASSGN(p->chan_out);
+ Safefree(p->buf);
+ *p->home = 0;
+ Safefree(p);
+}
+
+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 = fd ? dup(fd) : 0;
+ 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->done = FALSE;
+ p->retry = 0;
+ strcpy(out, mbx);
+
+ if (fd) { /* only read in fd=0 if snarfing, later */
+ _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 iss2, snarf = (p->fd_out == 0);
+ int eof = (iss == SS$_ENDOFFILE);
+ int myeof = eof && (p->iosb.dvispec == mypid);
+ int err = !(iss&1) && !eof;
+ int done = p->done;
+ static int initted = 0;
+ static unsigned long delaytime[2];
+
+ if (snarf && done && myeof) { /* end snarfing */
+ SYS$DASSGN(p->chan_in);
+ Safefree(p->buf);
+ *p->home = 0;
+ Safefree(p);
+ _ckvmssts(SYS$SETEF(pipe_ef));
+ return;
+ }
+
+ if (!snarf && !err && !eof) { /* fd!=0 -> send to file */
+ p->buf[p->iosb.count] = '\n';
+ iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
+ if (iss2 < 0) {
+ if (!initted) {
+ $DESCRIPTOR(d_delay, RETRY_DELAY);
+ _ckvmssts(SYS$BINTIM(&d_delay, delaytime));
+ initted = 1;
+ }
+ 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);
+ }
+
+ /* done && myeof (nonsnarfing) means we've reached the end of
+ the input stream, shut down...otherwise keep piping */
+
+
+ if (snarf || !(done && myeof)) {
+ _ckvmssts(SYS$QIO(0, p->chan_in, IO$_READVBLK, &p->iosb,
+ pipe_mbxtofd_ast, p,
+ p->buf, p->bufsize, 0, 0, 0, 0));
+ }
+
+ if (!snarf && done && myeof) {
+ if (p->fd_out) {
+ fsync(p->fd_out);
+ close(p->fd_out);
+ }
+ SYS$DASSGN(p->chan_in);
+ Safefree(p->buf);
+ *p->home = 0;
+ Safefree(p);
+ _ckvmssts(SYS$SETEF(pipe_ef));
+ }
+}
+
+
+
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_out,"PERL_POPEN_OUT");
+ $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
+
+ /* we use an event flag for synchronization */
+
+
+ if (!pipe_ef) {
+ unsigned long int pidcode = JPI$_PID;
+ _ckvmssts(lib$get_ef(&pipe_ef));
+ _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
+ }
if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
- New(1301,info,1,struct pipe_details);
-
- /* create mailbox */
- create_mbx(&chan,&namdsc);
-
- /* open a FILE* onto it */
- info->fp = PerlIO_open(mbxname, mode);
-
- /* give up other channel onto it */
- _ckvmssts(sys$dassgn(chan));
-
- if (!info->fp)
- return Nullfp;
+ New(1301,info,1,Info);
info->mode = *mode;
info->done = FALSE;
info->completion=0;
+ info->closing = 0;
+ info->in = 0;
+ info->out = 0;
+ info->err = 0;
+
+ if (*mode == 'r') { /* piping from subroutine */
+ in[0] = '\0';
+
+ info->out = pipe_infromchild_setup(mbx,out);
+ info->out->home = &info->out;
+ info->out->info = info;
+ info->fp = PerlIO_open(mbx, mode);
+ if (!info->fp) {
+ SYS$CANCEL(info->out->chan_out);
+ Safefree(info);
+ return Nullfp;
+ }
- 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));
+ info->err = pipe_mbxtofd_setup(fileno(stderr), err);
+ if (info->err) {
+ info->err->home = &info->err;
+ info->err->info = info;
+ }
+
+ } else { /* piping to subroutine */
+ int melded;
+
+ info->in = pipe_mbxtofd_setup(0, in);
+ info->in->home = &info->in;
+ info->in->info = info;
+ info->fp = PerlIO_open(in, mode);
+ if (!info->fp) {
+ Safefree(info->in->buf);
+ Safefree(info->in);
+ Safefree(info);
+ 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;
+ }
}
- else {
- _ckvmssts(lib$spawn(&VMScmd, &namdsc, 0 /* sys$output */, &flags,
- 0 /* name */, &info->pid, &info->completion,
- 0, popen_completion_ast,info,0,0,0));
}
+ info->out = pipe_mbxtofd_setup(fileno(stdout), out);
+ if (info->out) {
+ info->out->home = &info->out;
+ info->out->info = info;
+ }
+ if (!melded) {
+ info->err = pipe_mbxtofd_setup(fileno(stderr), err);
+ if (info->err) {
+ info->err->home = &info->err;
+ 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, "", MAX_DCL_SYMBOL); /* set in lib$spawn */
+ d_symbol.dsc$w_length = strlen(symbol);
+ _ckvmssts(LIB$SET_SYMBOL(&d_sym_out, &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_out, &table));
+ _ckvmssts(LIB$DELETE_SYMBOL(&d_sym_err, &table));
+
vms_execfree();
if (!handler_set_up) {
_ckvmssts(sys$dclexh(&pipe_exitblock));
handler_set_up = TRUE;
}
- info->next=open_pipes; /* prepend to list */
- open_pipes=info;
PL_forkprocess = info->pid;
return info->fp;
@@ -1122,9 +1577,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;
for (info = open_pipes; info != NULL; last = info, info = info->next)
if (info->fp == fp) break;
@@ -1138,14 +1593,22 @@
/* 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;
+ info->closing = TRUE;
+ done = (info->in == 0) && info->done;
_ckvmssts(SYS$SETAST(1));
- if (need_eof) pipe_eof(info->fp,0);
+ if (info->mode == 'w' && !done) pipe_eof(info);
PerlIO_close(info->fp);
- if (info->done) retsts = info->completion;
- else waitpid(info->pid,(int *) &retsts,0);
+ while (!done) { /* wait until complete & all data snarfed */
+ _ckvmssts(SYS$SETAST(0));
+ done = (info->in == 0) && info->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));
@@ -1163,7 +1626,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)
@@ -1171,8 +1635,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;
--- vms/vmspipe.com-orig Mon Mar 6 06:47:50 2000
+++ vms/vmspipe.com Thu Mar 9 03:44:00 2000
@@ -0,0 +1,20 @@
+$! 'f$verify(0)
+$! --- protect against nonstandard definitions ---
+$ perl_define = "define/nolog"
+$ perl_noon = "set noon"
+$ perl_exit = "exit"
+$ perl_del = "delete"
+$ pif = "if"
+$ pif perl_popen_in .nes. "" then perl_define sys$input 'perl_popen_in'
+$ pif perl_popen_out .nes. "" then perl_define sys$output 'perl_popen_out'
+$ pif perl_popen_err .nes. "" then perl_define sys$error 'perl_popen_err'
+$ cmd = perl_popen_cmd
+$!
+$ perl_del/symbol/global perl_popen_in
+$ perl_del/symbol/global perl_popen_out
+$ perl_del/symbol/global perl_popen_err
+$ perl_del/symbol/global perl_popen_cmd
+$ perl_noon
+$ 'cmd
+$ perl_status = $STATUS
+$ perl_exit 'perl_status'
--- manifest.orig Fri Mar 10 16:04:47 2000
+++ manifest Fri Mar 10 16:04:35 2000
@@ -1532,6 +1532,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
--
Drexel University \V --Chuck Lane
----------------->--------*------------<[EMAIL PROTECTED]
(215) 895-1545 / \ Particle Physics [EMAIL PROTECTED]
FAX: (215) 895-5934 /~~~~~~~~~~~ [EMAIL PROTECTED]
