#endif
#ifdef I_UTIME
-# ifdef _MSC_VER
+# if defined(_MSC_VER) || defined(__MINGW32__)
# include <sys/utime.h>
# else
# include <utime.h>
PerlIO *fp;
int fd;
int result;
+ bool was_fdopen = FALSE;
forkprocess = 1; /* assume true if no fork */
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 (dodup)
fd = PerlLIO_dup(fd);
+ else
+ was_fdopen = TRUE;
if (!(fp = PerlIO_fdopen(fd,mode))) {
if (dodup)
PerlLIO_close(fd);
else
fp = PerlIO_open(name,mode);
}
- else if (name[len-1] == '|') {
+ else if (len > 1 && name[len-1] == '|') {
name[--len] = '\0';
while (len && isSPACE(name[len-1]))
name[--len] = '\0';
sv = *av_fetch(fdpid,fd,TRUE);
(void)SvUPGRADE(sv, SVt_IV);
SvIVX(sv) = pid;
- PerlIO_close(fp);
+ if (!was_fdopen)
+ PerlIO_close(fp);
}
fp = saveifp;
(void)fchown(lastfd,fileuid,filegid);
#else
#ifdef HAS_CHOWN
- (void)chown(oldname,fileuid,filegid);
+ (void)PerlLIO_chown(oldname,fileuid,filegid);
#endif
#endif
}
/* explicit renamed to avoid C++ conflict -- kja */
bool
-#ifndef CAN_PROTOTYPE
-do_close(gv,not_implicit)
-GV *gv;
-bool not_implicit;
-#else
do_close(GV *gv, bool not_implicit)
-#endif /* CAN_PROTOTYPE */
{
bool retval;
IO *io;
if (!gv)
gv = argvgv;
if (!gv || SvTYPE(gv) != SVt_PVGV) {
- SETERRNO(EBADF,SS$_IVCHAN);
+ if (not_implicit)
+ SETERRNO(EBADF,SS$_IVCHAN);
return FALSE;
}
io = GvIO(gv);
if (!io) { /* never opened */
- if (dowarn && not_implicit)
- warn("Close on unopened file <%s>",GvENAME(gv));
+ if (not_implicit) {
+ if (dowarn)
+ 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);
+ ((FILE*)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);
}
else {
SV* sv = POPs;
+ char *s;
PUTBACK;
if (SvTYPE(sv) == SVt_PVGV) {
tmpgv = (GV*)sv;
goto do_fstat;
}
+ s = SvPV(sv, na);
statgv = Nullgv;
- sv_setpv(statname,SvPV(sv, na));
+ sv_setpv(statname, s);
laststype = OP_STAT;
- laststatval = PerlLIO_stat(SvPV(sv, na),&statcache);
- if (laststatval < 0 && dowarn && strchr(SvPV(sv, na), '\n'))
+ laststatval = PerlLIO_stat(s, &statcache);
+ if (laststatval < 0 && dowarn && strchr(s, '\n'))
warn(warn_nl, "stat");
return laststatval;
}
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() \
+ STMT_START { \
+ if (tainting && tainted) { goto taint_proper_label; } \
+ } STMT_END
+
+ /* 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 (PerlLIO_chown(name, val, val2))
tot--;
}
}
break;
#endif
+/*
+XXX Should we make lchown() directly available from perl?
+For now, we'll let Configure test for HAS_LCHOWN, but do
+nothing in the core.
+ --AD 5/1998
+*/
#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_label:
+ TAINT_PROPER(what);
+ return 0; /* this should never happen */
+
+#undef APPLY_TAINT_PROPER
}
/* Do the permissions allow some operation? Assumes statcache already set. */
char *a;
I32 id, n, cmd, infosize, getinfo;
I32 ret = -1;
-#ifdef __linux__ /* XXX Need metaconfig test */
- union semun unsemds;
-#endif
id = SvIVx(*++mark);
n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
else if (cmd == GETALL || cmd == SETALL)
{
struct semid_ds semds;
-#ifdef __linux__ /* XXX Need metaconfig test */
-/* linux (and Solaris2?) uses :
- int semctl (int semid, int semnum, int cmd, union semun arg)
- union semun {
- int val;
- struct semid_ds *buf;
- ushort *array;
- };
-*/
- union semun semun;
+ union semun semun;
+
semun.buf = &semds;
- if (semctl(id, 0, IPC_STAT, semun) == -1)
-#else
- if (semctl(id, 0, IPC_STAT, &semds) == -1)
-#endif
- return -1;
getinfo = (cmd == GETALL);
+ if (Semctl(id, 0, IPC_STAT, semun) == -1)
+ return -1;
infosize = semds.sem_nsems * sizeof(short);
/* "short" is technically wrong but much more portable
than guessing about u_?short(_t)? */
break;
#endif
#ifdef HAS_SEM
- case OP_SEMCTL:
-#ifdef __linux__ /* XXX Need metaconfig test */
- unsemds.buf = (struct semid_ds *)a;
- ret = semctl(id, n, cmd, unsemds);
-#else
- ret = semctl(id, n, cmd, (struct semid_ds *)a);
-#endif
+ case OP_SEMCTL: {
+ union semun unsemds;
+
+ unsemds.buf = (struct semid_ds *)a;
+ ret = Semctl(id, n, cmd, unsemds);
+ }
break;
#endif
#ifdef HAS_SHM
projects / p5sagit/p5-mst-13.2.git / blobdiff