From: Stas Bekman <stas@stason.org>
Date: Mon, 19 Apr 2004 18:10:01 +0000 (-0700)
Subject: [patch] log the interpreter id in warnings
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=472d47bc592782703b1974a20dbd65f617e06414;p=p5sagit%2Fp5-mst-13.2.git

[patch] log the interpreter id in warnings
Message-ID: <40847869.1000906@stason.org>

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

diff --git a/gv.c b/gv.c
index 8a27065..68328ac 100644
--- a/gv.c
+++ b/gv.c
@@ -1246,7 +1246,8 @@ Perl_gp_free(pTHX_ GV *gv)
     if (gp->gp_refcnt == 0) {
 	if (ckWARN_d(WARN_INTERNAL))
 	    Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
-			"Attempt to free unreferenced glob pointers");
+			"Attempt to free unreferenced glob pointers"
+                        pTHX__FORMAT pTHX__VALUE);
         return;
     }
     if (gp->gp_cv) {
diff --git a/handy.h b/handy.h
index b88c729..19a5934 100644
--- a/handy.h
+++ b/handy.h
@@ -665,3 +665,19 @@ hopefully catches attempts to access uninitialized memory.
 # endif
 #endif
 
+/* convenience debug macros */
+#ifdef USE_ITHREADS
+#define pTHX_FORMAT  "Perl interpreter: 0x%p"
+#define pTHX__FORMAT ", Perl interpreter: 0x%p"
+#define pTHX_VALUE_   (unsigned long)my_perl,
+#define pTHX_VALUE    (unsigned long)my_perl
+#define pTHX__VALUE_ ,(unsigned long)my_perl,
+#define pTHX__VALUE  ,(unsigned long)my_perl
+#else
+#define pTHX_FORMAT 
+#define pTHX__FORMAT
+#define pTHX_VALUE_ 
+#define pTHX_VALUE
+#define pTHX__VALUE_ 
+#define pTHX__VALUE
+#endif /* USE_ITHREADS */
diff --git a/hv.c b/hv.c
index 627140b..ca945f6 100644
--- a/hv.c
+++ b/hv.c
@@ -2016,9 +2016,10 @@ S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
     UNLOCK_STRTAB_MUTEX;
     if (!found && ckWARN_d(WARN_INTERNAL))
 	Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
-                    "Attempt to free non-existent shared string '%s'%s",
+                    "Attempt to free non-existent shared string '%s'%s"
+                    pTHX__FORMAT,
                     hek ? HEK_KEY(hek) : str,
-                    (k_flags & HVhek_UTF8) ? " (utf8)" : "");
+                    ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
     if (k_flags & HVhek_FREEKEY)
 	Safefree(str);
 }
diff --git a/perl.c b/perl.c
index a769190..63438e8 100644
--- a/perl.c
+++ b/perl.c
@@ -847,7 +847,9 @@ perl_destruct(pTHXx)
 	    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);
+		    PerlIO_printf(Perl_debug_log, "leaked: 0x%p"
+                                  pTHX__FORMAT "\n",
+                                  sv pTHX__VALUE);
 		}
 	    }
 	}
diff --git a/sv.c b/sv.c
index 36fbc21..c4aa66c 100644
--- a/sv.c
+++ b/sv.c
@@ -246,8 +246,8 @@ S_del_sv(pTHX_ SV *p)
 	if (!ok) {
 	    if (ckWARN_d(WARN_INTERNAL))	
 	        Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
-			    "Attempt to free non-arena SV: 0x%"UVxf,
-			    PTR2UV(p));
+			    "Attempt to free non-arena SV: 0x%"UVxf
+                            pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
 	    return;
 	}
     }
@@ -5654,8 +5654,8 @@ Perl_sv_free(pTHX_ SV *sv)
 	}
 	if (ckWARN_d(WARN_INTERNAL))
 	    Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
-                        "Attempt to free unreferenced scalar: SV 0x%"UVxf,
-                PTR2UV(sv));
+                        "Attempt to free unreferenced scalar: SV 0x%"UVxf
+                        pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
 	return;
     }
     if (--(SvREFCNT(sv)) > 0)
@@ -5670,8 +5670,8 @@ Perl_sv_free2(pTHX_ SV *sv)
     if (SvTEMP(sv)) {
 	if (ckWARN_d(WARN_DEBUGGING))
 	    Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
-			"Attempt to free temp prematurely: SV 0x%"UVxf,
-			PTR2UV(sv));
+			"Attempt to free temp prematurely: SV 0x%"UVxf
+                        pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
 	return;
     }
 #endif