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 1d6bc6a..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
 
@@ -428,6 +469,7 @@ perl_destruct(pTHXx)
         int x = 0;
 
         JMPENV_PUSH(x);
+       PERL_UNUSED_VAR(x);
         if (PL_endav && !PL_minus_c)
             call_list(PL_scopestack_ix, PL_endav);
         JMPENV_POP;
@@ -464,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;
@@ -498,7 +563,7 @@ perl_destruct(pTHXx)
            }
            _exit(0);
        }
-       sock = fd[0];
+       PL_dumper_fd = fd[0];
        close(fd[1]);
     }
 #endif
@@ -506,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)) {
@@ -514,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;
@@ -946,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"
@@ -963,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
                }
            }
@@ -1001,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);
@@ -1231,15 +1273,10 @@ setuid perl scripts securely.\n");
     if (!PL_rehash_seed_set)
         PL_rehash_seed = get_hash_seed();
     {
-        char *s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
+       const char *s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
 
-        if (s) {
-             int i = atoi(s);
-
-             if (i == 1)
-                  PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n",
-                                PL_rehash_seed);
-        }
+       if (s && (atoi(s) == 1))
+           PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n", PL_rehash_seed);
     }
 #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
 
@@ -1256,10 +1293,10 @@ setuid perl scripts securely.\n");
         * --jhi */
         const char *s = NULL;
         int i;
-        UV mask =
+        const UV mask =
           ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
          /* Do the mask check only if the args seem like aligned. */
-        UV aligned =
+        const UV aligned =
           (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
 
         /* See if all the arguments are contiguous in memory.  Note