* 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);
}
}
}
}
/*}}}*/
+
+#ifndef HOMEGROWN_POSIX_SIGNALS
+/*
+ * The C RTL's sigaction fails to check for invalid signal numbers so we
+ * help it out a bit. The docs are correct, but the actual routine doesn't
+ * do what the docs say it will.
+ */
+/*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
+int
+Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
+ struct sigaction* oact)
+{
+ if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
+ SETERRNO(EINVAL, SS$_INVARG);
+ return -1;
+ }
+ return sigaction(sig, act, oact);
+}
+/*}}}*/
+#endif
+
/* default piping mailbox size */
#define PERL_BUFSIZ 512
vmspipedsc.dsc$a_pointer = tfilebuf;
vmspipedsc.dsc$w_length = strlen(tfilebuf);
- if (!(setup_cmddsc(aTHX_ cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
+ sts = setup_cmddsc(aTHX_ cmd,0);
+ if (!(sts & 1)) {
+ switch (sts) {
+ case RMS$_FNF: case RMS$_DNF:
+ set_errno(ENOENT); break;
+ case RMS$_DIR:
+ set_errno(ENOTDIR); break;
+ case RMS$_DEV:
+ set_errno(ENODEV); break;
+ case RMS$_PRV:
+ set_errno(EACCES); break;
+ case RMS$_SYN:
+ set_errno(EINVAL); break;
+ case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
+ set_errno(E2BIG); break;
+ case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
+ _ckvmssts(sts); /* fall through */
+ default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
+ set_errno(EVMSERR);
+ }
+ set_vaxc_errno(sts);
+ if (ckWARN(WARN_PIPE)) {
+ Perl_warner(aTHX_ WARN_PIPE,"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
+ }
+ return Nullfp;
+ }
New(1301,info,1,Info);
info->mode = *mode;
} /* 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);
} /* end of setup_argstr() */
+#define MAX_DCL_LINE_LENGTH 255
static unsigned long int
setup_cmddsc(pTHX_ char *cmd, int check_img)
register char *s, *rest, *cp, *wordbreak;
register int isdcl;
- if (strlen(cmd) >
- (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
- return LIB$_INVARG;
+ if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
+ return CLI$_BUFOVF; /* continuation lines currently unsupported */
s = cmd;
while (*s && isspace(*s)) s++;
if (cando_by_name(S_IXUSR,0,resspec)) {
New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
if (!isdcl) {
- strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
+ strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
} else {
strcpy(VMScmd.dsc$a_pointer,"@");
}
strcat(VMScmd.dsc$a_pointer,resspec);
if (rest) strcat(VMScmd.dsc$a_pointer,rest);
VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
- return retsts;
+ return (VMScmd.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
}
else retsts = RMS$_PRV;
}
else { _ckvmssts(retsts); }
}
- return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
+ return (VMScmd.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
} /* end of setup_cmddsc() */
set_errno(EACCES); break;
case RMS$_SYN:
set_errno(EINVAL); break;
- case CLI$_BUFOVF:
+ case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
set_errno(E2BIG); break;
case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
_ckvmssts(retsts); /* fall through */
hadcmd = 0;
sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
}
- else if ((sts = setup_cmddsc(aTHX_ cmd,0)) & 1) {
- sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
+ else {
+ sts = setup_cmddsc(aTHX_ cmd,0);
+ if (sts & 1) {
+ sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
+ } else {
+ substs = sts; /* didn't spawn, use command setup failure for return */
+ }
}
if (!(sts & 1)) {
set_errno(EACCES); break;
case RMS$_SYN:
set_errno(EINVAL); break;
- case CLI$_BUFOVF:
+ case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
set_errno(E2BIG); break;
case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
_ckvmssts(sts); /* fall through */
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);
store_pipelocs(aTHX);
+#ifdef Drand01_is_rand
+/* this hackery brought to you by a bug in DECC for /ieee=denorm */
+ {
+ int ix = RAND_MAX;
+ float x = (float)ix;
+ PL_my_inv_rand_max = 1./x;
+ }
+#endif
+
return;
}
projects / p5sagit/p5-mst-13.2.git / blobdiff