From: Nicholas Clark <nick@ccl4.org>
Date: Wed, 22 Jun 2005 16:37:06 +0000 (+0000)
Subject: Add facility to fork() early in perl_destruct and use the child to
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2aa47728aa947a41f1d2abaa0249b6e8da98653a;p=p5sagit%2Fp5-mst-13.2.git

Add facility to fork() early in perl_destruct and use the child to
dump out leaked scalars (enabled with DEBUG_LEAKING_SCALARS_FORK_DUMP
when DEBUG_LEAKING_SCALARS is already in force)

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

diff --git a/perl.c b/perl.c
index 6a3b3f8..1d6bc6a 100644
--- a/perl.c
+++ b/perl.c
@@ -92,6 +92,12 @@ char *nw_get_sitelib(const char *pl);
 #include <unistd.h>
 #endif
 
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+#  ifdef I_SYS_WAIT
+#   include <sys/wait.h>
+#  endif
+#endif
+
 #ifdef __BEOS__
 #  define HZ 1000000
 #endif
@@ -397,6 +403,10 @@ perl_destruct(pTHXx)
     dVAR;
     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
 
     /* wait for all pseudo-forked children to finish */
     PERL_WAIT_FOR_CHILDREN;
@@ -433,6 +443,66 @@ perl_destruct(pTHXx)
         return STATUS_NATIVE_EXPORT;
     }
 
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+    if (destruct_level != 0) {
+	/* Fork here to create a child. Our child's job is to preserve the
+	   state of scalars prior to destruction, so that we can instruct it
+	   to dump any scalars that we later find have leaked.
+	   There's no subtlety in this code - it assumes POSIX, and it doesn't
+	   fail gracefully  */
+	int fd[2];
+
+	if(socketpair(AF_UNIX, SOCK_STREAM, 0, fd)) {
+	    perror("Debug leaking scalars socketpair failed");
+	    abort();
+	}
+
+	child = fork();
+	if(child == -1) {
+	    perror("Debug leaking scalars fork failed");
+	    abort();
+	}
+	if (!child) {
+	    /* We are the child */
+	    close(fd[0]);
+	    sock = fd[1];
+
+	    while (1) {
+		SV *target;
+		ssize_t got = read(sock, &target, sizeof(target));
+
+		if(got == 0)
+		    break;
+		if(got < 0) {
+		    perror("Debug leaking scalars child read failed");
+		    abort();
+		}
+		if(got < sizeof(target)) {
+		    perror("Debug leaking scalars child short read");
+		    abort();
+		}
+		sv_dump(target);
+		PerlIO_flush(Perl_debug_log);
+
+		/* Write something back as synchronisation.  */
+		got = write(sock, &target, sizeof(target));
+
+		if(got < 0) {
+		    perror("Debug leaking scalars child write failed");
+		    abort();
+		}
+		if(got < sizeof(target)) {
+		    perror("Debug leaking scalars child short write");
+		    abort();
+		}
+	    }
+	    _exit(0);
+	}
+	sock = fd[0];
+	close(fd[1]);
+    }
+#endif
+    
     /* We must account for everything.  */
 
     /* Destroy the main CV and syntax tree */
@@ -876,6 +946,11 @@ 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"
@@ -888,10 +963,53 @@ 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();
+		    }
+#endif
 		}
 	    }
 	}
     }
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+    {
+	int status;
+	fd_set rset;
+	/* Wait for up to 4 seconds for child to terminate.
+	   This seems to be the least effort way of timing out on reaping
+	   its exit status.  */
+	struct timeval waitfor = {4, 0};
+
+	shutdown(sock, 1);
+	FD_ZERO(&rset);
+	FD_SET(sock, &rset);
+	select(sock + 1, &rset, NULL, NULL, &waitfor);
+	waitpid(child, &status, WNOHANG);
+	close(sock);
+    }
+#endif
 #endif
     PL_sv_count = 0;