* 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
*/
+#include <accdef.h>
#include <acedef.h>
#include <acldef.h>
#include <armdef.h>
#include <libdef.h>
#include <lib$routines.h>
#include <lnmdef.h>
+#include <msgdef.h>
#include <prvdef.h>
#include <psldef.h>
#include <rms.h>
/* fully initialized, in which case either thr or PL_curcop */
/* might be bogus. We have to check, since ckWARN needs them */
/* both to be valid if running threaded */
-#if defined(USE_THREADS)
+#if defined(USE_5005THREADS)
if (thr && PL_curcop) {
#endif
if (ckWARN(WARN_MISC)) {
Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
}
-#if defined(USE_THREADS)
+#if defined(USE_5005THREADS)
} else {
Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
}
{
static int primed = 0;
HV *seenhv = NULL, *envhv;
+ SV *sv = NULL;
char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
unsigned short int chan;
#ifndef CLI$M_TRUSTED
#if defined(PERL_IMPLICIT_CONTEXT)
pTHX;
#endif
-#if defined(USE_THREADS) || defined(USE_ITHREADS)
+#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
static perl_mutex primenv_mutex;
MUTEX_INIT(&primenv_mutex);
#endif
}
else {
start++;
- (void) hv_store(envhv,environ[j],start - environ[j] - 1,
- newSVpv(start,0),0);
+ sv = newSVpv(start,0);
+ SvTAINTED_on(sv);
+ (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
}
}
continue;
continue;
}
PERL_HASH(hash,key,keylen);
- hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
+ sv = newSVpvn(cp2,cp1 - cp2 + 1);
+ SvTAINTED_on(sv);
+ hv_store(envhv,key,keylen,sv,hash);
hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
}
if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
int trnlen, i;
for (i = 0; ppfs[i]; i++) {
trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
- hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
+ sv = newSVpv(eqv,trnlen);
+ SvTAINTED_on(sv);
+ hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
}
}
}
} /* 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;
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() */
/*}}}*/
dir[--dirlen] = '\0';
dir[dirlen-1] = ']';
}
+ if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) {
+ dir[--dirlen] = '\0';
+ dir[dirlen-1] = '>';
+ }
if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
/* If we've got an explicit filename, we can just shuffle the string. */
else if (ts) New(1312,retspec,retlen+16,char);
else retspec = __fileify_retbuf;
cp1 = strstr(esa,"][");
+ if (!cp1) cp1 = strstr(esa,"]<");
dirlen = cp1 - esa;
memcpy(retspec,esa,dirlen);
if (!strncmp(cp1+2,"000000]",7)) {
if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
getredirection(argcp,argvp);
-#if defined(USE_THREADS) && ( defined(__DECC) || defined(__DECCXX) )
+#if defined(USE_5005THREADS) && ( defined(__DECC) || defined(__DECCXX) )
{
# include <reentrancy.h>
(void) decc$set_reentrancy(C$C_MULTITHREAD);
char temp_fspec[NAM$C_MAXRSS+300];
int retval = -1;
+ if (!fspec) return retval;
strcpy(temp_fspec, fspec);
if (statbufp == (Stat_t *) &PL_statcache)
do_tovmsspec(temp_fspec,namecache,0);
}
void
+hushexit_fromperl(pTHX_ CV *cv)
+{
+ dXSARGS;
+
+ if (items > 0) {
+ VMSISH_HUSHED = SvTRUE(ST(0));
+ }
+ ST(0) = boolSV(VMSISH_HUSHED);
+ XSRETURN(1);
+}
+
+void
+Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
+ struct interp_intern *dst)
+{
+ memcpy(dst,src,sizeof(struct interp_intern));
+}
+
+void
+Perl_sys_intern_clear(pTHX)
+{
+}
+
+void
+Perl_sys_intern_init(pTHX)
+{
+ int ix = RAND_MAX;
+ float x;
+
+ VMSISH_HUSHED = 0;
+
+ x = (float)ix;
+ MY_INV_RAND_MAX = 1./x;
+}
+
+
+
+void
init_os_extras()
{
dTHX;
newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
+ newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
store_pipelocs(aTHX);