From: Nicholas Clark <nick@ccl4.org>
Date: Thu, 10 Jan 2008 21:15:02 +0000 (+0000)
Subject: Ensure DEBUG_LEAKING_SCALARS_ABORT can't be circumvented by fatal
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=bfd95973f1e91e9be1076173ba89a5c91f404e09;p=p5sagit%2Fp5-mst-13.2.git

Ensure DEBUG_LEAKING_SCALARS_ABORT can't be circumvented by fatal
warnings. Add an abort() if you try to dup a freed scalar.

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

diff --git a/sv.c b/sv.c
index b26379f..37f527f 100644
--- a/sv.c
+++ b/sv.c
@@ -5424,15 +5424,23 @@ Perl_sv_free(pTHX_ SV *sv)
 	    return;
 	}
 	if (ckWARN_d(WARN_INTERNAL)) {
-	    Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
-                        "Attempt to free unreferenced scalar: SV 0x%"UVxf
-                        pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
 	    Perl_dump_sv_child(aTHX_ sv);
 #else
   #ifdef DEBUG_LEAKING_SCALARS
-	sv_dump(sv);
+	    sv_dump(sv);
   #endif
+#ifdef DEBUG_LEAKING_SCALARS_ABORT
+	    if (PL_warnhook == PERL_WARNHOOK_FATAL
+		|| ckDEAD(packWARN(WARN_INTERNAL))) {
+		/* Don't let Perl_warner cause us to escape our fate:  */
+		abort();
+	    }
+#endif
+	    /* This may not return:  */
+	    Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
+                        "Attempt to free unreferenced scalar: SV 0x%"UVxf
+                        pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
 #endif
 	}
 #ifdef DEBUG_LEAKING_SCALARS_ABORT
@@ -10138,8 +10146,14 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param)
     dVAR;
     SV *dstr;
 
-    if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
+    if (!sstr)
+	return NULL;
+    if (SvTYPE(sstr) == SVTYPEMASK) {
+#ifdef DEBUG_LEAKING_SCALARS_ABORT
+	abort();
+#endif
 	return NULL;
+    }
     /* look for it in the table first */
     dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
     if (dstr)