From: Gurusamy Sarathy <gsar@cpan.org>
Date: Thu, 16 Mar 2000 03:18:41 +0000 (+0000)
Subject: due to an oversight during PERL_OBJECT migration, hosts created
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1c0ca838512883f7a705e306f80a7c0a95277a87;p=p5sagit%2Fp5-mst-13.2.git

due to an oversight during PERL_OBJECT migration, hosts created
by pseudo-fork were never being deleted, leading to a sizeable
memory leak; std FDs in pseudo-children are now closed
automatically to avoid resource leaks; basic infinite looping
fork() test works without leaking again in non-PERL_OBJECT
build

p4raw-id: //depot/perl@5761
---

diff --git a/embed.pl b/embed.pl
index 600e818..eecf964 100755
--- a/embed.pl
+++ b/embed.pl
@@ -1445,7 +1445,7 @@ p	|bool	|do_aexec	|SV* really|SV** mark|SV** sp
 p	|bool	|do_aexec5	|SV* really|SV** mark|SV** sp|int fd|int flag
 Ap	|int	|do_binmode	|PerlIO *fp|int iotype|int flag
 p	|void	|do_chop	|SV* asv|SV* sv
-p	|bool	|do_close	|GV* gv|bool not_implicit
+Ap	|bool	|do_close	|GV* gv|bool not_implicit
 p	|bool	|do_eof		|GV* gv
 p	|bool	|do_exec	|char* cmd
 #if !defined(WIN32)
diff --git a/global.sym b/global.sym
index ea77dfe..c9ecd97 100644
--- a/global.sym
+++ b/global.sym
@@ -85,6 +85,7 @@ Perl_delimcpy
 Perl_die
 Perl_dounwind
 Perl_do_binmode
+Perl_do_close
 Perl_do_open
 Perl_do_open9
 Perl_dowantarray
diff --git a/objXSUB.h b/objXSUB.h
index 1906a66..4cf78b9 100644
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -297,6 +297,10 @@
 #define Perl_do_binmode		pPerl->Perl_do_binmode
 #undef  do_binmode
 #define do_binmode		Perl_do_binmode
+#undef  Perl_do_close
+#define Perl_do_close		pPerl->Perl_do_close
+#undef  do_close
+#define do_close		Perl_do_close
 #if !defined(WIN32)
 #endif
 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
diff --git a/perl.c b/perl.c
index e517451..f80ee95 100644
--- a/perl.c
+++ b/perl.c
@@ -764,7 +764,13 @@ perl_free(pTHXx)
 #if defined(PERL_OBJECT)
     PerlMem_free(this);
 #else
+#  if defined(PERL_IMPLICIT_SYS) && defined(WIN32)
+    void *host = w32_internal_host;
     PerlMem_free(aTHXx);
+    win32_delete_internal_host(host);
+#  else
+    PerlMem_free(aTHXx);
+#  endif
 #endif
 }
 
diff --git a/perlapi.c b/perlapi.c
index 2ee7060..0294fce 100644
--- a/perlapi.c
+++ b/perlapi.c
@@ -606,6 +606,13 @@ Perl_do_binmode(pTHXo_ PerlIO *fp, int iotype, int flag)
 {
     return ((CPerlObj*)pPerl)->Perl_do_binmode(fp, iotype, flag);
 }
+
+#undef  Perl_do_close
+bool
+Perl_do_close(pTHXo_ GV* gv, bool not_implicit)
+{
+    return ((CPerlObj*)pPerl)->Perl_do_close(gv, not_implicit);
+}
 #if !defined(WIN32)
 #endif
 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
diff --git a/win32/perlhost.h b/win32/perlhost.h
index 02b9cb4..cac05b2 100644
--- a/win32/perlhost.h
+++ b/win32/perlhost.h
@@ -1719,6 +1719,13 @@ restart:
 	PL_main_root = Nullop;
     }
 
+    /* close the std handles to avoid fd leaks */
+    {
+	do_close(gv_fetchpv("STDIN", TRUE, SVt_PVIO), FALSE);
+	do_close(gv_fetchpv("STDOUT", TRUE, SVt_PVIO), FALSE);
+	do_close(gv_fetchpv("STDERR", TRUE, SVt_PVIO), FALSE);
+    }
+
     /* destroy everything (waits for any pseudo-forked children) */
     perl_destruct(my_perl);
     perl_free(my_perl);
diff --git a/win32/perllib.c b/win32/perllib.c
index 6211ba7..857aada 100644
--- a/win32/perllib.c
+++ b/win32/perllib.c
@@ -143,6 +143,13 @@ perl_alloc(void)
     return my_perl;
 }
 
+EXTERN_C void
+win32_delete_internal_host(void *h)
+{
+    CPerlHost *host = (CPerlHost*)h;
+    delete host;
+}
+
 #ifdef PERL_OBJECT
 
 EXTERN_C void
@@ -157,10 +164,7 @@ perl_construct(PerlInterpreter* my_perl)
     {
 	win32_fprintf(stderr, "%s\n",
 		      "Error: Unable to construct data structures");
-	CPerlHost* pHost = (CPerlHost*)w32_internal_host;
-	Perl_free();
-	delete pHost;
-	PERL_SET_THX(NULL);
+	perl_free(my_perl);
     }
 }
 
@@ -185,21 +189,19 @@ EXTERN_C void
 perl_free(PerlInterpreter* my_perl)
 {
     CPerlObj* pPerl = (CPerlObj*)my_perl;
+    void *host = w32_internal_host;
 #ifdef DEBUGGING
-    CPerlHost* pHost = (CPerlHost*)w32_internal_host;
     Perl_free();
-    delete pHost;
 #else
     try
     {
-	CPerlHost* pHost = (CPerlHost*)w32_internal_host;
 	Perl_free();
-	delete pHost;
     }
     catch(...)
     {
     }
 #endif
+    win32_delete_internal_host(host);
     PERL_SET_THX(NULL);
 }
 
@@ -207,10 +209,10 @@ EXTERN_C int
 perl_run(PerlInterpreter* my_perl)
 {
     CPerlObj* pPerl = (CPerlObj*)my_perl;
+    int retVal;
 #ifdef DEBUGGING
-    return Perl_run();
+    retVal = Perl_run();
 #else
-    int retVal;
     try
     {
 	retVal = Perl_run();
@@ -220,8 +222,8 @@ perl_run(PerlInterpreter* my_perl)
 	win32_fprintf(stderr, "Error: Runtime exception\n");
 	retVal = -1;
     }
-    return retVal;
 #endif
+    return retVal;
 }
 
 EXTERN_C int
diff --git a/win32/win32.h b/win32/win32.h
index 81bf574..35d5bdf 100644
--- a/win32/win32.h
+++ b/win32/win32.h
@@ -337,6 +337,10 @@ extern int		IsWin95(void);
 extern int		IsWinNT(void);
 extern void		win32_argv2utf8(int argc, char** argv);
 
+#ifdef PERL_IMPLICIT_SYS
+extern void		win32_delete_internal_host(void *h);
+#endif
+
 extern char *		staticlinkmodules[];
 
 END_EXTERN_C