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 (executable)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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