From: Nicholas Clark <nick@ccl4.org>
Date: Fri, 24 Jun 2005 14:04:19 +0000 (+0000)
Subject: Extend DEBUG_LEAKING_SCALARS_FORK_DUMP so it can also dump scalars
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=41e4abd8e288135291940b1765c485a707618c20;p=p5sagit%2Fp5-mst-13.2.git

Extend DEBUG_LEAKING_SCALARS_FORK_DUMP so it can also dump scalars
which become unreferenced. This is less likely to be successful.
The #define needs a better name.

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

diff --git a/embed.fnc b/embed.fnc
index a9b5afb..d5f44f3 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1517,6 +1517,10 @@ dpR	|bool	|is_gv_magical_sv|SV *name|U32 flags
 
 ApR	|bool	|stashpv_hvname_match|NN const COP *cop|NN const HV *hv
 
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+p	|void	|dump_sv_child	|SV *sv
+#endif
+
 END_EXTERN_C
 /*
  * ex: set ts=8 sts=4 sw=4 noet:
diff --git a/embed.h b/embed.h
index 7f67c22..c7745b3 100644
--- a/embed.h
+++ b/embed.h
@@ -1632,6 +1632,11 @@
 #define is_gv_magical_sv	Perl_is_gv_magical_sv
 #endif
 #define stashpv_hvname_match	Perl_stashpv_hvname_match
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+#ifdef PERL_CORE
+#define dump_sv_child		Perl_dump_sv_child
+#endif
+#endif
 #define ck_anoncode		Perl_ck_anoncode
 #define ck_bitop		Perl_ck_bitop
 #define ck_concat		Perl_ck_concat
@@ -3599,6 +3604,11 @@
 #define is_gv_magical_sv(a,b)	Perl_is_gv_magical_sv(aTHX_ a,b)
 #endif
 #define stashpv_hvname_match(a,b)	Perl_stashpv_hvname_match(aTHX_ a,b)
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+#ifdef PERL_CORE
+#define dump_sv_child(a)	Perl_dump_sv_child(aTHX_ a)
+#endif
+#endif
 #define ck_anoncode(a)		Perl_ck_anoncode(aTHX_ a)
 #define ck_bitop(a)		Perl_ck_bitop(aTHX_ a)
 #define ck_concat(a)		Perl_ck_concat(aTHX_ a)
diff --git a/embedvar.h b/embedvar.h
index 2f3640a..985e015 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -228,6 +228,7 @@
 #define PL_doextract		(vTHX->Idoextract)
 #define PL_doswitches		(vTHX->Idoswitches)
 #define PL_dowarn		(vTHX->Idowarn)
+#define PL_dumper_fd		(vTHX->Idumper_fd)
 #define PL_e_script		(vTHX->Ie_script)
 #define PL_egid			(vTHX->Iegid)
 #define PL_encoding		(vTHX->Iencoding)
@@ -531,6 +532,7 @@
 #define PL_Idoextract		PL_doextract
 #define PL_Idoswitches		PL_doswitches
 #define PL_Idowarn		PL_dowarn
+#define PL_Idumper_fd		PL_dumper_fd
 #define PL_Ie_script		PL_e_script
 #define PL_Iegid		PL_egid
 #define PL_Iencoding		PL_encoding
diff --git a/intrpvar.h b/intrpvar.h
index 8a93f2a..519093f 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -539,10 +539,13 @@ PERLVARI(Irehash_seed_set, bool, FALSE)	/* 582 hash initialized? */
    taken out of blead soon, and relevant prototypes changed.  */
 PERLVARI(Ifdscript, int, -1)	/* fd for script */
 PERLVARI(Isuidscript, int, -1)	/* fd for suid script */
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+/* File descriptor to talk to the child which dumps scalars.  */
+PERLVARI(Idumper_fd, int, -1)
+#endif
 /* New variables must be added to the very end, before this comment,
  * for binary compatibility (the offsets of the old members must not change).
  * (Don't forget to add your variable also to perl_clone()!)
  * XSUB.h provides wrapper functions via perlapi.h that make this
  * irrelevant, but not all code may be expected to #include XSUB.h.
  */
-
diff --git a/perl.c b/perl.c
index 838f911..1d2ab24 100644
--- a/perl.c
+++ b/perl.c
@@ -389,6 +389,48 @@ Perl_nothreadhook(pTHX)
     return 0;
 }
 
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+void
+Perl_dump_sv_child(pTHX_ SV *sv)
+{
+    ssize_t got;
+    int sock = PL_dumper_fd;
+    SV *target;
+
+    if(sock == -1)
+	return;
+
+    PerlIO_flush(Perl_debug_log);
+
+    got = write(sock, &sv, sizeof(sv));
+
+    if(got < 0) {
+	perror("Debug leaking scalars parent write failed");
+	abort();
+    }
+    if(got < sizeof(target)) {
+	perror("Debug leaking scalars parent short write");
+	abort();
+    }
+
+    got = read(sock, &target, sizeof(target));
+
+    if(got < 0) {
+	perror("Debug leaking scalars parent read failed");
+	abort();
+    }
+    if(got < sizeof(target)) {
+	perror("Debug leaking scalars parent short read");
+	abort();
+    }
+
+    if (target != sv) {
+	perror("Debug leaking scalars parent target != sv");
+	abort();
+    }
+}
+#endif
+
 /*
 =for apidoc perl_destruct
 
@@ -404,7 +446,6 @@ perl_destruct(pTHXx)
     volatile int destruct_level;  /* 0=none, 1=full, 2=full with checks */
     HV *hv;
 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
-    int sock;
     pid_t child;
 #endif
 
@@ -464,9 +505,9 @@ perl_destruct(pTHXx)
 	    abort();
 	}
 	if (!child) {
+	    int sock = fd[1];
 	    /* We are the child */
 	    close(fd[0]);
-	    sock = fd[1];
 
 	    while (1) {
 		SV *target;
@@ -499,7 +540,7 @@ perl_destruct(pTHXx)
 	    }
 	    _exit(0);
 	}
-	sock = fd[0];
+	PL_dumper_fd = fd[0];
 	close(fd[1]);
     }
 #endif
@@ -951,11 +992,6 @@ perl_destruct(pTHXx)
 	    svend = &sva[SvREFCNT(sva)];
 	    for (sv = sva + 1; sv < svend; ++sv) {
 		if (SvTYPE(sv) != SVTYPEMASK) {
-#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
-		    ssize_t got;
-		    SV *target;
-#endif
-
 		    PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
 			" flags=0x%"UVxf
 			" refcnt=%"UVuf pTHX__FORMAT "\n"
@@ -968,31 +1004,8 @@ perl_destruct(pTHXx)
 			    PL_op_name[sv->sv_debug_optype]: "(none)",
 			sv->sv_debug_cloned ? " (cloned)" : ""
 		    );
-
 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
-		    PerlIO_flush(Perl_debug_log);
-
-		    got = write(sock, &sv, sizeof(sv));
-
-		    if(got < 0) {
-			perror("Debug leaking scalars parent write failed");
-			abort();
-		    }
-		    if(got < sizeof(target)) {
-			perror("Debug leaking scalars parent short write");
-			abort();
-		    }
-
-		    got = read(sock, &target, sizeof(target));
-
-		    if(got < 0) {
-			perror("Debug leaking scalars parent read failed");
-			abort();
-		    }
-		    if(got < sizeof(target)) {
-			perror("Debug leaking scalars parent short read");
-			abort();
-		    }
+		    Perl_dump_sv_child(aTHX_ sv);
 #endif
 		}
 	    }
@@ -1006,6 +1019,7 @@ perl_destruct(pTHXx)
 	   This seems to be the least effort way of timing out on reaping
 	   its exit status.  */
 	struct timeval waitfor = {4, 0};
+	int sock = PL_dumper_fd;
 
 	shutdown(sock, 1);
 	FD_ZERO(&rset);
diff --git a/perlapi.h b/perlapi.h
index 5f3b37e..d4633b6 100644
--- a/perlapi.h
+++ b/perlapi.h
@@ -252,6 +252,8 @@ END_EXTERN_C
 #define PL_doswitches		(*Perl_Idoswitches_ptr(aTHX))
 #undef  PL_dowarn
 #define PL_dowarn		(*Perl_Idowarn_ptr(aTHX))
+#undef  PL_dumper_fd
+#define PL_dumper_fd		(*Perl_Idumper_fd_ptr(aTHX))
 #undef  PL_e_script
 #define PL_e_script		(*Perl_Ie_script_ptr(aTHX))
 #undef  PL_egid
diff --git a/proto.h b/proto.h
index 36a0c41..7b060cf 100644
--- a/proto.h
+++ b/proto.h
@@ -2989,6 +2989,10 @@ PERL_CALLCONV bool	Perl_stashpv_hvname_match(pTHX_ const COP *cop, const HV *hv)
 			__attribute__nonnull__(pTHX_2);
 
 
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+PERL_CALLCONV void	Perl_dump_sv_child(pTHX_ SV *sv);
+#endif
+
 END_EXTERN_C
 /*
  * ex: set ts=8 sts=4 sw=4 noet:
diff --git a/sv.c b/sv.c
index 4d1bfb9..45da2bc 100644
--- a/sv.c
+++ b/sv.c
@@ -5722,10 +5722,14 @@ Perl_sv_free(pTHX_ SV *sv)
 	    SvREFCNT(sv) = (~(U32)0)/2;
 	    return;
 	}
-	if (ckWARN_d(WARN_INTERNAL))
+	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);
+#endif
+	}
 	return;
     }
     if (--(SvREFCNT(sv)) > 0)