* 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
*/
-#include <accdef.h>
#include <acedef.h>
#include <acldef.h>
#include <armdef.h>
if (thr && PL_curcop) {
#endif
if (ckWARN(WARN_MISC)) {
- Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
+ Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
}
#if defined(USE_5005THREADS)
} else {
- Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
+ Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
}
#endif
for (j = 0; environ[j]; j++) {
if (!(start = strchr(environ[j],'='))) {
if (ckWARN(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
}
else {
start++;
continue;
}
if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
if (*cp1 == '(' || /* Logical name table name */
cp1--; /* stop on last non-space char */
}
if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
- Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
continue;
}
PERL_HASH(hash,key,keylen);
ivenv = 1; retsts = SS$_NOLOGNAM;
#else
if (ckWARN(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
ivenv = 1; retsts = SS$_NOSUCHPGM;
break;
}
return setenv(lnm,eqv,1) ? vaxc$errno : 0;
#else
if (ckWARN(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
retsts = SS$_NOSUCHPGM;
#endif
}
if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
if (ckWARN(WARN_MISC)) {
- Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
+ Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
}
}
retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
}
/*}}}*/
-/*{{{static void vmssetuserlnm(char *name, char *eqv);
+/*{{{static void vmssetuserlnm(char *name, char *eqv); */
/* vmssetuserlnm
* sets a user-mode logical in the process logical name table
* used for redirection of sys$error
#ifdef KILL_BY_SIGPRC
#include <errnodef.h>
-/* okay, this is some BLATENT hackery ...
- we use this if the kill() in the CRTL uses sys$forcex, causing the
+/* We implement our own kill() using the undocumented system service
+ sys$sigprc for one of two reasons:
+
+ 1.) If the kill() in an older CRTL uses sys$forcex, causing the
target process to do a sys$exit, which usually can't be handled
gracefully...certainly not by Perl and the %SIG{} mechanism.
- Instead we use the (undocumented) system service sys$sigprc.
- It has the same parameters as sys$forcex, but throws an exception
+ 2.) If the kill() in the CRTL can't be called from a signal
+ handler without disappearing into the ether, i.e., the signal
+ it purportedly sends is never trapped. Still true as of VMS 7.3.
+
+ sys$sigprc has the same parameters as sys$forcex, but throws an exception
in the target process rather than calling sys$exit.
Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
unsigned long int exit_status;
};
+typedef struct _closed_pipes Xpipe;
+typedef struct _closed_pipes* pXpipe;
+
+struct _closed_pipes {
+ int pid; /* PID of subprocess */
+ unsigned long completion; /* termination status of subprocess */
+};
+#define NKEEPCLOSED 50
+static Xpipe closed_list[NKEEPCLOSED];
+static int closed_index = 0;
+static int closed_num = 0;
+
#define RETRY_DELAY "0 ::0.20"
#define MAX_RETRY 50
{
pInfo i = open_pipes;
int iss;
+ pXpipe x;
+
+ info->completion &= 0x0FFFFFFF; /* strip off "control" field */
+ closed_list[closed_index].pid = info->pid;
+ closed_list[closed_index].completion = info->completion;
+ closed_index++;
+ if (closed_index == NKEEPCLOSED)
+ closed_index = 0;
+ closed_num++;
while (i) {
if (i == info) break;
}
if (!i) return; /* unlinked, probably freed too */
- info->completion &= 0x0FFFFFFF; /* strip off "control" field */
info->done = TRUE;
/*
safe_popen(pTHX_ char *cmd, char *in_mode, int *psts)
{
static int handler_set_up = FALSE;
- unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
+ unsigned long int sts, flags = CLI$M_NOWAIT;
unsigned int table = LIB$K_CLI_GLOBAL_SYM;
int j, wait = 0;
char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
tpipe = vmspipe_tempfile(aTHX);
if (!tpipe) { /* a fish popular in Boston */
if (ckWARN(WARN_PIPE)) {
- Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
+ Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
}
return Nullfp;
}
}
set_vaxc_errno(sts);
if (*mode != 'n' && ckWARN(WARN_PIPE)) {
- Perl_warner(aTHX_ WARN_PIPE,"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
+ Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
}
*psts = sts;
return Nullfp;
info->next=open_pipes; /* prepend to list */
open_pipes=info;
_ckvmssts(sys$setast(1));
- _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
+ /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
+ * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
+ * have SYS$COMMAND if we need it.
+ */
+ _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
0, &info->pid, &info->completion,
0, popen_completion_ast,info,0,0,0));
pInfo info;
int done;
int sts;
+ int j;
if (statusp) *statusp = 0;
if (statusp) *statusp = info->completion;
return pid;
+ }
+
+ /* child that already terminated? */
+ for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
+ if (closed_list[j].pid == pid) {
+ if (statusp) *statusp = closed_list[j].completion;
+ return pid;
+ }
}
- else { /* this child is not one of our own pipe children */
+
+ /* fall through if this child is not one of our own pipe children */
#if defined(__CRTL_VER) && __CRTL_VER >= 70100322
#endif /* defined(__CRTL_VER) && __CRTL_VER >= 70100322 */
+ {
$DESCRIPTOR(intdsc,"0 00:00:01");
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] = {
+ struct itmlst_3 jpilist[2] = {
{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
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.
+ /* Get the owner of the child so I can warn if it's not mine. 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];
/* 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,
+ Perl_warner(aTHX_ packWARN(WARN_EXEC),
"waitpid: process %x is not a child of process %x",
pid,mypid);
}
- /* 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 the process doesn't have a termination mailbox, then simply check
- * on it once a second until it's not there anymore.
- */
- if (termination_mbu == 0) {
- _ckvmssts(sys$bintim(&intdsc,interval));
- while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
+ /* simply check on it once a second until it's not there anymore. */
+
+ _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 ? */
+ }
+ if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
_ckvmssts(sts);
return pid;
-
- } /* else one of our own pipe children */
-
+ }
} /* end of waitpid() */
/*}}}*/
/*}}}*/
if (do_tovmspath(name,dir,0) == NULL) {
return NULL;
}
+ /* Check access before stat; otherwise stat does not
+ * accurately report whether it's a directory.
+ */
+ if (!cando_by_name(S_IRUSR,0,dir)) {
+ set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
+ return NULL;
+ }
if (flex_stat(dir,&sb) == -1) return NULL;
if (!S_ISDIR(sb.st_mode)) {
set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
return NULL;
}
- if (!cando_by_name(S_IRUSR,0,dir)) {
- set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
- return NULL;
- }
/* Get memory for the handle, and the pattern. */
New(1306,dd,1,DIR);
New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
}
set_vaxc_errno(retsts);
if (ckWARN(WARN_EXEC)) {
- Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
+ Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
}
vms_execfree(vmscmd);
}
set_vaxc_errno(sts);
if (ckWARN(WARN_EXEC)) {
- Perl_warner(aTHX_ WARN_EXEC,"Can't spawn: %s",
+ Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
Strerror(errno));
}
}
union prvdef curprv;
struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
{sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
- struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
+ struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
+ {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
+ {0,0,0,0}};
+ struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
{0,0,0,0}};
+ struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
if (!fname || !*fname) return FALSE;
/* Make sure we expand logical names, since sys$check_access doesn't */
namdsc.dsc$a_pointer = fileified;
}
- if (!usrdsc.dsc$w_length) {
- cuserid(usrname);
- usrdsc.dsc$w_length = strlen(usrname);
- }
-
switch (bit) {
case S_IXUSR: case S_IXGRP: case S_IXOTH:
access = ARM$M_EXECUTE; break;
return FALSE;
}
- retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
+ /* Before we call $check_access, create a user profile with the current
+ * process privs since otherwise it just uses the default privs from the
+ * UAF and might give false positives or negatives.
+ */
+
+ /* get current process privs and username */
+ _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
+ _ckvmssts(iosb[0]);
+
+ /* find out the space required for the profile */
+ _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
+ &usrprodsc.dsc$w_length,0));
+
+ /* allocate space for the profile and get it filled in */
+ New(1330,usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
+ _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
+ &usrprodsc.dsc$w_length,0));
+
+ /* use the profile to check access to the file; free profile & analyze results */
+ retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
+ Safefree(usrprodsc.dsc$a_pointer);
+ if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
else set_errno(ENOENT);
return FALSE;
}
- if (retsts == SS$_NORMAL) {
- if (!privused) return TRUE;
- /* We can get access, but only by using privs. Do we have the
- necessary privs currently enabled? */
- _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
- if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
- if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
- !curprv.prv$v_bypass) return FALSE;
- if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
- !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
- if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
- return TRUE;
- }
- if (retsts == SS$_ACCONFLICT) {
+ if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
return TRUE;
}
_ckvmssts(retsts);
char fileified[NAM$C_MAXRSS+1];
char temp_fspec[NAM$C_MAXRSS+300];
int retval = -1;
+ int saved_errno, saved_vaxc_errno;
if (!fspec) return retval;
+ saved_errno = errno; saved_vaxc_errno = vaxc$errno;
strcpy(temp_fspec, fspec);
if (statbufp == (Stat_t *) &PL_statcache)
do_tovmsspec(temp_fspec,namecache,0);
}
# endif
}
+ /* If we were successful, leave errno where we found it */
+ if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
return retval;
} /* end of flex_stat() */
projects / p5sagit/p5-mst-13.2.git / blobdiff