On OS X to use perl's malloc need to USE_PERL_SBRK and emulate sbrk()

[p5sagit/p5-mst-13.2.git] / perl.c

diff --git a/perl.c b/perl.c
index f8fd6d3..c87be80 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
 
@@ -465,8 +506,31 @@ perl_destruct(pTHXx)
        }
        if (!child) {
            /* We are the child */
+
+           const int sock = fd[1];
+           const int debug_fd = PerlIO_fileno(Perl_debug_log);
+           int f;
+
            close(fd[0]);
-           sock = fd[1];
+
+           /* We need to close all other file descriptors otherwise we end up
+              with interesting hangs, where the parent closes its end of a
+              pipe, and sits waiting for (another) child to terminate. Only
+              that child never terminates, because it never gets EOF, because
+              we also have the far end of the pipe open.  */
+
+           f = sysconf(_SC_OPEN_MAX);
+           if(f < 0) {
+               perror("Debug leaking scalars sysconf failed");
+               abort();
+           }
+           while (f--) {
+               if (f == sock)
+                   continue;
+               if (f == debug_fd)
+                   continue;
+               close(f);
+           }
 
            while (1) {
                SV *target;
@@ -499,7 +563,7 @@ perl_destruct(pTHXx)
            }
            _exit(0);
        }
-       sock = fd[0];
+       PL_dumper_fd = fd[0];
        close(fd[1]);
     }
 #endif
@@ -507,6 +571,11 @@ perl_destruct(pTHXx)
     /* We must account for everything.  */
 
     /* Destroy the main CV and syntax tree */
+    /* Do this now, because destroying ops can cause new SVs to be generated
+       in Perl_pad_swipe, and when running with -DDEBUG_LEAKING_SCALARS they
+       PL_curcop to point to a valid op from which the filename structure
+       member is copied.  */
+    PL_curcop = &PL_compiling;
     if (PL_main_root) {
        /* ensure comppad/curpad to refer to main's pad */
        if (CvPADLIST(PL_main_cv)) {
@@ -515,7 +584,6 @@ perl_destruct(pTHXx)
        op_free(PL_main_root);
        PL_main_root = Nullop;
     }
-    PL_curcop = &PL_compiling;
     PL_main_start = Nullop;
     SvREFCNT_dec(PL_main_cv);
     PL_main_cv = Nullcv;
@@ -947,11 +1015,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"
@@ -964,31 +1027,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
                }
            }
@@ -1002,6 +1042,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);