fix memory leak on Windows (PL_sys_intern contents were never

freed)

p4raw-id: //depot/perl@6299

diff --git a/embed.h b/embed.h
index 33ef720..301619e 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -825,16 +825,15 @@
 #define mg_dup                 Perl_mg_dup
 #define sv_dup                 Perl_sv_dup
 #if defined(HAVE_INTERP_INTERN)
+#define sys_intern_clear       Perl_sys_intern_clear
 #define sys_intern_dup         Perl_sys_intern_dup
+#define sys_intern_init                Perl_sys_intern_init
 #endif
 #define ptr_table_new          Perl_ptr_table_new
 #define ptr_table_fetch                Perl_ptr_table_fetch
 #define ptr_table_store                Perl_ptr_table_store
 #define ptr_table_split                Perl_ptr_table_split
 #endif
-#if defined(HAVE_INTERP_INTERN)
-#define sys_intern_init                Perl_sys_intern_init
-#endif
 #if defined(PERL_OBJECT)
 #else
 #endif
@@ -2266,16 +2265,15 @@
 #define mg_dup(a)              Perl_mg_dup(aTHX_ a)
 #define sv_dup(a)              Perl_sv_dup(aTHX_ a)
 #if defined(HAVE_INTERP_INTERN)
+#define sys_intern_clear()     Perl_sys_intern_clear(aTHX)
 #define sys_intern_dup(a,b)    Perl_sys_intern_dup(aTHX_ a,b)
+#define sys_intern_init()      Perl_sys_intern_init(aTHX)
 #endif
 #define ptr_table_new()                Perl_ptr_table_new(aTHX)
 #define ptr_table_fetch(a,b)   Perl_ptr_table_fetch(aTHX_ a,b)
 #define ptr_table_store(a,b,c) Perl_ptr_table_store(aTHX_ a,b,c)
 #define ptr_table_split(a)     Perl_ptr_table_split(aTHX_ a)
 #endif
-#if defined(HAVE_INTERP_INTERN)
-#define sys_intern_init()      Perl_sys_intern_init(aTHX)
-#endif
 #if defined(PERL_OBJECT)
 #else
 #endif
@@ -4443,8 +4441,12 @@
 #define Perl_sv_dup            CPerlObj::Perl_sv_dup
 #define sv_dup                 Perl_sv_dup
 #if defined(HAVE_INTERP_INTERN)
+#define Perl_sys_intern_clear  CPerlObj::Perl_sys_intern_clear
+#define sys_intern_clear       Perl_sys_intern_clear
 #define Perl_sys_intern_dup    CPerlObj::Perl_sys_intern_dup
 #define sys_intern_dup         Perl_sys_intern_dup
+#define Perl_sys_intern_init   CPerlObj::Perl_sys_intern_init
+#define sys_intern_init                Perl_sys_intern_init
 #endif
 #define Perl_ptr_table_new     CPerlObj::Perl_ptr_table_new
 #define ptr_table_new          Perl_ptr_table_new
@@ -4455,10 +4457,6 @@
 #define Perl_ptr_table_split   CPerlObj::Perl_ptr_table_split
 #define ptr_table_split                Perl_ptr_table_split
 #endif
-#if defined(HAVE_INTERP_INTERN)
-#define Perl_sys_intern_init   CPerlObj::Perl_sys_intern_init
-#define sys_intern_init                Perl_sys_intern_init
-#endif
 #if defined(PERL_OBJECT)
 #else
 #endif

diff --git a/embed.pl b/embed.pl
index 8a89103..d760576 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -2155,17 +2155,16 @@ Ap      |GP*    |gp_dup         |GP* gp
 Ap     |MAGIC* |mg_dup         |MAGIC* mg
 Ap     |SV*    |sv_dup         |SV* sstr
 #if defined(HAVE_INTERP_INTERN)
+Ap     |void   |sys_intern_clear
 Ap     |void   |sys_intern_dup |struct interp_intern* src \
                                |struct interp_intern* dst
+Ap     |void   |sys_intern_init
 #endif
 Ap     |PTR_TBL_t*|ptr_table_new
 Ap     |void*  |ptr_table_fetch|PTR_TBL_t *tbl|void *sv
 Ap     |void   |ptr_table_store|PTR_TBL_t *tbl|void *oldsv|void *newsv
 Ap     |void   |ptr_table_split|PTR_TBL_t *tbl
 #endif
-#if defined(HAVE_INTERP_INTERN)
-Ap     |void   |sys_intern_init
-#endif
 
 #if defined(PERL_OBJECT)
 protected:

diff --git a/global.sym b/global.sym
index ec6180b..15afc0c 100644 (file)
--- a/global.sym
+++ b/global.sym
@@ -536,9 +536,10 @@ Perl_dirp_dup
 Perl_gp_dup
 Perl_mg_dup
 Perl_sv_dup
+Perl_sys_intern_clear
 Perl_sys_intern_dup
+Perl_sys_intern_init
 Perl_ptr_table_new
 Perl_ptr_table_fetch
 Perl_ptr_table_store
 Perl_ptr_table_split
-Perl_sys_intern_init

diff --git a/makedef.pl b/makedef.pl
index ae68674..b47237c 100644 (file)
--- a/makedef.pl
+++ b/makedef.pl
@@ -259,6 +259,7 @@ elsif ($PLATFORM eq 'aix') {
                     Perl_safexrealloc
                     Perl_same_dirent
                     Perl_unlnk
+                    Perl_sys_intern_clear
                     Perl_sys_intern_dup
                     Perl_sys_intern_init
                     PL_cryptseen

diff --git a/objXSUB.h b/objXSUB.h
index 25536e9..7f14e2f 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -2166,10 +2166,18 @@
 #undef  sv_dup
 #define sv_dup                 Perl_sv_dup
 #if defined(HAVE_INTERP_INTERN)
+#undef  Perl_sys_intern_clear
+#define Perl_sys_intern_clear  pPerl->Perl_sys_intern_clear
+#undef  sys_intern_clear
+#define sys_intern_clear       Perl_sys_intern_clear
 #undef  Perl_sys_intern_dup
 #define Perl_sys_intern_dup    pPerl->Perl_sys_intern_dup
 #undef  sys_intern_dup
 #define sys_intern_dup         Perl_sys_intern_dup
+#undef  Perl_sys_intern_init
+#define Perl_sys_intern_init   pPerl->Perl_sys_intern_init
+#undef  sys_intern_init
+#define sys_intern_init                Perl_sys_intern_init
 #endif
 #undef  Perl_ptr_table_new
 #define Perl_ptr_table_new     pPerl->Perl_ptr_table_new
@@ -2188,12 +2196,6 @@
 #undef  ptr_table_split
 #define ptr_table_split                Perl_ptr_table_split
 #endif
-#if defined(HAVE_INTERP_INTERN)
-#undef  Perl_sys_intern_init
-#define Perl_sys_intern_init   pPerl->Perl_sys_intern_init
-#undef  sys_intern_init
-#define sys_intern_init                Perl_sys_intern_init
-#endif
 #if defined(PERL_OBJECT)
 #else
 #endif

diff --git a/perl.c b/perl.c
index 33ca540..9736d3b 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -657,6 +657,10 @@ perl_destruct(pTHXx)
     SvREFCNT_dec(PL_fdpid);            /* needed in io_close() */
     PL_fdpid = Nullav;
 
+#ifdef HAVE_INTERP_INTERN
+    sys_intern_clear();
+#endif
+
     /* Destruct the global string table. */
     {
        /* Yell and reset the HeVAL() slots that are still holding refcounts,

diff --git a/perlapi.c b/perlapi.c
index 10a7a37..6a2b5b0 100644 (file)
--- a/perlapi.c
+++ b/perlapi.c
@@ -3914,12 +3914,26 @@ Perl_sv_dup(pTHXo_ SV* sstr)
 }
 #if defined(HAVE_INTERP_INTERN)
 
+#undef  Perl_sys_intern_clear
+void
+Perl_sys_intern_clear(pTHXo)
+{
+    ((CPerlObj*)pPerl)->Perl_sys_intern_clear();
+}
+
 #undef  Perl_sys_intern_dup
 void
 Perl_sys_intern_dup(pTHXo_ struct interp_intern* src, struct interp_intern* dst)
 {
     ((CPerlObj*)pPerl)->Perl_sys_intern_dup(src, dst);
 }
+
+#undef  Perl_sys_intern_init
+void
+Perl_sys_intern_init(pTHXo)
+{
+    ((CPerlObj*)pPerl)->Perl_sys_intern_init();
+}
 #endif
 
 #undef  Perl_ptr_table_new
@@ -3950,15 +3964,6 @@ Perl_ptr_table_split(pTHXo_ PTR_TBL_t *tbl)
     ((CPerlObj*)pPerl)->Perl_ptr_table_split(tbl);
 }
 #endif
-#if defined(HAVE_INTERP_INTERN)
-
-#undef  Perl_sys_intern_init
-void
-Perl_sys_intern_init(pTHXo)
-{
-    ((CPerlObj*)pPerl)->Perl_sys_intern_init();
-}
-#endif
 #if defined(PERL_OBJECT)
 #else
 #endif

diff --git a/proto.h b/proto.h
index 28c9581..da7d9bc 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -933,16 +933,15 @@ PERL_CALLCONV GP* Perl_gp_dup(pTHX_ GP* gp);
 PERL_CALLCONV MAGIC*   Perl_mg_dup(pTHX_ MAGIC* mg);
 PERL_CALLCONV SV*      Perl_sv_dup(pTHX_ SV* sstr);
 #if defined(HAVE_INTERP_INTERN)
+PERL_CALLCONV void     Perl_sys_intern_clear(pTHX);
 PERL_CALLCONV void     Perl_sys_intern_dup(pTHX_ struct interp_intern* src, struct interp_intern* dst);
+PERL_CALLCONV void     Perl_sys_intern_init(pTHX);
 #endif
 PERL_CALLCONV PTR_TBL_t*       Perl_ptr_table_new(pTHX);
 PERL_CALLCONV void*    Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv);
 PERL_CALLCONV void     Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldsv, void *newsv);
 PERL_CALLCONV void     Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl);
 #endif
-#if defined(HAVE_INTERP_INTERN)
-PERL_CALLCONV void     Perl_sys_intern_init(pTHX);
-#endif
 
 #if defined(PERL_OBJECT)
 protected:

diff --git a/win32/win32.c b/win32/win32.c
index c589ff5..750f6fb 100644 (file)
--- a/win32/win32.c
+++ b/win32/win32.c
@@ -4032,6 +4032,8 @@ win32_get_child_IO(child_IO_table* ptbl)
 #    define Perl_sys_intern_init CPerlObj::Perl_sys_intern_init
 #    undef Perl_sys_intern_dup
 #    define Perl_sys_intern_dup CPerlObj::Perl_sys_intern_dup
+#    undef Perl_sys_intern_clear
+#    define Perl_sys_intern_clear CPerlObj::Perl_sys_intern_clear
 #    define pPerl this
 #  endif
 
@@ -4066,6 +4068,18 @@ Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
     Newz(1313, dst->pseudo_children, 1, child_tab);
     dst->thr_intern.Winit_socktype = src->thr_intern.Winit_socktype;
 }
+
+void
+Perl_sys_intern_clear(pTHX)
+{
+    Safefree(w32_perlshell_tokens);
+    Safefree(w32_perlshell_vec);
+    /* NOTE: w32_fdpid is freed by sv_clean_all() */
+    Safefree(w32_children);
+#  ifdef USE_ITHREADS
+    Safefree(w32_pseudo_children);
+#  endif
+}
 #  endif /* USE_ITHREADS */
 #endif /* HAVE_INTERP_INTERN */