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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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)