X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/f36eea1037c5e636f0a49c0b179f8f7dce70d331..1bb10054bdf0ca9f15c14bdc94158615f8bdf418:/pp_sys.c

diff --git a/pp_sys.c b/pp_sys.c
index bf2b352..99f1eb5 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -838,24 +838,26 @@ PP(pp_untie)
 	SV *obj = SvRV(mg->mg_obj);
 	GV *gv;
 	CV *cv = NULL;
-	if ((gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE)) &&
-            isGV(gv) && (cv = GvCV(gv))) {
-	    PUSHMARK(SP);
-	    XPUSHs(SvTIED_obj((SV*)gv, mg));
-	    XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
-	    PUTBACK;
-	    ENTER;
-	    call_sv((SV *)cv, G_VOID);
-	    LEAVE;
-	    SPAGAIN;
-        }
-        else if (ckWARN(WARN_UNTIE)) {
-	    if (mg && SvREFCNT(obj) > 1)
-		Perl_warner(aTHX_ WARN_UNTIE,
-		    "untie attempted while %"UVuf" inner references still exist",
-		    (UV)SvREFCNT(obj) - 1 ) ;
+        if (obj) {
+	    if ((gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE)) &&
+               isGV(gv) && (cv = GvCV(gv))) {
+	       PUSHMARK(SP);
+	       XPUSHs(SvTIED_obj((SV*)gv, mg));
+	       XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
+	       PUTBACK;
+	       ENTER;
+	       call_sv((SV *)cv, G_VOID);
+	       LEAVE;
+	       SPAGAIN;
+            }
+           else if (ckWARN(WARN_UNTIE)) {
+	       if (mg && SvREFCNT(obj) > 1)
+		  Perl_warner(aTHX_ WARN_UNTIE,
+		      "untie attempted while %"UVuf" inner references still exist",
+		       (UV)SvREFCNT(obj) - 1 ) ;
+           }
         }
-	sv_unmagic(sv, how);
+	sv_unmagic(sv, how) ;
     }
     RETPUSHYES;
 }
@@ -2066,7 +2068,7 @@ PP(pp_truncate)
 	else {
 	    SV *sv = POPs;
 	    char *name;
-	  
+	
 	    if (SvTYPE(sv) == SVt_PVGV) {
 	        tmpgv = (GV*)sv;		/* *main::FRED for example */
 		goto do_ftruncate;
@@ -2280,7 +2282,7 @@ PP(pp_socket)
 
 PP(pp_sockpair)
 {
-#ifdef HAS_SOCKETPAIR
+#if defined (HAS_SOCKETPAIR) || defined (HAS_SOCKET)
     dSP;
     GV *gv1;
     GV *gv2;
@@ -2469,6 +2471,7 @@ PP(pp_accept)
     struct sockaddr saddr;	/* use a struct to avoid alignment problems */
     Sock_size_t len = sizeof saddr;
     int fd;
+    int fd2;
 
     ggv = (GV*)POPs;
     ngv = (GV*)POPs;
@@ -2489,7 +2492,11 @@ PP(pp_accept)
     if (IoIFP(nstio))
 	do_close(ngv, FALSE);
     IoIFP(nstio) = PerlIO_fdopen(fd, "r");
-    IoOFP(nstio) = PerlIO_fdopen(fd, "w");
+    /* FIXME: we dup(fd) here so that refcounting of fd's does not inhibit
+       fclose of IoOFP's FILE * - and hence leak memory.
+       Special treatment of _this_ case of IoIFP != IoOFP seems wrong.
+     */
+    IoOFP(nstio) = PerlIO_fdopen(fd2 = PerlLIO_dup(fd), "w");
     IoTYPE(nstio) = IoTYPE_SOCKET;
     if (!IoIFP(nstio) || !IoOFP(nstio)) {
 	if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
@@ -2499,6 +2506,7 @@ PP(pp_accept)
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
     fcntl(fd, F_SETFD, fd > PL_maxsysfd);	/* ensure close-on-exec */
+    fcntl(fd2, F_SETFD, fd2 > PL_maxsysfd);	/* ensure close-on-exec */
 #endif
 
 #ifdef EPOC
@@ -3410,8 +3418,9 @@ PP(pp_chdir)
                 deprecate("chdir('') or chdir(undef) as chdir()");
             tmps = SvPV(*svp, n_a);
         }
-        else {            
+        else {
             PUSHi(0);
+            TAINT_PROPER("chdir");
             RETURN;
         }
     }
@@ -3513,9 +3522,8 @@ PP(pp_rename)
 
 PP(pp_link)
 {
-    dSP;
 #ifdef HAS_LINK
-    dTARGET;
+    dSP; dTARGET;
     STRLEN n_a;
     char *tmps2 = POPpx;
     char *tmps = SvPV(TOPs, n_a);
@@ -3923,8 +3931,11 @@ PP(pp_fork)
 	RETSETUNDEF;
     if (!childpid) {
 	/*SUPPRESS 560*/
-	if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
+	if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV))) {
+            SvREADONLY_off(GvSV(tmpgv));
 	    sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
+            SvREADONLY_on(GvSV(tmpgv));
+        }
 	hv_clear(PL_pidstatus);	/* no kids, so don't wait for 'em */
     }
     PUSHi(childpid);
@@ -4026,7 +4037,17 @@ PP(pp_system)
 	 Pid_t childpid;
 	 int status;
 	 Sigsave_t ihand,qhand;     /* place to save signals during system() */
-	 
+	
+	 if (PL_tainting) {
+	     SV *cmd = NULL;
+	     if (PL_op->op_flags & OPf_STACKED)
+		cmd = *(MARK + 1);
+	     else if (SP - MARK != 1)
+		cmd = *SP;
+	     if (cmd && *(SvPV_nolen(cmd)) != '/')
+		TAINT_ENV();
+	 }
+
 	 if (PerlProc_pipe(pp) >= 0)
 	      did_pipes = 1;
 	 while ((childpid = PerlProc_fork()) == -1) {
@@ -4062,7 +4083,7 @@ PP(pp_system)
 	      if (did_pipes) {
 		   int errkid;
 		   int n = 0, n1;
-		   
+		
 		   while (n < sizeof(int)) {
 			n1 = PerlLIO_read(pp[0],
 					  (void*)(((char*)&errkid)+n),
@@ -4299,6 +4320,10 @@ PP(pp_time)
    it's supported.    --AD  9/96.
 */
 
+#ifdef __BEOS__
+#  define HZ 1000000
+#endif
+
 #ifndef HZ
 #  ifdef CLK_TCK
 #    define HZ CLK_TCK