From: Dave Mitchell <davem@fdisolutions.com>
Date: Thu, 14 Nov 2002 23:03:00 +0000 (+0000)
Subject: optional code for debugging leaking scalars
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=eba0f806800ee6c16a404edf6a6aff3df57bdcb5;p=p5sagit%2Fp5-mst-13.2.git

optional code for debugging leaking scalars
Message-ID: <20021114230300.B18614@fdgroup.com>

p4raw-id: //depot/perl@18150
---

diff --git a/perl.c b/perl.c
index a2aa4d2..11da315 100644
--- a/perl.c
+++ b/perl.c
@@ -752,6 +752,24 @@ perl_destruct(pTHXx)
     if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
 	Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
 
+#ifdef DEBUG_LEAKING_SCALARS
+    if (PL_sv_count != 0) {
+	SV* sva;
+	SV* sv;
+	register SV* svend;
+
+	for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
+	    svend = &sva[SvREFCNT(sva)];
+	    for (sv = sva + 1; sv < svend; ++sv) {
+		if (SvTYPE(sv) != SVTYPEMASK) {
+		    PerlIO_printf(Perl_debug_log, "leaked: 0x%p\n", sv);
+		}
+	    }
+	}
+    }
+#endif
+
+
 #if defined(PERLIO_LAYERS)
     /* No more IO - including error messages ! */
     PerlIO_cleanup(aTHX);
diff --git a/sv.c b/sv.c
index a674986..cba547c 100644
--- a/sv.c
+++ b/sv.c
@@ -164,7 +164,28 @@ Public API:
 
 /* new_SV(): return a new, empty SV head */
 
-#define new_SV(p) \
+#ifdef DEBUG_LEAKING_SCALARS
+/* provide a real function for a debugger to play with */
+STATIC SV*
+S_new_SV(pTHX)
+{
+    SV* sv;
+
+    LOCK_SV_MUTEX;
+    if (PL_sv_root)
+	uproot_SV(sv);
+    else
+	sv = more_sv();
+    UNLOCK_SV_MUTEX;
+    SvANY(sv) = 0;
+    SvREFCNT(sv) = 1;
+    SvFLAGS(sv) = 0;
+    return sv;
+}
+#  define new_SV(p) (p)=S_new_SV(aTHX)
+
+#else
+#  define new_SV(p) \
     STMT_START {					\
 	LOCK_SV_MUTEX;					\
 	if (PL_sv_root)					\
@@ -176,6 +197,7 @@ Public API:
 	SvREFCNT(p) = 1;				\
 	SvFLAGS(p) = 0;					\
     } STMT_END
+#endif
 
 
 /* del_SV(): return an empty SV head to the free list */