if (strNE(name,"-"))
TAINT_ENV();
TAINT_PROPER("piped open");
- if (dowarn && name[strlen(name)-1] == '|')
- warn("Can't do bidirectional pipe");
+ if (name[strlen(name)-1] == '|') {
+ name[strlen(name)-1] = '\0' ;
+ if (dowarn)
+ warn("Can't do bidirectional pipe");
+ }
fp = PerlProc_popen(name,"w");
writing = 1;
}
if (!io) { /* never opened */
if (dowarn && not_implicit)
warn("Close on unopened file <%s>",GvENAME(gv));
+ SETERRNO(EBADF,SS$_IVCHAN);
return FALSE;
}
retval = io_close(io);
}
IoOFP(io) = IoIFP(io) = Nullfp;
}
+ else {
+ SETERRNO(EBADF,SS$_IVCHAN);
+ }
return retval;
}
return -1L;
}
+int
+do_binmode(PerlIO *fp, int iotype, int flag)
+{
+ if (flag != TRUE)
+ croak("panic: unsetting binmode"); /* Not implemented yet */
+#ifdef DOSISH
+#ifdef atarist
+ if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN))
+ return 1;
+ else
+ return 0;
+#else
+ if (PerlLIO_setmode(PerlIO_fileno(fp), OP_BINARY) != -1) {
+#if defined(WIN32) && defined(__BORLANDC__)
+ /* The translation mode of the stream is maintained independent
+ * of the translation mode of the fd in the Borland RTL (heavy
+ * digging through their runtime sources reveal). User has to
+ * set the mode explicitly for the stream (though they don't
+ * document this anywhere). GSAR 97-5-24
+ */
+ PerlIO_seek(fp,0L,0);
+ fp->flags |= _F_BIN;
+#endif
+ return 1;
+ }
+ else
+ return 0;
+#endif
+#else
+#if defined(USEMYBINMODE)
+ if (my_binmode(fp,iotype) != NULL)
+ return 1;
+ else
+ return 0;
+#else
+ return 1;
+#endif
+#endif
+}
+
#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
/* code courtesy of William Kucharski */
#define HAS_CHSIZE
GV* tmpgv;
if (op->op_flags & OPf_REF) {
- EXTEND(sp,1);
+ EXTEND(SP,1);
tmpgv = cGVOP->op_gv;
do_fstat:
io = GvIO(tmpgv);
djSP;
SV *sv;
if (op->op_flags & OPf_REF) {
- EXTEND(sp,1);
+ EXTEND(SP,1);
if (cGVOP->op_gv == defgv) {
if (laststype != OP_LSTAT)
croak("The stat preceding -l _ wasn't an lstat");
register I32 val;
register I32 val2;
register I32 tot = 0;
+ char *what;
char *s;
SV **oldmark = mark;
+#define APPLY_TAINT_PROPER() \
+ if (!(tainting && tainted)) {} else { goto taint_proper; }
+
+ /* This is a first heuristic; it doesn't catch tainting magic. */
if (tainting) {
while (++mark <= sp) {
if (SvTAINTED(*mark)) {
}
switch (type) {
case OP_CHMOD:
- TAINT_PROPER("chmod");
+ what = "chmod";
+ APPLY_TAINT_PROPER();
if (++mark <= sp) {
- tot = sp - mark;
val = SvIVx(*mark);
+ APPLY_TAINT_PROPER();
+ tot = sp - mark;
while (++mark <= sp) {
- if (PerlLIO_chmod(SvPVx(*mark, na),val))
+ char *name = SvPVx(*mark, na);
+ APPLY_TAINT_PROPER();
+ if (PerlLIO_chmod(name, val))
tot--;
}
}
break;
#ifdef HAS_CHOWN
case OP_CHOWN:
- TAINT_PROPER("chown");
+ what = "chown";
+ APPLY_TAINT_PROPER();
if (sp - mark > 2) {
val = SvIVx(*++mark);
val2 = SvIVx(*++mark);
+ APPLY_TAINT_PROPER();
tot = sp - mark;
while (++mark <= sp) {
- if (chown(SvPVx(*mark, na),val,val2))
+ char *name = SvPVx(*mark, na);
+ APPLY_TAINT_PROPER();
+ if (chown(name, val, val2))
tot--;
}
}
#endif
#ifdef HAS_KILL
case OP_KILL:
- TAINT_PROPER("kill");
+ what = "kill";
+ APPLY_TAINT_PROPER();
if (mark == sp)
break;
s = SvPVx(*++mark, na);
- tot = sp - mark;
if (isUPPER(*s)) {
if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
s += 3;
}
else
val = SvIVx(*mark);
+ APPLY_TAINT_PROPER();
+ tot = sp - mark;
#ifdef VMS
/* kill() doesn't do process groups (job trees?) under VMS */
if (val < 0) val = -val;
while (++mark <= sp) {
I32 proc = SvIVx(*mark);
register unsigned long int __vmssts;
+ APPLY_TAINT_PROPER();
if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
tot--;
switch (__vmssts) {
val = -val;
while (++mark <= sp) {
I32 proc = SvIVx(*mark);
+ APPLY_TAINT_PROPER();
#ifdef HAS_KILLPG
if (PerlProc_killpg(proc,val)) /* BSD */
#else
}
else {
while (++mark <= sp) {
- if (PerlProc_kill(SvIVx(*mark),val))
+ I32 proc = SvIVx(*mark);
+ APPLY_TAINT_PROPER();
+ if (PerlProc_kill(proc, val))
tot--;
}
}
break;
#endif
case OP_UNLINK:
- TAINT_PROPER("unlink");
+ what = "unlink";
+ APPLY_TAINT_PROPER();
tot = sp - mark;
while (++mark <= sp) {
s = SvPVx(*mark, na);
+ APPLY_TAINT_PROPER();
if (euid || unsafe) {
if (UNLINK(s))
tot--;
break;
#ifdef HAS_UTIME
case OP_UTIME:
- TAINT_PROPER("utime");
+ what = "utime";
+ APPLY_TAINT_PROPER();
if (sp - mark > 2) {
#if defined(I_UTIME) || defined(VMS)
struct utimbuf utbuf;
utbuf.actime = SvIVx(*++mark); /* time accessed */
utbuf.modtime = SvIVx(*++mark); /* time modified */
#endif
+ APPLY_TAINT_PROPER();
tot = sp - mark;
while (++mark <= sp) {
- if (PerlLIO_utime(SvPVx(*mark, na),&utbuf))
+ char *name = SvPVx(*mark, na);
+ APPLY_TAINT_PROPER();
+ if (PerlLIO_utime(name, &utbuf))
tot--;
}
}
#endif
}
return tot;
+
+ taint_proper:
+ TAINT_PROPER(what);
+ return 0; /* this should never happen */
+
+#undef APPLY_TAINT_PROPER
}
/* Do the permissions allow some operation? Assumes statcache already set. */
return -1; /* should never happen */
}
+#if defined(__sun) && defined(__svr4__) /* XXX Need metaconfig test */
+/* Solaris manpage says that it uses (like linux)
+ int semctl (int semid, int semnum, int cmd, union semun arg)
+ but the system include files do not define union semun !!!!
+*/
+union semun {
+ int val;
+ struct semid_ds *buf;
+ ushort *array;
+};
+#endif
+
I32
do_ipcctl(I32 optype, SV **mark, SV **sp)
{
char *a;
I32 id, n, cmd, infosize, getinfo;
I32 ret = -1;
-#ifdef __linux__ /* XXX Need metaconfig test */
+#if defined(__linux__) || (defined(__sun) && defined(__svr4__))
+/* XXX Need metaconfig test */
union semun unsemds;
#endif
else if (cmd == GETALL || cmd == SETALL)
{
struct semid_ds semds;
-#ifdef __linux__ /* XXX Need metaconfig test */
-/* linux (and Solaris2?) uses :
+#if defined(__linux__) || (defined(__sun) && defined(__svr4__))
+ /* XXX Need metaconfig test */
+/* linux and Solaris2 uses :
int semctl (int semid, int semnum, int cmd, union semun arg)
union semun {
int val;
#endif
#ifdef HAS_SEM
case OP_SEMCTL:
-#ifdef __linux__ /* XXX Need metaconfig test */
+#if defined(__linux__) || (defined(__sun) && defined(__svr4__))
+ /* XXX Need metaconfig test */
unsemds.buf = (struct semid_ds *)a;
ret = semctl(id, n, cmd, unsemds);
#else