X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=bd2334ad48c8408a2c3424ba680d1eda1b43cb95;hb=02a834a9ae508dc3fab0b5a0375804172985b012;hp=827d8f6de7ee0f3a37fb666b28e9302fd59a1f23;hpb=17a8c7ba9970150a64381dc5f49457bd108eabcc;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_sys.c b/pp_sys.c
index 827d8f6..bd2334a 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -173,6 +173,8 @@ static char zero_but_true[ZBTLEN + 1] = "0 but true";
 #  define FD_CLOEXEC 1		/* NeXT needs this */
 #endif
 
+#include "reentr.h"
+
 #undef PERL_EFF_ACCESS_R_OK	/* EFFective uid/gid ACCESS R_OK */
 #undef PERL_EFF_ACCESS_W_OK
 #undef PERL_EFF_ACCESS_X_OK
@@ -321,10 +323,13 @@ PP(pp_backtick)
 		;
 	}
 	else if (gimme == G_SCALAR) {
+	    SV *oldrs = PL_rs;
+	    PL_rs = &PL_sv_undef;
 	    sv_setpv(TARG, "");	/* note that this preserves previous buffer */
 	    while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
 		/*SUPPRESS 530*/
 		;
+	    PL_rs = oldrs;
 	    XPUSHs(TARG);
 	    SvTAINTED_on(TARG);
 	}
@@ -605,6 +610,7 @@ PP(pp_pipe_op)
 
     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
+    IoOFP(rstio) = IoIFP(rstio);
     IoIFP(wstio) = IoOFP(wstio);
     IoTYPE(rstio) = IoTYPE_RDONLY;
     IoTYPE(wstio) = IoTYPE_WRONLY;
@@ -731,11 +737,16 @@ PP(pp_binmode)
         RETPUSHUNDEF;
     }
 
+    PUTBACK;
     if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp),
-                       (discp) ? SvPV_nolen(discp) : Nullch))
+                       (discp) ? SvPV_nolen(discp) : Nullch)) {
+	SPAGAIN;
 	RETPUSHYES;
-    else
+    }
+    else {
+	SPAGAIN;
 	RETPUSHUNDEF;
+    }
 }
 
 PP(pp_tie)
@@ -785,7 +796,7 @@ PP(pp_tie)
 	ENTER;
 	PUSHSTACKi(PERLSI_MAGIC);
 	PUSHMARK(SP);
-	EXTEND(SP,items);
+	EXTEND(SP,(I32)items);
 	while (items--)
 	    PUSHs(*MARK++);
 	PUTBACK;
@@ -803,7 +814,7 @@ PP(pp_tie)
 	ENTER;
 	PUSHSTACKi(PERLSI_MAGIC);
 	PUSHMARK(SP);
-	EXTEND(SP,items);
+	EXTEND(SP,(I32)items);
 	while (items--)
 	    PUSHs(*MARK++);
 	PUTBACK;
@@ -817,11 +828,11 @@ PP(pp_tie)
 	sv_unmagic(varsv, how);
 	/* Croak if a self-tie on an aggregate is attempted. */
 	if (varsv == SvRV(sv) &&
-	    (SvTYPE(sv) == SVt_PVAV ||
-	     SvTYPE(sv) == SVt_PVHV))
+	    (SvTYPE(varsv) == SVt_PVAV ||
+	     SvTYPE(varsv) == SVt_PVHV))
 	    Perl_croak(aTHX_
 		       "Self-ties of arrays and hashes are not supported");
-	sv_magic(varsv, sv, how, Nullch, 0);
+	sv_magic(varsv, (SvRV(sv) == varsv ? Nullsv : sv), how, Nullch, 0);
     }
     LEAVE;
     SP = PL_stack_base + markoff;
@@ -1593,7 +1604,7 @@ PP(pp_sysread)
 	if (bufsize >= 256)
 	    bufsize = 255;
 #endif
-	buffer = SvGROW(bufsv, length+1);
+	buffer = SvGROW(bufsv, (STRLEN)(length+1));
 	/* 'offset' means 'flags' here */
 	count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
 			  (struct sockaddr *)namebuf, &bufsize);
@@ -1626,7 +1637,7 @@ PP(pp_sysread)
 	blen = sv_len_utf8(bufsv);
     }
     if (offset < 0) {
-	if (-offset > blen)
+	if (-offset > (int)blen)
 	    DIE(aTHX_ "Offset outside string");
 	offset += blen;
     }
@@ -1636,7 +1647,7 @@ PP(pp_sysread)
     }
  more_bytes:
     bufsize = SvCUR(bufsv);
-    buffer  = SvGROW(bufsv, length+offset+1);
+    buffer  = SvGROW(bufsv, (STRLEN)(length+offset+1));
     if (offset > bufsize) { /* Zero any newly allocated space */
     	Zero(buffer+bufsize, offset-bufsize, char);
     }
@@ -1826,10 +1837,10 @@ PP(pp_send)
 	if (MARK < SP) {
 	    offset = SvIVx(*++MARK);
 	    if (offset < 0) {
-		if (-offset > blen)
+		if (-offset > (IV)blen)
 		    DIE(aTHX_ "Offset outside string");
 		offset += blen;
-	    } else if (offset >= blen && blen > 0)
+	    } else if (offset >= (IV)blen && blen > 0)
 		DIE(aTHX_ "Offset outside string");
 	} else
 	    offset = 0;
@@ -2042,7 +2053,7 @@ PP(pp_truncate)
     /* XXX Configure probe for the length type of *truncate() needed XXX */
     Off_t len;
 
-#if Size_t_size > IVSIZE
+#if Off_t_size > IVSIZE
     len = (Off_t)POPn;
 #else
     len = (Off_t)POPi;
@@ -2167,15 +2178,14 @@ PP(pp_ioctl)
 	DIE(aTHX_ "ioctl is not implemented");
 #endif
     else
-#ifdef HAS_FCNTL
+#ifndef HAS_FCNTL
+      DIE(aTHX_ "fcntl is not implemented");
+#else
 #if defined(OS2) && defined(__EMX__)
 	retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
 #else
 	retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
 #endif
-#else
-	DIE(aTHX_ "fcntl is not implemented");
-#endif
 
     if (SvPOK(argsv)) {
 	if (s[SvCUR(argsv)] != 17)
@@ -2193,6 +2203,7 @@ PP(pp_ioctl)
     else {
 	PUSHp(zero_but_true, ZBTLEN);
     }
+#endif
     RETURN;
 }
 
@@ -4034,22 +4045,24 @@ PP(pp_system)
     I32 value;
     STRLEN n_a;
     int result;
-    int pp[2];
     I32 did_pipes = 0;
 
     if (PL_tainting) {
+	int some_arg_tainted = 0;
 	TAINT_ENV();
 	while (++MARK <= SP) {
 	    (void)SvPV_nolen(*MARK);      /* stringify for taint check */
-	    if (PL_tainted) 
+	    if (PL_tainted) {
+		some_arg_tainted = 1;
 		break;
+	    }
 	}
 	MARK = ORIGMARK;
 	/* XXX Remove warning at end of deprecation cycle --RD 2002-02  */
 	if (SP - MARK == 1) {
 	    TAINT_PROPER("system");
 	}
-	else if (ckWARN2(WARN_TAINT, WARN_DEPRECATED)) {
+	else if (some_arg_tainted && ckWARN2(WARN_TAINT, WARN_DEPRECATED)) {
 	    Perl_warner(aTHX_ packWARN2(WARN_TAINT, WARN_DEPRECATED),
 		"Use of tainted arguments in %s is deprecated", "system");
 	}
@@ -4057,91 +4070,102 @@ PP(pp_system)
     PERL_FLUSHALL_FOR_CHILD;
 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
     {
-	 Pid_t childpid;
-	 int status;
-	 Sigsave_t ihand,qhand;     /* place to save signals during system() */
-
-	 if (PerlProc_pipe(pp) >= 0)
-	      did_pipes = 1;
-	 while ((childpid = PerlProc_fork()) == -1) {
-	      if (errno != EAGAIN) {
-		   value = -1;
-		   SP = ORIGMARK;
-		   PUSHi(value);
-		   if (did_pipes) {
-			PerlLIO_close(pp[0]);
-			PerlLIO_close(pp[1]);
-		   }
-		   RETURN;
-	      }
-	      sleep(5);
-	 }
-	 if (childpid > 0) {
-	      if (did_pipes)
-		   PerlLIO_close(pp[1]);
+	Pid_t childpid;
+	int pp[2];
+
+	if (PerlProc_pipe(pp) >= 0)
+	    did_pipes = 1;
+	while ((childpid = PerlProc_fork()) == -1) {
+	    if (errno != EAGAIN) {
+		value = -1;
+		SP = ORIGMARK;
+		PUSHi(value);
+		if (did_pipes) {
+		    PerlLIO_close(pp[0]);
+		    PerlLIO_close(pp[1]);
+		}
+		RETURN;
+	    }
+	    sleep(5);
+	}
+	if (childpid > 0) {
+	    Sigsave_t ihand,qhand; /* place to save signals during system() */
+	    int status;
+
+	    if (did_pipes)
+		PerlLIO_close(pp[1]);
 #ifndef PERL_MICRO
-	      rsignal_save(SIGINT, SIG_IGN, &ihand);
-	      rsignal_save(SIGQUIT, SIG_IGN, &qhand);
+	    rsignal_save(SIGINT, SIG_IGN, &ihand);
+	    rsignal_save(SIGQUIT, SIG_IGN, &qhand);
 #endif
-	      do {
-		   result = wait4pid(childpid, &status, 0);
-	      } while (result == -1 && errno == EINTR);
+	    do {
+		result = wait4pid(childpid, &status, 0);
+	    } while (result == -1 && errno == EINTR);
 #ifndef PERL_MICRO
-	      (void)rsignal_restore(SIGINT, &ihand);
-	      (void)rsignal_restore(SIGQUIT, &qhand);
-#endif
-	      STATUS_NATIVE_SET(result == -1 ? -1 : status);
-	      do_execfree();	/* free any memory child malloced on fork */
-	      SP = ORIGMARK;
-	      if (did_pipes) {
-		   int errkid;
-		   int n = 0, n1;
-		
-		   while (n < sizeof(int)) {
-			n1 = PerlLIO_read(pp[0],
-					  (void*)(((char*)&errkid)+n),
-					  (sizeof(int)) - n);
-			if (n1 <= 0)
-			     break;
-			n += n1;
-		   }
-		   PerlLIO_close(pp[0]);
-		   if (n) {			/* Error */
-			if (n != sizeof(int))
-			     DIE(aTHX_ "panic: kid popen errno read");
-			errno = errkid;		/* Propagate errno from kid */
-			STATUS_CURRENT = -1;
-		   }
-	      }
-	      PUSHi(STATUS_CURRENT);
-	      RETURN;
-	 }
-	 if (did_pipes) {
-	      PerlLIO_close(pp[0]);
+	    (void)rsignal_restore(SIGINT, &ihand);
+	    (void)rsignal_restore(SIGQUIT, &qhand);
+#endif
+	    STATUS_NATIVE_SET(result == -1 ? -1 : status);
+	    do_execfree();	/* free any memory child malloced on fork */
+	    SP = ORIGMARK;
+	    if (did_pipes) {
+		int errkid;
+		int n = 0, n1;
+
+		while (n < sizeof(int)) {
+		    n1 = PerlLIO_read(pp[0],
+				      (void*)(((char*)&errkid)+n),
+				      (sizeof(int)) - n);
+		    if (n1 <= 0)
+			break;
+		    n += n1;
+		}
+		PerlLIO_close(pp[0]);
+		if (n) {			/* Error */
+		    if (n != sizeof(int))
+			DIE(aTHX_ "panic: kid popen errno read");
+		    errno = errkid;		/* Propagate errno from kid */
+		    STATUS_CURRENT = -1;
+		}
+	    }
+	    PUSHi(STATUS_CURRENT);
+	    RETURN;
+	}
+	if (did_pipes) {
+	    PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-	      fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+	    fcntl(pp[1], F_SETFD, FD_CLOEXEC);
 #endif
-	 }
-    }
-    if (PL_op->op_flags & OPf_STACKED) {
-	SV *really = *++MARK;
-	value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
-    }
-    else if (SP - MARK != 1)
-	value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
-    else {
-	value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
+	}
+	if (PL_op->op_flags & OPf_STACKED) {
+	    SV *really = *++MARK;
+	    value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
+	}
+	else if (SP - MARK != 1)
+	    value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
+	else {
+	    value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
+	}
+	PerlProc__exit(-1);
     }
-    PerlProc__exit(-1);
 #else /* ! FORK or VMS or OS/2 */
     PL_statusvalue = 0;
     result = 0;
     if (PL_op->op_flags & OPf_STACKED) {
 	SV *really = *++MARK;
+#  ifdef WIN32
+	value = (I32)do_aspawn(really, MARK, SP);
+#  else
 	value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
+#  endif
     }
-    else if (SP - MARK != 1)
+    else if (SP - MARK != 1) {
+#  ifdef WIN32
+	value = (I32)do_aspawn(Nullsv, MARK, SP);
+#  else
 	value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
+#  endif
+    }
     else {
 	value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
     }
@@ -4162,18 +4186,21 @@ PP(pp_exec)
     STRLEN n_a;
 
     if (PL_tainting) {
+	int some_arg_tainted = 0;
 	TAINT_ENV();
 	while (++MARK <= SP) {
 	    (void)SvPV_nolen(*MARK);      /* stringify for taint check */
-	    if (PL_tainted) 
+	    if (PL_tainted) {
+		some_arg_tainted = 1;
 		break;
+	    }
 	}
 	MARK = ORIGMARK;
 	/* XXX Remove warning at end of deprecation cycle --RD 2002-02  */
 	if (SP - MARK == 1) {
 	    TAINT_PROPER("exec");
 	}
-	else if (ckWARN2(WARN_TAINT, WARN_DEPRECATED)) {
+	else if (some_arg_tainted && ckWARN2(WARN_TAINT, WARN_DEPRECATED)) {
 	    Perl_warner(aTHX_ packWARN2(WARN_TAINT, WARN_DEPRECATED),
 		"Use of tainted arguments in %s is deprecated", "exec");
 	}
@@ -4952,7 +4979,7 @@ PP(pp_gservent)
     else if (which == OP_GSBYPORT) {
 #ifdef HAS_GETSERVBYPORT
 	char *proto = POPpbytex;
-	unsigned short port = POPu;
+	unsigned short port = (unsigned short)POPu;
 
 #ifdef HAS_HTONS
 	port = PerlSock_htons(port);
@@ -5199,6 +5226,9 @@ PP(pp_gpwent)
     case OP_GPWENT:
 #   ifdef HAS_GETPWENT
 	pwent  = getpwent();
+#ifdef POSIX_BC   /* In some cases pw_passwd has invalid addresses */
+	if (pwent) pwent = getpwnam(pwent->pw_name);
+#endif
 #   else
 	DIE(aTHX_ PL_no_func, "getpwent");
 #   endif
@@ -5430,12 +5460,22 @@ PP(pp_ggrent)
 	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
 	sv_setiv(sv, (IV)grent->gr_gid);
 
+#if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
 	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+	/* In UNICOS/mk (_CRAYMPP) the multithreading
+	 * versions (getgrnam_r, getgrgid_r)
+	 * seem to return an illegal pointer
+	 * as the group members list, gr_mem.
+	 * getgrent() doesn't even have a _r version
+	 * but the gr_mem is poisonous anyway.
+	 * So yes, you cannot get the list of group
+	 * members if building multithreaded in UNICOS/mk. */
 	for (elem = grent->gr_mem; elem && *elem; elem++) {
 	    sv_catpv(sv, *elem);
 	    if (elem[1])
 		sv_catpvn(sv, " ", 1);
 	}
+#endif
     }
 
     RETURN;