#endif
#ifdef I_UTIME
-# ifdef _MSC_VER
+# if defined(_MSC_VER) || defined(__MINGW32__)
# include <sys/utime.h>
# else
# include <utime.h>
# endif
#endif
+
#ifdef I_FCNTL
#include <fcntl.h>
#endif
#ifdef I_SYS_FILE
#include <sys/file.h>
#endif
+#ifdef O_EXCL
+# define OPEN_EXCL O_EXCL
+#else
+# define OPEN_EXCL 0
+#endif
#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
#include <signal.h>
PerlIO *fp;
int fd;
int result;
+ bool was_fdopen = FALSE;
forkprocess = 1; /* assume true if no fork */
result = 0;
}
else if (IoTYPE(io) == '|')
- result = my_pclose(IoIFP(io));
+ result = PerlProc_pclose(IoIFP(io));
else if (IoIFP(io) != IoOFP(io)) {
if (IoOFP(io)) {
result = PerlIO_close(IoOFP(io));
result = rawmode & 3;
IoTYPE(io) = "<>++"[result];
writing = (result > 0);
- fd = open(name, rawmode, rawperm);
+ fd = PerlLIO_open3(name, rawmode, rawperm);
if (fd == -1)
fp = NULL;
else {
fpmode = (result == 1) ? "w" : "r+";
fp = PerlIO_fdopen(fd, fpmode);
if (!fp)
- close(fd);
+ PerlLIO_close(fd);
}
}
else {
if (strNE(name,"-"))
TAINT_ENV();
TAINT_PROPER("piped open");
- if (dowarn && name[strlen(name)-1] == '|')
- warn("Can't do bidirectional pipe");
- fp = my_popen(name,"w");
+ 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;
}
else if (*name == '>') {
fd = -1;
}
if (dodup)
- fd = dup(fd);
+ fd = PerlLIO_dup(fd);
+ else
+ was_fdopen = TRUE;
if (!(fp = PerlIO_fdopen(fd,mode))) {
if (dodup)
- close(fd);
+ 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';
if (strNE(name,"-"))
TAINT_ENV();
TAINT_PROPER("piped open");
- fp = my_popen(name,"r");
+ fp = PerlProc_popen(name,"r");
IoTYPE(io) = '|';
}
else {
if (IoTYPE(io) &&
IoTYPE(io) != '|' && IoTYPE(io) != '-') {
dTHR;
- if (Fstat(PerlIO_fileno(fp),&statbuf) < 0) {
+ if (PerlLIO_fstat(PerlIO_fileno(fp),&statbuf) < 0) {
(void)PerlIO_close(fp);
goto say_false;
}
) {
char tmpbuf[256];
Sock_size_t buflen = sizeof tmpbuf;
- if (getsockname(PerlIO_fileno(fp), (struct sockaddr *)tmpbuf,
+ if (PerlSock_getsockname(PerlIO_fileno(fp), (struct sockaddr *)tmpbuf,
&buflen) >= 0
|| errno != ENOTSOCK)
IoTYPE(io) = 's'; /* some OS's return 0 on fstat()ed socket */
int pid;
SV *sv;
- dup2(PerlIO_fileno(fp), fd);
+ PerlLIO_dup2(PerlIO_fileno(fp), fd);
sv = *av_fetch(fdpid,PerlIO_fileno(fp),TRUE);
(void)SvUPGRADE(sv, SVt_IV);
pid = SvIVX(sv);
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;
#ifdef HAS_FCHMOD
(void)fchmod(lastfd,filemode);
#else
- (void)chmod(oldname,filemode);
+ (void)PerlLIO_chmod(oldname,filemode);
#endif
}
filemode = 0;
while (av_len(GvAV(gv)) >= 0) {
dTHR;
- STRLEN len;
+ STRLEN oldlen;
sv = av_shift(GvAV(gv));
SAVEFREESV(sv);
sv_setsv(GvSV(gv),sv);
SvSETMAGIC(GvSV(gv));
- oldname = SvPVx(GvSV(gv), len);
- if (do_open(gv,oldname,len,FALSE,0,0,Nullfp)) {
+ oldname = SvPVx(GvSV(gv), oldlen);
+ if (do_open(gv,oldname,oldlen,inplace!=0,0,0,Nullfp)) {
if (inplace) {
TAINT_PROPER("inplace open");
- if (strEQ(oldname,"-")) {
+ if (oldlen == 1 && *oldname == '-') {
setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
return IoIFP(GvIOp(gv));
}
sv_catpv(sv,inplace);
#endif
#ifndef FLEXFILENAMES
- if (Stat(SvPVX(sv),&statbuf) >= 0
+ if (PerlLIO_stat(SvPVX(sv),&statbuf) >= 0
&& statbuf.st_dev == filedev
&& statbuf.st_ino == fileino
#ifdef DJGPP
#endif
#ifdef HAS_RENAME
#ifndef DOSISH
- if (rename(oldname,SvPVX(sv)) < 0) {
+ if (PerlLIO_rename(oldname,SvPVX(sv)) < 0) {
warn("Can't rename %s to %s: %s, skipping file",
oldname, SvPVX(sv), Strerror(errno) );
do_close(gv,FALSE);
}
#else
do_close(gv,FALSE);
- (void)unlink(SvPVX(sv));
- (void)rename(oldname,SvPVX(sv));
- do_open(gv,SvPVX(sv),SvCUR(sv),FALSE,0,0,Nullfp);
+ (void)PerlLIO_unlink(SvPVX(sv));
+ (void)PerlLIO_rename(oldname,SvPVX(sv));
+ do_open(gv,SvPVX(sv),SvCUR(sv),inplace!=0,0,0,Nullfp);
#endif /* DOSISH */
#else
(void)UNLINK(SvPVX(sv));
#if !defined(DOSISH) && !defined(AMIGAOS)
# ifndef VMS /* Don't delete; use automatic file versioning */
if (UNLINK(oldname) < 0) {
- warn("Can't rename %s to %s: %s, skipping file",
- oldname, SvPVX(sv), Strerror(errno) );
+ warn("Can't remove %s: %s, skipping file",
+ oldname, Strerror(errno) );
do_close(gv,FALSE);
continue;
}
#endif
}
- sv_setpvn(sv,">",1);
- sv_catpv(sv,oldname);
+ sv_setpvn(sv,">",!inplace);
+ sv_catpvn(sv,oldname,oldlen);
SETERRNO(0,0); /* in case sprintf set errno */
- if (!do_open(argvoutgv,SvPVX(sv),SvCUR(sv),FALSE,0,0,Nullfp)) {
+ if (!do_open(argvoutgv,SvPVX(sv),SvCUR(sv),inplace!=0,
+ O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp)) {
warn("Can't do inplace edit on %s: %s",
oldname, Strerror(errno) );
do_close(gv,FALSE);
}
setdefout(argvoutgv);
lastfd = PerlIO_fileno(IoIFP(GvIOp(argvoutgv)));
- (void)Fstat(lastfd,&statbuf);
+ (void)PerlLIO_fstat(lastfd,&statbuf);
#ifdef HAS_FCHMOD
(void)fchmod(lastfd,filemode);
#else
# if !(defined(WIN32) && defined(__BORLANDC__))
/* Borland runtime creates a readonly file! */
- (void)chmod(oldname,filemode);
+ (void)PerlLIO_chmod(oldname,filemode);
# endif
#endif
if (fileuid != statbuf.st_uid || filegid != statbuf.st_gid) {
(void)fchown(lastfd,fileuid,filegid);
#else
#ifdef HAS_CHOWN
- (void)chown(oldname,fileuid,filegid);
+ (void)PerlLIO_chown(oldname,fileuid,filegid);
#endif
#endif
}
if (IoIFP(wstio))
do_close(wgv,FALSE);
- if (pipe(fd) < 0)
+ if (PerlProc_pipe(fd) < 0)
goto badexit;
IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
IoTYPE(wstio) = '>';
if (!IoIFP(rstio) || !IoOFP(wstio)) {
if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
- else close(fd[0]);
+ else PerlLIO_close(fd[0]);
if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
- else close(fd[1]);
+ else PerlLIO_close(fd[1]);
goto badexit;
}
/* 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);
if (IoIFP(io)) {
if (IoTYPE(io) == '|') {
- status = my_pclose(IoIFP(io));
+ status = PerlProc_pclose(IoIFP(io));
STATUS_NATIVE_SET(status);
retval = (STATUS_POSIX == 0);
}
}
IoOFP(io) = IoIFP(io) = Nullfp;
}
+ else {
+ SETERRNO(EBADF,SS$_IVCHAN);
+ }
return retval;
}
register PerlIO *fp;
if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
- return lseek(PerlIO_fileno(fp), pos, whence);
+ return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
if (dowarn)
warn("sysseek() on unopened file");
SETERRNO(EBADF,RMS$_IFI);
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
struct flock fl;
struct stat filebuf;
- if (Fstat(fd, &filebuf) < 0)
+ if (PerlLIO_fstat(fd, &filebuf) < 0)
return -1;
if (filebuf.st_size < length) {
/* extend file length */
- if ((lseek(fd, (length - 1), 0)) < 0)
+ if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
return -1;
/* write a "0" byte */
- if ((write(fd, "", 1)) != 1)
+ if ((PerlLIO_write(fd, "", 1)) != 1)
return -1;
}
else {
GV* tmpgv;
if (op->op_flags & OPf_REF) {
- EXTEND(sp,1);
+ EXTEND(SP,1);
tmpgv = cGVOP->op_gv;
do_fstat:
io = GvIO(tmpgv);
statgv = tmpgv;
sv_setpv(statname,"");
laststype = OP_STAT;
- return (laststatval = Fstat(PerlIO_fileno(IoIFP(io)), &statcache));
+ return (laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &statcache));
}
else {
if (tmpgv == defgv)
}
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 = 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");
PUTBACK;
sv_setpv(statname,SvPV(sv, na));
#ifdef HAS_LSTAT
- laststatval = lstat(SvPV(sv, na),&statcache);
+ laststatval = PerlLIO_lstat(SvPV(sv, na),&statcache);
#else
- laststatval = Stat(SvPV(sv, na),&statcache);
+ laststatval = PerlLIO_stat(SvPV(sv, na),&statcache);
#endif
if (laststatval < 0 && dowarn && strchr(SvPV(sv, na), '\n'))
warn(warn_nl, "lstat");
if (*Argv[0] != '/') /* will execvp use PATH? */
TAINT_ENV(); /* testing IFS here is overkill, probably */
if (really && *(tmps = SvPV(really, na)))
- execvp(tmps,Argv);
+ PerlProc_execvp(tmps,Argv);
else
- execvp(Argv[0],Argv);
+ PerlProc_execvp(Argv[0],Argv);
if (dowarn)
warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno));
}
*--s = '\0';
if (s[-1] == '\'') {
*--s = '\0';
- execl(cshname,"csh", flags,ncmd,(char*)0);
+ PerlProc_execl(cshname,"csh", flags,ncmd,(char*)0);
*s = '\'';
return FALSE;
}
break;
}
doshell:
- execl(sh_path, "sh", "-c", cmd, (char*)0);
+ PerlProc_execl(sh_path, "sh", "-c", cmd, (char*)0);
return FALSE;
}
}
}
*a = Nullch;
if (Argv[0]) {
- execvp(Argv[0],Argv);
+ PerlProc_execvp(Argv[0],Argv);
if (errno == ENOEXEC) { /* for system V NIH syndrome */
do_execfree();
goto doshell;
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 (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 (killpg(proc,val)) /* BSD */
+ if (PerlProc_killpg(proc,val)) /* BSD */
#else
- if (kill(-proc,val)) /* SYSV */
+ if (PerlProc_kill(-proc,val)) /* SYSV */
#endif
tot--;
}
}
else {
while (++mark <= sp) {
- if (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--;
}
else { /* don't let root wipe out directories without -U */
#ifdef HAS_LSTAT
- if (lstat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
+ if (PerlLIO_lstat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
#else
- if (Stat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
+ if (PerlLIO_stat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
#endif
tot--;
else {
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 (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