X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=13e11b5adba6756c3f1638a3fbf399d98f5143de;hb=9a3e71f668bd84b1cf53dd3ea10f588d59ecfebb;hp=ab8b8e6ded2327e12334212834876719e6e4eca7;hpb=7b160dda90126187f14dbd829dee2bd8b9e86fde;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_sys.c b/pp_sys.c
index ab8b8e6..13e11b5 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -98,10 +98,50 @@ static int dooneliner _((char *cmd, char *filename));
 # 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. */
@@ -244,18 +284,18 @@ PP(pp_open)
 
     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
@@ -428,7 +468,7 @@ PP(pp_tie)
 	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));
 
@@ -443,7 +483,7 @@ PP(pp_tie)
     if (perldb && curstash != debstash)
 	op->op_private |= OPpENTERSUB_DB;
 
-    XPUSHs((SV*)gv);
+    XPUSHs((SV*)GvCV(gv));
     PUTBACK;
 
     if (op = pp_entersub())
@@ -532,11 +572,11 @@ PP(pp_dbmopen)
     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");
     }
 
@@ -561,7 +601,7 @@ PP(pp_dbmopen)
     else
 	PUSHs(sv_2mortal(newSViv(O_RDWR)));
     PUSHs(right);
-    PUSHs((SV*)gv);
+    PUSHs((SV*)GvCV(gv));
     PUTBACK;
 
     if (op = pp_entersub())
@@ -578,7 +618,7 @@ PP(pp_dbmopen)
 	PUSHs(left);
 	PUSHs(sv_2mortal(newSViv(O_RDONLY)));
 	PUSHs(right);
-	PUSHs((SV*)gv);
+	PUSHs((SV*)GvCV(gv));
 	PUTBACK;
 
 	if (op = pp_entersub())
@@ -635,7 +675,7 @@ PP(pp_sselect)
     }
 
 #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 */
@@ -1007,12 +1047,12 @@ PP(pp_prtf)
 	goto just_say_no;
     }
     else {
-#ifdef LC_NUMERIC
+#ifdef USE_LOCALE_NUMERIC
 	if (op->op_private & OPpLOCALE)
-	    NUMERIC_LOCAL();
+	    SET_NUMERIC_LOCAL();
 	else
-	    NUMERIC_STANDARD();
-#endif /* LC_NUMERIC */
+	    SET_NUMERIC_STANDARD();
+#endif
 	do_sprintf(sv, SP - MARK, MARK + 1);
 	if (!do_print(sv, fp))
 	    goto just_say_no;
@@ -1077,6 +1117,8 @@ PP(pp_sysread)
     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)
@@ -1418,7 +1460,7 @@ PP(pp_flock)
     GV *gv;
     PerlIO *fp;
 
-#if defined(HAS_FLOCK) || defined(flock)
+#ifdef FLOCK
     argtype = POPi;
     if (MAXARG <= 0)
 	gv = last_in_gv;
@@ -1429,7 +1471,7 @@ PP(pp_flock)
     else
 	fp = Nullfp;
     if (fp) {
-	value = (I32)(flock(PerlIO_fileno(fp), argtype) >= 0);
+	value = (I32)(FLOCK(PerlIO_fileno(fp), argtype) >= 0);
     }
     else
 	value = 0;
@@ -1818,6 +1860,12 @@ PP(pp_getpeername)
 	    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);
@@ -1855,13 +1903,10 @@ PP(pp_stat)
 	    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 {
@@ -1890,15 +1935,17 @@ PP(pp_stat)
 	}
     }
 
-    EXTEND(SP, 13);
-    EXTEND_MORTAL(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)));
@@ -2232,11 +2279,21 @@ PP(pp_fttext)
     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 {
@@ -2245,13 +2302,17 @@ PP(pp_fttext)
 	    }
 	}
 	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;
@@ -2269,10 +2330,6 @@ PP(pp_fttext)
 	    /* 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)
@@ -2284,9 +2341,10 @@ PP(pp_fttext)
     }
     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
@@ -2297,7 +2355,9 @@ PP(pp_fttext)
 		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) {
@@ -2436,13 +2496,15 @@ PP(pp_rename)
 #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 );
@@ -2876,13 +2938,13 @@ PP(pp_system)
 	sleep(5);
     }
     if (childpid > 0) {
-	rsignalsave(SIGINT, SIG_IGN, &ihand);
-	rsignalsave(SIGQUIT, SIG_IGN, &qhand);
+	rsignal_save(SIGINT, SIG_IGN, &ihand);
+	rsignal_save(SIGQUIT, SIG_IGN, &qhand);
 	do {
 	    result = wait4pid(childpid, &status, 0);
 	} while (result == -1 && errno == EINTR);
-	(void)rsignalrestore(SIGINT, &ihand);
-	(void)rsignalrestore(SIGQUIT, &qhand);
+	(void)rsignal_restore(SIGINT, &ihand);
+	(void)rsignal_restore(SIGQUIT, &qhand);
 	statusvalue = FIXSTATUS(status);
 	if (result < 0)
 	    value = -1;
@@ -3621,8 +3683,11 @@ PP(pp_gservent)
     }
     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
@@ -4078,7 +4143,42 @@ PP(pp_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
@@ -4108,22 +4208,6 @@ PP(pp_syscall)
 #  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;
@@ -4149,8 +4233,9 @@ 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;
 
@@ -4162,4 +4247,5 @@ int operation;
     }
     return (i);
 }
-#endif
+
+#endif /* LOCKF_EMULATE_FLOCK */