new_body_type doesn't need to subtract the offset, that's what

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

diff --git a/perl.c b/perl.c
index cf84f86..2d687be 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -181,6 +181,7 @@ perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
     PL_Dir = ipD;
     PL_Sock = ipS;
     PL_Proc = ipP;
+    INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
 
     return my_perl;
 }
@@ -205,7 +206,13 @@ perl_alloc(void)
     my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
 
     S_init_tls_and_interp(my_perl);
+#ifndef PERL_TRACK_MEMPOOL
     return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
+#else
+    Zero(my_perl, 1, PerlInterpreter);
+    INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
+    return my_perl;
+#endif
 }
 #endif /* PERL_IMPLICIT_SYS */
 
@@ -1280,19 +1287,28 @@ Releases a Perl interpreter.  See L<perlembed>.
 void
 perl_free(pTHXx)
 {
+#ifdef PERL_TRACK_MEMPOOL
+    /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
+       thread at thread exit.  */
+    while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
+       safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next));
+#endif
+
 #if defined(WIN32) || defined(NETWARE)
 #  if defined(PERL_IMPLICIT_SYS)
+    {
 #    ifdef NETWARE
-    void *host = nw_internal_host;
+       void *host = nw_internal_host;
 #    else
-    void *host = w32_internal_host;
+       void *host = w32_internal_host;
 #    endif
-    PerlMem_free(aTHXx);
+       PerlMem_free(aTHXx);
 #    ifdef NETWARE
-    nw_delete_internal_host(host);
+       nw_delete_internal_host(host);
 #    else
-    win32_delete_internal_host(host);
+       win32_delete_internal_host(host);
 #    endif
+    }
 #  else
     PerlMem_free(aTHXx);
 #  endif
@@ -2050,7 +2066,13 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
            || gMacPerl_AlwaysExtract
 #endif
            ) {
-           find_beginning(suidscript);
+
+           /* This will croak if suidscript is >= 0, as -x cannot be used with
+              setuid scripts.  */
+           forbid_setid('x', suidscript);
+           /* Hence you can't get here if suidscript >= 0  */
+
+           find_beginning();
            if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
                Perl_croak(aTHX_ "Can't chdir to %s",cddir);
        }
@@ -3500,7 +3522,6 @@ S_init_main_stash(pTHX)
     sv_setpvn(get_sv("/", TRUE), "\n", 1);
 }
 
-/* PSz 18 Nov 03  fdscript now global but do not change prototype */
 STATIC int
 S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv,
              int *suidscript)
@@ -4218,7 +4239,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
 }
 
 STATIC void
-S_find_beginning(pTHX_ const int suidscript)
+S_find_beginning(pTHX)
 {
     dVAR;
     register char *s;
@@ -4229,11 +4250,6 @@ S_find_beginning(pTHX_ const int suidscript)
 
     /* skip forward in input to the real script? */
 
-    /* This will croak if suidscript is >= 0, as -x cannot be used with
-       setuid scripts.  */
-    forbid_setid('x', suidscript);
-    /* Hence you can't get here if suidscript >= 0  */
-
 #ifdef MACOS_TRADITIONAL
     /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */