fix memory leak on Windows (PL_sys_intern contents were never

freed)

p4raw-id: //depot/perl@6299

9 files changed, 55 insertions, 32 deletions

diff --git a/embed.h b/embed.h
index 33ef720e9d..301619e68b 100644
--- 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 8a89103380..d7605761ee 100755
--- 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 ec6180b2f1..15afc0c2b6 100644
--- 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 ae68674aa7..b47237ce82 100644
--- 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 25536e902f..7f14e2f271 100644
--- 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 33ca54061b..9736d3b9fc 100644
--- 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 10a7a37c40..6a2b5b0a8a 100644
--- 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 28c9581241..da7d9bc6f8 100644
--- 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 c589ff5e88..750f6fb9c6 100644
--- 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 */