X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=16f3e02ee9da05eeca0ab8a37b592ddd997d45b7;hb=e5c81feb3d32a96869ed78abc5cecef7e294da38;hp=38591e9ea596b28c7177448af4d6134069c76637;hpb=3d35f11b2518ea9ea787f5db97c6c3e7cff04dbf;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/util.c b/util.c
index 38591e9..16f3e02 100644
--- a/util.c
+++ b/util.c
@@ -1896,7 +1896,12 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
 	    PerlIO *serr = Perl_error_log;
 	    PerlIO_write(serr, message, msglen);
 #ifdef LEAKTEST
-	    DEBUG_L(xstat());
+	    DEBUG_L(*message == '!' 
+		? (xstat(message[1]=='!'
+			 ? (message[2]=='!' ? 2 : 1)
+			 : 0)
+		   , 0)
+		: 0);
 #endif
 	    (void)PerlIO_flush(serr);
 	}
@@ -2402,9 +2407,9 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
 	PerlLIO_close(p[This]);
 	p[This] = p[that];
     }
-    FDPID_LOCK;
+    LOCK_FDPID_MUTEX;
     sv = *av_fetch(PL_fdpid,p[This],TRUE);
-    FDPID_UNLOCK;
+    UNLOCK_FDPID_MUTEX;
     (void)SvUPGRADE(sv,SVt_IV);
     SvIVX(sv) = pid;
     PL_forkprocess = pid;
@@ -2622,9 +2627,9 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
     int saved_win32_errno;
 #endif
 
-    FDPID_LOCK;
+    LOCK_FDPID_MUTEX;
     svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
-    FDPID_UNLOCK;
+    UNLOCK_FDPID_MUTEX;
     pid = SvIVX(*svp);
     SvREFCNT_dec(*svp);
     *svp = &PL_sv_undef;
@@ -2676,6 +2681,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 
     if (!pid)
 	return -1;
+#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
     if (pid > 0) {
 	sprintf(spid, "%"IVdf, (IV)pid);
 	svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
@@ -2698,6 +2704,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 	    return pid;
 	}
     }
+#endif
 #ifdef HAS_WAITPID
 #  ifdef HAS_WAITPID_RUNTIME
     if (!HAS_WAITPID_RUNTIME)
@@ -3497,33 +3504,32 @@ Perl_condpair_magic(pTHX_ SV *sv)
 }
 
 SV *
-Perl_lock(pTHX_ SV *osv)
+Perl_sv_lock(pTHX_ SV *osv)
 {
     MAGIC *mg;
     SV *sv = osv;
 
-    SvLOCK(osv);
+    LOCK_SV_LOCK_MUTEX;
     if (SvROK(sv)) {
 	sv = SvRV(sv);
-	SvUNLOCK(osv);
-	SvLOCK(sv);
     }
 
     mg = condpair_magic(sv);
     MUTEX_LOCK(MgMUTEXP(mg));
     if (MgOWNER(mg) == thr)
 	MUTEX_UNLOCK(MgMUTEXP(mg));
-     else {
+    else {
 	while (MgOWNER(mg))
 	    COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
 	MgOWNER(mg) = thr;
-	DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n",
+	DEBUG_S(PerlIO_printf(Perl_debug_log,
+			      "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n",
 			      PTR2UV(thr), PTR2UV(sv));)
 	MUTEX_UNLOCK(MgMUTEXP(mg));
 	SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
     }
-  SvUNLOCK(sv);
-  return sv;
+    UNLOCK_SV_LOCK_MUTEX;
+    return sv;
 }
 
 /*
@@ -3889,21 +3895,48 @@ Perl_my_atof(pTHX_ const char* s)
 }
 
 void
-Perl_report_closed_fh(pTHX_ GV *gv, IO *io, const char *func, const char *obj)
-{
-    SV *sv;
-    char *name;
-
-    assert(gv);
-
-    sv = sv_newmortal();
-    gv_efullname3(sv, gv, Nullch);
-    name = SvPVX(sv);
+Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
+{
+    char *vile;
+    I32   warn_type;
+    char *func =
+	op == OP_READLINE   ? "readline"  :	/* "<HANDLE>" not nice */
+	op == OP_LEAVEWRITE ? "write" :		/* "write exit" not nice */
+	PL_op_desc[op];
+    char *pars = OP_IS_FILETEST(op) ? "" : "()";
+    char *type = OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET) ?
+                     "socket" : "filehandle";
+    char *name = NULL;
+
+    if (io && IoTYPE(io) == IoTYPE_CLOSED) {
+	vile = "closed";
+	warn_type = WARN_CLOSED;
+    }
+    else {
+	vile = "unopened";
+	warn_type = WARN_UNOPENED;
+    }
 
-    Perl_warner(aTHX_ WARN_CLOSED, "%s() on closed %s %s", func, obj, name);
+    if (gv && isGV(gv)) {
+	SV *sv = sv_newmortal();
+	gv_efullname4(sv, gv, Nullch, FALSE);
+	name = SvPVX(sv);
+    }
 
-    if (io && IoDIRP(io))
-	Perl_warner(aTHX_ WARN_CLOSED,
-		    "\t(Are you trying to call %s() on dirhandle %s?)\n",
-		    func, name);
+    if (name && *name) {
+	Perl_warner(aTHX_ warn_type,
+		    "%s%s on %s %s %s", func, pars, vile, type, name);
+	if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+	    Perl_warner(aTHX_ warn_type,
+			"\t(Are you trying to call %s%s on dirhandle %s?)\n",
+			func, pars, name);
+    }
+    else {
+	Perl_warner(aTHX_ warn_type,
+		    "%s%s on %s %s", func, pars, vile, type);
+	if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+	    Perl_warner(aTHX_ warn_type,
+			"\t(Are you trying to call %s%s on dirhandle?)\n",
+			func, pars);
+    }
 }