# define my_chsize chsize
#endif
-#if !defined(HAS_FLOCK) && defined(HAS_LOCKF)
- static int lockf_emulate_flock _((int fd, int operation));
-# define flock lockf_emulate_flock
-#endif
+#ifdef HAS_FLOCK
+# define FLOCK flock
+#else /* no flock() */
+
+ /* fcntl.h might not have been included, even if it exists, because
+ the current Configure only sets I_FCNTL if it's needed to pick up
+ the *_OK constants. Make sure it has been included before testing
+ the fcntl() locking constants. */
+# if defined(HAS_FCNTL) && !defined(I_FCNTL)
+# include <fcntl.h>
+# endif
+
+# if defined(HAS_FCNTL) && defined(F_SETLK) && defined (F_SETLKW)
+# define FLOCK fcntl_emulate_flock
+# define FCNTL_EMULATE_FLOCK
+# else /* no flock() or fcntl(F_SETLK,...) */
+# ifdef HAS_LOCKF
+# define FLOCK lockf_emulate_flock
+# define LOCKF_EMULATE_FLOCK
+# endif /* lockf */
+# endif /* no flock() or fcntl(F_SETLK,...) */
+
+# ifdef FLOCK
+ static int FLOCK _((int, int));
+
+ /*
+ * These are the flock() constants. Since this sytems doesn't have
+ * flock(), the values of the constants are probably not available.
+ */
+# ifndef LOCK_SH
+# define LOCK_SH 1
+# endif
+# ifndef LOCK_EX
+# define LOCK_EX 2
+# endif
+# ifndef LOCK_NB
+# define LOCK_NB 4
+# endif
+# ifndef LOCK_UN
+# define LOCK_UN 8
+# endif
+# endif /* emulating flock() */
+
+#endif /* no flock() */
/* Pushy I/O. */
}
}
}
- statusvalue = FIXSTATUS(my_pclose(fp));
+ STATUS_NATIVE_SET(my_pclose(fp));
}
else {
- statusvalue = -1;
+ STATUS_NATIVE_SET(-1);
if (GIMME == G_SCALAR)
RETPUSHUNDEF;
}
if (MAXARG > 1)
sv = POPs;
- else if (SvTYPE(TOPs) == SVt_PVGV)
- sv = GvSV(TOPs);
- else
+ if (!isGV(TOPs))
DIE(no_usym, "filehandle");
+ if (MAXARG <= 1)
+ sv = GvSV(TOPs);
gv = (GV*)POPs;
- if (IoFLAGS(GvIOn(gv)) & IOf_UNTAINT) /* This GV has UNTAINT previously set */
- IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT; /* Clear it. We don't carry that over */
+ if (!isGV(gv))
+ DIE(no_usym, "filehandle");
+ if (GvIOp(gv))
+ IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
tmps = SvPV(sv, len);
- if (do_open(gv, tmps, len, FALSE, 0, 0, Nullfp)) {
- IoLINES(GvIOp(gv)) = 0;
+ if (do_open(gv, tmps, len, FALSE, 0, 0, Nullfp))
PUSHi( (I32)forkprocess );
- }
else if (forkprocess == 0) /* we are a new child */
PUSHi(0);
else
methname = "TIESCALAR";
stash = gv_stashsv(mark[1], FALSE);
- if (!stash || !(gv = gv_fetchmethod(stash, methname)) || !GvCV(gv))
+ if (!stash || !(gv = gv_fetchmethod(stash, methname)))
DIE("Can't locate object method \"%s\" via package \"%s\"",
methname, SvPV(mark[1],na));
if (perldb && curstash != debstash)
op->op_private |= OPpENTERSUB_DB;
- XPUSHs((SV*)gv);
+ XPUSHs((SV*)GvCV(gv));
PUTBACK;
if (op = pp_entersub())
sv = sv_mortalcopy(&sv_no);
sv_setpv(sv, "AnyDBM_File");
stash = gv_stashsv(sv, FALSE);
- if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")) || !GvCV(gv)) {
+ if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
PUTBACK;
perl_require_pv("AnyDBM_File.pm");
SPAGAIN;
- if (!(gv = gv_fetchmethod(stash, "TIEHASH")) || !GvCV(gv))
+ if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
DIE("No dbm on this machine");
}
else
PUSHs(sv_2mortal(newSViv(O_RDWR)));
PUSHs(right);
- PUSHs((SV*)gv);
+ PUSHs((SV*)GvCV(gv));
PUTBACK;
if (op = pp_entersub())
PUSHs(left);
PUSHs(sv_2mortal(newSViv(O_RDONLY)));
PUSHs(right);
- PUSHs((SV*)gv);
+ PUSHs((SV*)GvCV(gv));
PUTBACK;
if (op = pp_entersub())
}
#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
-#ifdef __linux__
+#if defined(__linux__) || defined(OS2)
growsize = sizeof(fd_set);
#else
growsize = maxlen; /* little endians can use vecs directly */
XPUSHs(&sv_undef);
else {
GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
- if (gvp && *gvp == egv)
+ if (gvp && *gvp == egv) {
gv_efullname3(TARG, defoutgv, Nullch);
- else
- sv_setsv(TARG, sv_2mortal(newRV((SV*)egv)));
- XPUSHTARG;
+ XPUSHTARG;
+ }
+ else {
+ XPUSHs(sv_2mortal(newRV((SV*)egv)));
+ }
}
if (newdefout) {
gv = argvgv;
if (!gv || do_eof(gv)) /* make sure we have fp with something */
RETPUSHUNDEF;
- TAINT_IF(1);
+ TAINT;
sv_setpv(TARG, " ");
*SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
PUSHTARG;
fgv = gv;
cv = GvFORM(fgv);
-
if (!cv) {
if (fgv) {
SV *tmpsv = sv_newmortal();
}
DIE("Not a format reference");
}
- IoFLAGS(io) &= ~IOf_DIDTOP;
+ if (CvCLONE(cv))
+ cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
+ IoFLAGS(io) &= ~IOf_DIDTOP;
return doform(cv,gv,op->op_next);
}
gv_efullname3(tmpsv, fgv, Nullch);
DIE("Undefined top format \"%s\" called",SvPVX(tmpsv));
}
+ if (CvCLONE(cv))
+ cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
return doform(cv,gv,op);
}
goto just_say_no;
}
else {
+#ifdef USE_LOCALE_NUMERIC
+ if (op->op_private & OPpLOCALE)
+ SET_NUMERIC_LOCAL();
+ else
+ SET_NUMERIC_STANDARD();
+#endif
do_sprintf(sv, SP - MARK, MARK + 1);
if (!do_print(sv, fp))
goto just_say_no;
if (!gv)
goto say_undef;
bufsv = *++MARK;
+ if (! SvOK(bufsv))
+ sv_setpvn(bufsv, "", 0);
buffer = SvPV_force(bufsv, blen);
length = SvIVx(*++MARK);
if (length < 0)
if (op->op_type == OP_RECV) {
bufsize = sizeof buf;
buffer = SvGROW(bufsv, length+1);
+ /* 'offset' means 'flags' here */
length = recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
(struct sockaddr *)buf, &bufsize);
if (length < 0)
(void)SvPOK_only(bufsv);
SvSETMAGIC(bufsv);
/* This should not be marked tainted if the fp is marked clean */
- if (tainting && !(IoFLAGS(io) & IOf_UNTAINT))
- sv_magic(bufsv, Nullsv, 't', Nullch, 0);
+ if (!(IoFLAGS(io) & IOf_UNTAINT))
+ SvTAINTED_on(bufsv);
SP = ORIGMARK;
sv_setpvn(TARG, buf, bufsize);
PUSHs(TARG);
if (op->op_type == OP_RECV)
DIE(no_sock_func, "recv");
#endif
+ if (offset < 0) {
+ if (-offset > blen)
+ DIE("Offset outside string");
+ offset += blen;
+ }
bufsize = SvCUR(bufsv);
buffer = SvGROW(bufsv, length+offset+1);
if (offset > bufsize) { /* Zero any newly allocated space */
(void)SvPOK_only(bufsv);
SvSETMAGIC(bufsv);
/* This should not be marked tainted if the fp is marked clean */
- if (tainting && !(IoFLAGS(io) & IOf_UNTAINT))
- sv_magic(bufsv, Nullsv, 't', Nullch, 0);
+ if (!(IoFLAGS(io) & IOf_UNTAINT))
+ SvTAINTED_on(bufsv);
SP = ORIGMARK;
PUSHi(length);
RETURN;
}
}
else if (op->op_type == OP_SYSWRITE) {
- if (MARK < SP)
+ if (MARK < SP) {
offset = SvIVx(*++MARK);
- else
+ if (offset < 0) {
+ if (-offset > blen)
+ DIE("Offset outside string");
+ offset += blen;
+ } else if (offset >= blen)
+ DIE("Offset outside string");
+ } else
offset = 0;
if (length > blen - offset)
length = blen - offset;
int tmpfd;
if ((tmpfd = open(SvPV (sv, na), O_RDWR)) < 0)
- result = 0;
+ result = 0;
else {
if (my_chsize(tmpfd, len) < 0)
result = 0;
GV *gv;
PerlIO *fp;
-#if defined(HAS_FLOCK) || defined(flock)
+#ifdef FLOCK
argtype = POPi;
if (MAXARG <= 0)
gv = last_in_gv;
else
fp = Nullfp;
if (fp) {
- value = (I32)(flock(PerlIO_fileno(fp), argtype) >= 0);
+ value = (I32)(FLOCK(PerlIO_fileno(fp), argtype) >= 0);
}
else
value = 0;
goto nuts2;
break;
}
+#ifdef BOGUS_GETNAME_RETURN
+ /* Interactive Unix, getpeername() and getsockname()
+ does not return valid namelen */
+ if (aint == BOGUS_GETNAME_RETURN)
+ aint = sizeof(struct sockaddr);
+#endif
SvCUR_set(sv,aint);
*SvEND(sv) ='\0';
PUSHs(sv);
laststype = OP_STAT;
statgv = tmpgv;
sv_setpv(statname, "");
- if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
- Fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &statcache) < 0) {
- max = 0;
- laststatval = -1;
- }
+ laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
+ ? Fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &statcache) : -1);
}
- else if (laststatval < 0)
+ if (laststatval < 0)
max = 0;
}
else {
}
}
- EXTEND(SP, 13);
if (GIMME != G_ARRAY) {
+ EXTEND(SP, 1);
if (max)
RETPUSHYES;
else
RETPUSHUNDEF;
}
if (max) {
+ EXTEND(SP, max);
+ EXTEND_MORTAL(max);
+
PUSHs(sv_2mortal(newSViv((I32)statcache.st_dev)));
PUSHs(sv_2mortal(newSViv((I32)statcache.st_ino)));
PUSHs(sv_2mortal(newSViv((I32)statcache.st_mode)));
STDCHAR tbuf[512];
register STDCHAR *s;
register IO *io;
- SV *sv;
+ register SV *sv;
+ GV *gv;
- if (op->op_flags & OPf_REF) {
+ if (op->op_flags & OPf_REF)
+ gv = cGVOP->op_gv;
+ else if (isGV(TOPs))
+ gv = (GV*)POPs;
+ else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
+ gv = (GV*)SvRV(POPs);
+ else
+ gv = Nullgv;
+
+ if (gv) {
EXTEND(SP, 1);
- if (cGVOP->op_gv == defgv) {
+ if (gv == defgv) {
if (statgv)
io = GvIO(statgv);
else {
}
}
else {
- statgv = cGVOP->op_gv;
+ statgv = gv;
+ laststatval = -1;
sv_setpv(statname, "");
io = GvIO(statgv);
}
if (io && IoIFP(io)) {
- if (PerlIO_has_base(IoIFP(io))) {
- Fstat(PerlIO_fileno(IoIFP(io)), &statcache);
+ if (! PerlIO_has_base(IoIFP(io)))
+ DIE("-T and -B not implemented on filehandles");
+ laststatval = Fstat(PerlIO_fileno(IoIFP(io)), &statcache);
+ if (laststatval < 0)
+ RETPUSHUNDEF;
if (S_ISDIR(statcache.st_mode)) /* handle NFS glitch */
if (op->op_type == OP_FTTEXT)
RETPUSHNO;
/* sfio can have large buffers - limit to 512 */
if (len > 512)
len = 512;
- }
- else {
- DIE("-T and -B not implemented on filehandles");
- }
}
else {
if (dowarn)
}
else {
sv = POPs;
+ really_filename:
statgv = Nullgv;
+ laststatval = -1;
sv_setpv(statname, SvPV(sv, na));
- really_filename:
#ifdef HAS_OPEN3
i = open(SvPV(sv, na), O_RDONLY, 0);
#else
warn(warn_nl, "open");
RETPUSHUNDEF;
}
- Fstat(i, &statcache);
+ laststatval = Fstat(i, &statcache);
+ if (laststatval < 0)
+ RETPUSHUNDEF;
len = read(i, tbuf, 512);
(void)close(i);
if (len <= 0) {
#ifdef HAS_RENAME
anum = rename(tmps, tmps2);
#else
- if (same_dirent(tmps2, tmps)) /* can always rename to same name */
- anum = 1;
- else {
- if (euid || Stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
- (void)UNLINK(tmps2);
- if (!(anum = link(tmps, tmps2)))
- anum = UNLINK(tmps);
+ if (!(anum = Stat(tmps, &statbuf))) {
+ if (same_dirent(tmps2, tmps)) /* can always rename to same name */
+ anum = 1;
+ else {
+ if (euid || Stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
+ (void)UNLINK(tmps2);
+ if (!(anum = link(tmps, tmps2)))
+ anum = UNLINK(tmps);
+ }
}
#endif
SETi( anum >= 0 );
PP(pp_fork)
{
+#ifdef HAS_FORK
dSP; dTARGET;
int childpid;
GV *tmpgv;
EXTEND(SP, 1);
-#ifdef HAS_FORK
childpid = fork();
if (childpid < 0)
RETSETUNDEF;
PP(pp_wait)
{
+#if !defined(DOSISH) || defined(OS2)
dSP; dTARGET;
int childpid;
int argflags;
- I32 value;
- EXTEND(SP, 1);
-#ifdef HAS_WAIT
- childpid = wait(&argflags);
- if (childpid > 0)
- pidgone(childpid, argflags);
- value = (I32)childpid;
- statusvalue = FIXSTATUS(argflags);
- PUSHi(value);
+ childpid = wait4pid(-1, &argflags, 0);
+ STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
+ XPUSHi(childpid);
RETURN;
#else
DIE(no_func, "Unsupported function wait");
PP(pp_waitpid)
{
+#if !defined(DOSISH) || defined(OS2)
dSP; dTARGET;
int childpid;
int optype;
int argflags;
- I32 value;
-#ifdef HAS_WAIT
optype = POPi;
childpid = TOPi;
childpid = wait4pid(childpid, &argflags, optype);
- value = (I32)childpid;
- statusvalue = FIXSTATUS(argflags);
- SETi(value);
+ STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
+ SETi(childpid);
RETURN;
#else
DIE(no_func, "Unsupported function wait");
int childpid;
int result;
int status;
- Signal_t (*ihand)(); /* place to save signal during system() */
- Signal_t (*qhand)(); /* place to save signal during system() */
+ Sigsave_t ihand,qhand; /* place to save signals during system() */
#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
if (SP - MARK == 1) {
sleep(5);
}
if (childpid > 0) {
- ihand = signal(SIGINT, SIG_IGN);
- qhand = signal(SIGQUIT, SIG_IGN);
+ rsignal_save(SIGINT, SIG_IGN, &ihand);
+ rsignal_save(SIGQUIT, SIG_IGN, &qhand);
do {
result = wait4pid(childpid, &status, 0);
} while (result == -1 && errno == EINTR);
- (void)signal(SIGINT, ihand);
- (void)signal(SIGQUIT, qhand);
- statusvalue = FIXSTATUS(status);
- if (result < 0)
- value = -1;
- else {
- value = (I32)((unsigned int)status & 0xffff);
- }
+ (void)rsignal_restore(SIGINT, &ihand);
+ (void)rsignal_restore(SIGQUIT, &qhand);
+ STATUS_NATIVE_SET(result == -1 ? -1 : status);
do_execfree(); /* free any memory child malloced on vfork */
SP = ORIGMARK;
- PUSHi(value);
+ PUSHi(STATUS_POSIX);
RETURN;
}
if (op->op_flags & OPf_STACKED) {
else {
value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), na));
}
- statusvalue = FIXSTATUS(value);
+ STATUS_NATIVE_SET(value);
do_execfree();
SP = ORIGMARK;
- PUSHi(value);
+ PUSHi(STATUS_POSIX);
#endif /* !FORK or VMS */
RETURN;
}
tmbuf = gmtime(&when);
EXTEND(SP, 9);
+ EXTEND_MORTAL(9);
if (GIMME != G_ARRAY) {
dTARGET;
char mybuf[30];
#ifdef HOST_NOT_FOUND
if (!hent)
- statusvalue = FIXSTATUS(h_errno);
+ STATUS_NATIVE_SET(h_errno);
#endif
if (GIMME != G_ARRAY) {
}
else if (which == OP_GSBYPORT) {
char *proto = POPp;
- int port = POPi;
+ unsigned short port = POPu;
+#ifdef HAS_HTONS
+ port = htons(port);
+#endif
sent = getservbyport(port, proto);
}
else
if (tainting) {
while (++MARK <= SP) {
- if (SvGMAGICAL(*MARK) && SvSMAGICAL(*MARK) &&
- (mg = mg_find(*MARK, 't')) && mg->mg_len & 1)
- tainted = TRUE;
+ if (SvTAINTED(*MARK)) {
+ TAINT;
+ break;
+ }
}
MARK = ORIGMARK;
TAINT_PROPER("syscall");
#endif
}
-#if !defined(HAS_FLOCK) && defined(HAS_LOCKF)
+#ifdef FCNTL_EMULATE_FLOCK
+
+/* XXX Emulate flock() with fcntl().
+ What's really needed is a good file locking module.
+*/
+
+static int
+fcntl_emulate_flock(fd, operation)
+int fd;
+int operation;
+{
+ struct flock flock;
+
+ switch (operation & ~LOCK_NB) {
+ case LOCK_SH:
+ flock.l_type = F_RDLCK;
+ break;
+ case LOCK_EX:
+ flock.l_type = F_WRLCK;
+ break;
+ case LOCK_UN:
+ flock.l_type = F_UNLCK;
+ break;
+ default:
+ errno = EINVAL;
+ return -1;
+ }
+ flock.l_whence = SEEK_SET;
+ flock.l_start = flock.l_len = 0L;
+
+ return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
+}
+
+#endif /* FCNTL_EMULATE_FLOCK */
+
+#ifdef LOCKF_EMULATE_FLOCK
/* XXX Emulate flock() with lockf(). This is just to increase
portability of scripts. The calls are not completely
# define F_TEST 3 /* Test a region for other processes locks */
# endif
-/* These are the flock() constants. Since this sytems doesn't have
- flock(), the values of the constants are probably not available.
-*/
-# ifndef LOCK_SH
-# define LOCK_SH 1
-# endif
-# ifndef LOCK_EX
-# define LOCK_EX 2
-# endif
-# ifndef LOCK_NB
-# define LOCK_NB 4
-# endif
-# ifndef LOCK_UN
-# define LOCK_UN 8
-# endif
-
static int
lockf_emulate_flock (fd, operation)
int fd;
errno = EWOULDBLOCK;
break;
- /* LOCK_UN - unlock */
+ /* LOCK_UN - unlock (non-blocking is a no-op) */
case LOCK_UN:
+ case LOCK_UN|LOCK_NB:
i = lockf (fd, F_ULOCK, 0);
break;
}
return (i);
}
-#endif
+
+#endif /* LOCKF_EMULATE_FLOCK */
projects / p5sagit/p5-mst-13.2.git / blobdiff