#endif
#ifdef HAS_CHSIZE
+# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
+# undef my_chsize
+# endif
# define my_chsize chsize
#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. */
PP(pp_backtick)
#ifndef CSH
*SvPVX(rs) = '\n';
#endif /* !CSH */
-#endif /* !MSDOS */
+#endif /* !DOSISH */
result = do_readline();
LEAVE;
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 (!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
EXTEND(SP, 1);
if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
- RETSETUNDEF;
+ RETPUSHUNDEF;
#ifdef DOSISH
#ifdef atarist
SV * sv ;
sv = POPs;
- if (hints & HINT_STRICT_UNTIE)
- {
+
+ if (dowarn) {
MAGIC * mg ;
if (SvMAGICAL(sv)) {
if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
mg = mg_find(sv, 'q') ;
if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
- croak("Can't untie: %d inner references still exist",
+ warn("untie attempted while %d inner references still exist",
SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
}
}
sv_unmagic(sv, 'P');
else
sv_unmagic(sv, 'q');
- RETSETYES;
+ RETPUSHYES;
}
PP(pp_tied)
else {
GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
if (gvp && *gvp == egv)
- gv_efullname(TARG, defoutgv);
+ gv_efullname3(TARG, defoutgv, Nullch);
else
sv_setsv(TARG, sv_2mortal(newRV((SV*)egv)));
XPUSHTARG;
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;
if (!cv) {
if (fgv) {
SV *tmpsv = sv_newmortal();
- gv_efullname(tmpsv, gv);
+ gv_efullname3(tmpsv, fgv, Nullch);
DIE("Undefined format \"%s\" called",SvPVX(tmpsv));
}
DIE("Not a format reference");
cv = GvFORM(fgv);
if (!cv) {
SV *tmpsv = sv_newmortal();
- gv_efullname(tmpsv, fgv);
+ gv_efullname3(tmpsv, fgv, Nullch);
DIE("Undefined top format \"%s\" called",SvPVX(tmpsv));
}
return doform(cv,gv,op);
gv = defoutgv;
if (!(io = GvIO(gv))) {
if (dowarn) {
- gv_fullname(sv,gv);
+ gv_fullname3(sv, gv, Nullch);
warn("Filehandle %s never opened", SvPV(sv,na));
}
SETERRNO(EBADF,RMS$_IFI);
}
else if (!(fp = IoOFP(io))) {
if (dowarn) {
- gv_fullname(sv,gv);
+ gv_fullname3(sv, gv, Nullch);
if (IoIFP(io))
warn("Filehandle %s opened only for input", SvPV(sv,na));
else
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)
*SvEND(bufsv) = '\0';
(void)SvPOK_only(bufsv);
SvSETMAGIC(bufsv);
- if (tainting)
- sv_magic(bufsv, Nullsv, 't', Nullch, 0);
+ /* This should not be marked tainted if the fp is marked clean */
+ 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 */
+ Zero(buffer+bufsize, offset-bufsize, char);
+ }
if (op->op_type == OP_SYSREAD) {
length = read(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
}
*SvEND(bufsv) = '\0';
(void)SvPOK_only(bufsv);
SvSETMAGIC(bufsv);
- if (tainting)
- sv_magic(bufsv, Nullsv, 't', Nullch, 0);
+ /* This should not be marked tainted if the fp is marked clean */
+ 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), 0)) < 0)
- result = 0;
+ if ((tmpfd = open(SvPV (sv, na), O_RDWR)) < 0)
+ result = 0;
else {
if (my_chsize(tmpfd, len) < 0)
result = 0;
DIE("ioctl is not implemented");
#endif
else
-#if defined(DOSISH) && !defined(OS2)
- DIE("fcntl is not implemented");
-#else
-# ifdef HAS_FCNTL
-# if defined(OS2) && defined(__EMX__)
+#ifdef HAS_FCNTL
+#if defined(OS2) && defined(__EMX__)
retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
-# else
+#else
retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
-# endif
-# else
+#endif
+#else
DIE("fcntl is not implemented");
-# endif
#endif
if (SvPOK(argsv)) {
GV *gv;
PerlIO *fp;
-#if !defined(HAS_FLOCK) && defined(HAS_LOCKF)
-# define flock lockf_emulate_flock
-#endif
-
-#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;
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) {
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(VMS) && !defined(OS2)
+#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
if (SP - MARK == 1) {
if (tainting) {
char *junk = SvPV(TOPs, na);
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);
+ (void)rsignal_restore(SIGINT, &ihand);
+ (void)rsignal_restore(SIGQUIT, &qhand);
statusvalue = FIXSTATUS(status);
if (result < 0)
value = -1;
RETURN;
}
+/* XXX The POSIX name is CLK_TCK; it is to be preferred
+ to HZ. Probably. For now, assume that if the system
+ defines HZ, it does so correctly. (Will this break
+ on VMS?)
+ Probably we ought to use _sysconf(_SC_CLK_TCK), if
+ it's supported. --AD 9/96.
+*/
+
#ifndef HZ
-#define HZ 60
+# ifdef CLK_TCK
+# define HZ CLK_TCK
+# else
+# define HZ 60
+# endif
#endif
PP(pp_tms)
{
dSP;
-#if defined(MSDOS) || !defined(HAS_TIMES)
+#ifndef HAS_TIMES
DIE("times not implemented");
#else
EXTEND(SP, 4);
(void)times((tbuffer_t *)×buf); /* time.h uses different name for */
/* struct tms, though same data */
/* is returned. */
-#undef HZ
-#define HZ CLK_TCK
#endif
PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_utime)/HZ)));
PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cstime)/HZ)));
}
RETURN;
-#endif /* MSDOS */
+#endif /* HAS_TIMES */
}
PP(pp_localtime)
tmbuf = gmtime(&when);
EXTEND(SP, 9);
+ EXTEND_MORTAL(9);
if (GIMME != G_ARRAY) {
dTARGET;
char mybuf[30];
}
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
-
-int
+static int
lockf_emulate_flock (fd, operation)
int fd;
int operation;
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