From: Craig A. Berry Date: Mon, 17 Sep 2001 12:34:20 +0000 (-0500) Subject: waitpid enhancements for VMS X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=aeb5cf3cd3f21ab2a97faaa995fb3acef22a9f16;p=p5sagit%2Fp5-mst-13.2.git waitpid enhancements for VMS Message-Id: <5.1.0.14.0.20010916222208.0469cdf8@exchi01> p4raw-id: //depot/perl@12056 --- diff --git a/vms/vms.c b/vms/vms.c index 88cfa8e..c71f752 100644 --- a/vms/vms.c +++ b/vms/vms.c @@ -9,6 +9,7 @@ * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu */ +#include #include #include #include @@ -29,6 +30,7 @@ #include #include #include +#include #include #include #include @@ -2330,13 +2332,26 @@ I32 Perl_my_pclose(pTHX_ PerlIO *fp) } /* end of my_pclose() */ -/* sort-of waitpid; use only with popen() */ +#if defined(__CRTL_VER) && __CRTL_VER >= 70100322 + /* Roll our own prototype because we want this regardless of whether + * _VMS_WAIT is defined. + */ + __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options ); +#endif +/* sort-of waitpid; special handling of pipe clean-up for subprocesses + created with popen(); otherwise partially emulate waitpid() unless + we have a suitable one from the CRTL that came with VMS 7.2 and later. + Also check processes not considered by the CRTL waitpid(). + */ /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/ Pid_t Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags) { pInfo info; int done; + int sts; + + if (statusp) *statusp = 0; for (info = open_pipes; info != NULL; info = info->next) if (info->pid == pid) break; @@ -2350,37 +2365,140 @@ Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags) if (!done) _ckvmssts(sys$waitfr(pipe_ef)); } - *statusp = info->completion; + if (statusp) *statusp = info->completion; return pid; + } - else { /* we haven't heard of this child */ + else { /* this child is not one of our own pipe children */ + +#if defined(__CRTL_VER) && __CRTL_VER >= 70100322 + + /* waitpid() became available in the CRTL as of VMS 7.0, but only + * in 7.2 did we get a version that fills in the VMS completion + * status as Perl has always tried to do. + */ + + sts = __vms_waitpid( pid, statusp, flags ); + + if ( sts == 0 || !(sts == -1 && errno == ECHILD) ) + return sts; + + /* If the real waitpid tells us the child does not exist, we + * fall through here to implement waiting for a child that + * was created by some means other than exec() (say, spawned + * from DCL) or to wait for a process that is not a subprocess + * of the current process. + */ + +#endif /* defined(__CRTL_VER) && __CRTL_VER >= 70100322 */ + $DESCRIPTOR(intdsc,"0 00:00:01"); - unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid; - unsigned long int interval[2],sts; + unsigned long int ownercode = JPI$_OWNER, ownerpid; + unsigned long int pidcode = JPI$_PID, mypid; + unsigned long int interval[2]; + int termination_mbu = 0; + unsigned short qio_iosb[4]; + unsigned int jpi_iosb[2]; + struct itmlst_3 jpilist[3] = { + {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0}, + {sizeof(termination_mbu), JPI$_TMBU, &termination_mbu, 0}, + { 0, 0, 0, 0} + }; + char trmmbx[NAM$C_DVI+1]; + $DESCRIPTOR(trmmbxdsc,trmmbx); + struct accdef trmmsg; + unsigned short int mbxchan; + + if (pid <= 0) { + /* Sorry folks, we don't presently implement rooting around for + the first child we can find, and we definitely don't want to + pass a pid of -1 to $getjpi, where it is a wildcard operation. + */ + set_errno(ENOTSUP); + return -1; + } + + /* Get the owner of the child so I can warn if it's not mine, plus + * get the termination mailbox. If the process doesn't exist or I + * don't have the privs to look at it, I can go home early. + */ + sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL); + if (sts & 1) sts = jpi_iosb[0]; + if (!(sts & 1)) { + switch (sts) { + case SS$_NONEXPR: + set_errno(ECHILD); + break; + case SS$_NOPRIV: + set_errno(EACCES); + break; + default: + _ckvmssts(sts); + } + set_vaxc_errno(sts); + return -1; + } if (ckWARN(WARN_EXEC)) { - _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)); - _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0)); + /* remind folks they are asking for non-standard waitpid behavior */ + _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0)); if (ownerpid != mypid) - Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid); + Perl_warner(aTHX_ WARN_EXEC, + "waitpid: process %x is not a child of process %x", + pid,mypid); } - _ckvmssts(sys$bintim(&intdsc,interval)); - while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) { - _ckvmssts(sys$schdwk(0,0,interval,0)); - _ckvmssts(sys$hiber()); + /* It's possible to have a mailbox unit number but no actual mailbox; we + * check for this by assigning a channel to it, which we need anyway. + */ + if (termination_mbu != 0) { + sprintf(trmmbx, "MBA%d:", termination_mbu); + trmmbxdsc.dsc$w_length = strlen(trmmbx); + sts = sys$assign(&trmmbxdsc, &mbxchan, 0, 0); + if (sts == SS$_NOSUCHDEV) { + termination_mbu = 0; /* set up to take "no mailbox" case */ + sts = SS$_NORMAL; + } + _ckvmssts(sts); } - if (sts == SS$_NONEXPR) sts = SS$_NORMAL; - _ckvmssts(sts); - - /* There's no easy way to find the termination status a child we're - * not aware of beforehand. If we're really interested in the future, - * we can go looking for a termination mailbox, or chase after the - * accounting record for the process. + /* If the process doesn't have a termination mailbox, then simply check + * on it once a second until it's not there anymore. */ - *statusp = 0; + if (termination_mbu == 0) { + _ckvmssts(sys$bintim(&intdsc,interval)); + while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) { + _ckvmssts(sys$schdwk(0,0,interval,0)); + _ckvmssts(sys$hiber()); + } + if (sts == SS$_NONEXPR) sts = SS$_NORMAL; + } + else { + /* If we do have a termination mailbox, post reads to it until we get a + * termination message, discarding messages of the wrong type or for other + * processes. If there is a place to put the final status, then do so. + */ + sts = SS$_NORMAL; + while (sts & 1) { + memset((void *) &trmmsg, 0, sizeof(trmmsg)); + sts = sys$qiow(0,mbxchan,IO$_READVBLK,&qio_iosb,0,0, + &trmmsg,ACC$K_TERMLEN,0,0,0,0); + if (sts & 1) sts = qio_iosb[0]; + + if ( sts & 1 + && trmmsg.acc$w_msgtyp == MSG$_DELPROC + && trmmsg.acc$l_pid == pid ) { + + if (statusp) *statusp = trmmsg.acc$l_finalsts; + sts = sys$dassgn(mbxchan); + break; + } + } + } /* termination_mbu ? */ + + _ckvmssts(sts); return pid; - } + + } /* else one of our own pipe children */ } /* end of waitpid() */ /*}}}*/