X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=75fdc4055a6ed662a9050dea68b09e1dadc604a0;hb=3f4fc4634a226330cf98eab6871f26f45d52e425;hp=8af00722c82bde244291a3de6bf6c1a83f8f2110;hpb=ff68c7194e176ca1907544a3a65684b76834d0fe;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_sys.c b/pp_sys.c
index 8af0072..75fdc40 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -102,6 +102,14 @@ static int dooneliner _((char *cmd, char *filename));
 #  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
@@ -113,7 +121,7 @@ static int dooneliner _((char *cmd, char *filename));
 #  endif /* no flock() or fcntl(F_SETLK,...) */
 
 #  ifdef FLOCK
-     static int FLOCK(int, int);
+     static int FLOCK _((int, int));
 
     /*
      * These are the flock() constants.  Since this sytems doesn't have
@@ -146,12 +154,13 @@ PP(pp_backtick)
     TAINT_PROPER("``");
     fp = my_popen(tmps, "r");
     if (fp) {
-	sv_setpv(TARG, "");	/* note that this preserves previous buffer */
 	if (GIMME == G_SCALAR) {
+	    sv_setpv(TARG, "");	/* note that this preserves previous buffer */
 	    while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
 		/*SUPPRESS 530*/
 		;
 	    XPUSHs(TARG);
+	    SvTAINTED_on(TARG);
 	}
 	else {
 	    SV *sv;
@@ -167,12 +176,14 @@ PP(pp_backtick)
 		    SvLEN_set(sv, SvCUR(sv)+1);
 		    Renew(SvPVX(sv), SvLEN(sv), char);
 		}
+		SvTAINTED_on(sv);
 	    }
 	}
-	statusvalue = FIXSTATUS(my_pclose(fp));
+	STATUS_NATIVE_SET(my_pclose(fp));
+	TAINT;		/* "I believe that this is not gratuitous!" */
     }
     else {
-	statusvalue = -1;
+	STATUS_NATIVE_SET(-1);
 	if (GIMME == G_SCALAR)
 	    RETPUSHUNDEF;
     }
@@ -276,18 +287,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
@@ -460,7 +471,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));
 
@@ -475,7 +486,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())
@@ -515,8 +526,8 @@ PP(pp_untie)
                 mg = mg_find(sv, 'q') ;
     
             if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)  
-		warn("untie attempted while %d inner references still exist",
-			SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
+		warn("untie attempted while %lu inner references still exist",
+			(unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
         }
     }
  
@@ -564,11 +575,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");
     }
 
@@ -593,7 +604,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())
@@ -610,7 +621,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())
@@ -667,7 +678,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 */
@@ -790,11 +801,13 @@ PP(pp_select)
 	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) {
@@ -881,7 +894,6 @@ PP(pp_enterwrite)
 	fgv = gv;
 
     cv = GvFORM(fgv);
-
     if (!cv) {
 	if (fgv) {
 	    SV *tmpsv = sv_newmortal();
@@ -890,8 +902,10 @@ PP(pp_enterwrite)
 	}
 	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);
 }
 
@@ -967,6 +981,8 @@ PP(pp_leavewrite)
 	    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);
     }
 
@@ -1039,12 +1055,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;
@@ -1852,6 +1868,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);
@@ -1889,13 +1911,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 {
@@ -1924,15 +1943,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)));
@@ -2266,11 +2287,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 {
@@ -2279,13 +2310,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;
@@ -2303,10 +2338,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)
@@ -2318,9 +2349,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
@@ -2331,7 +2363,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) {
@@ -2470,13 +2504,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 );
@@ -2819,12 +2855,12 @@ nope:
 
 PP(pp_fork)
 {
+#ifdef HAS_FORK
     dSP; dTARGET;
     int childpid;
     GV *tmpgv;
 
     EXTEND(SP, 1);
-#ifdef HAS_FORK
     childpid = fork();
     if (childpid < 0)
 	RETSETUNDEF;
@@ -2843,19 +2879,14 @@ PP(pp_fork)
 
 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");
@@ -2864,19 +2895,17 @@ PP(pp_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");
@@ -2917,15 +2946,10 @@ PP(pp_system)
 	} while (result == -1 && errno == EINTR);
 	(void)rsignal_restore(SIGINT, &ihand);
 	(void)rsignal_restore(SIGQUIT, &qhand);
-	statusvalue = FIXSTATUS(status);
-	if (result < 0)
-	    value = -1;
-	else {
-	    value = (I32)((unsigned int)status & 0xffff);
-	}
+	STATUS_NATIVE_SET(result == -1 ? -1 : status);
 	do_execfree();	/* free any memory child malloced on vfork */
 	SP = ORIGMARK;
-	PUSHi(value);
+	PUSHi(STATUS_CURRENT);
 	RETURN;
     }
     if (op->op_flags & OPf_STACKED) {
@@ -2948,10 +2972,10 @@ PP(pp_system)
     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_CURRENT);
 #endif /* !FORK or VMS */
     RETURN;
 }
@@ -3027,7 +3051,7 @@ PP(pp_getpgrp)
 #ifdef BSD_GETPGRP
     value = (I32)BSD_GETPGRP(pid);
 #else
-    if (pid != 0)
+    if (pid != 0 && pid != getpid())
 	DIE("POSIX getpgrp can't take an argument");
     value = (I32)getpgrp();
 #endif
@@ -3057,9 +3081,8 @@ PP(pp_setpgrp)
 #ifdef BSD_SETPGRP
     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
 #else
-    if ((pgrp != 0) || (pid != 0)) {
+    if ((pgrp != 0 && pgrp != getpid())) || (pid != 0 && pid != getpid()))
 	DIE("POSIX setpgrp can't take an argument");
-    }
     SETi( setpgrp() >= 0 );
 #endif /* USE_BSDPGRP */
     RETURN;
@@ -3426,7 +3449,7 @@ PP(pp_ghostent)
 
 #ifdef HOST_NOT_FOUND
     if (!hent)
-	statusvalue = FIXSTATUS(h_errno);
+	STATUS_NATIVE_SET(h_errno);
 #endif
 
     if (GIMME != G_ARRAY) {
@@ -3655,8 +3678,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