From: Alan Burlison <Alan.Burlison@uk.sun.com>
Date: Fri, 4 Nov 2005 16:33:30 +0000 (+0000)
Subject: use clearenv if available
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b0269e46d70f4b0ab23ffad2f94b10b64091afa3;p=p5sagit%2Fp5-mst-13.2.git

use clearenv if available
Message-ID: <436B8D5A.4010502@sun.com>

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

diff --git a/embed.fnc b/embed.fnc
index df347c3..747426d 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1569,6 +1569,8 @@ p	|void	|offer_nice_chunk	|NN void *chunk|U32 chunk_size
 Apnod	|int	|my_sprintf	|NN char *buffer|NN const char *pat|...
 #endif
 
+px	|void	|my_clearenv
+
 END_EXTERN_C
 /*
  * ex: set ts=8 sts=4 sw=4 noet:
diff --git a/embed.h b/embed.h
index 9105aea..a303652 100644
--- a/embed.h
+++ b/embed.h
@@ -1651,6 +1651,9 @@
 #endif
 #ifndef SPRINTF_RETURNS_STRLEN
 #endif
+#ifdef PERL_CORE
+#define my_clearenv		Perl_my_clearenv
+#endif
 #define ck_anoncode		Perl_ck_anoncode
 #define ck_bitop		Perl_ck_bitop
 #define ck_concat		Perl_ck_concat
@@ -3637,6 +3640,9 @@
 #endif
 #ifndef SPRINTF_RETURNS_STRLEN
 #endif
+#ifdef PERL_CORE
+#define my_clearenv()		Perl_my_clearenv(aTHX)
+#endif
 #define ck_anoncode(a)		Perl_ck_anoncode(aTHX_ a)
 #define ck_bitop(a)		Perl_ck_bitop(aTHX_ a)
 #define ck_concat(a)		Perl_ck_concat(aTHX_ a)
diff --git a/mg.c b/mg.c
index fc4a1d4..6d71b21 100644
--- a/mg.c
+++ b/mg.c
@@ -1121,12 +1121,12 @@ Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
 int
 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
 {
-#if defined(VMS) || defined(EPOC)
+#if defined(VMS)
     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
 #else
     if (PL_localizing) {
 	HE* entry;
-	magic_clear_all_env(sv,mg);
+	my_clearenv();
 	hv_iterinit((HV*)sv);
 	while ((entry = hv_iternext((HV*)sv))) {
 	    I32 keylen;
@@ -1142,39 +1142,13 @@ int
 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
 {
     dVAR;
-#ifndef PERL_MICRO
-#if defined(VMS) || defined(EPOC)
-    Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
-#else
-#  if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
-    PerlEnv_clearenv();
-#  else
-#    ifdef USE_ENVIRON_ARRAY
-#      if defined(USE_ITHREADS)
-    /* only the parent thread can clobber the process environment */
-    if (PL_curinterp == aTHX)
-#      endif
-    {
-#      ifndef PERL_USE_SAFE_PUTENV
-    if (!PL_use_safe_putenv) {
-    I32 i;
-
-    if (environ == PL_origenviron)
-	environ = (char**)safesysmalloc(sizeof(char*));
-    else
-	for (i = 0; environ[i]; i++)
-	    safesysfree(environ[i]);
-    }
-#      endif /* PERL_USE_SAFE_PUTENV */
-
-    environ[0] = Nullch;
-    }
-#    endif /* USE_ENVIRON_ARRAY */
-#   endif /* PERL_IMPLICIT_SYS || WIN32 */
-#endif /* VMS || EPOC */
-#endif /* !PERL_MICRO */
     PERL_UNUSED_ARG(sv);
     PERL_UNUSED_ARG(mg);
+#if defined(VMS)
+    Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
+#else
+    my_clearenv();
+#endif
     return 0;
 }
 
diff --git a/proto.h b/proto.h
index 2839a18..0c37c5a 100644
--- a/proto.h
+++ b/proto.h
@@ -4083,6 +4083,8 @@ PERL_CALLCONV int	Perl_my_sprintf(char *buffer, const char *pat, ...)
 
 #endif
 
+PERL_CALLCONV void	Perl_my_clearenv(pTHX);
+
 END_EXTERN_C
 /*
  * ex: set ts=8 sts=4 sw=4 noet:
diff --git a/sv.c b/sv.c
index 00aa612..19cb7b3 100644
--- a/sv.c
+++ b/sv.c
@@ -7405,19 +7405,15 @@ Perl_sv_reset(pTHX_ register const char *s, HV *stash)
 		    av_clear(GvAV(gv));
 		}
 		if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
+#if defined(VMS)
+		    Perl_die(aTHX_ "Can't reset %%ENV on this system");
+#else /* ! VMS */
 		    hv_clear(GvHV(gv));
-#ifndef PERL_MICRO
-#ifdef USE_ENVIRON_ARRAY
-		    if (gv == PL_envgv
-#  ifdef USE_ITHREADS
-			&& PL_curinterp == aTHX
-#  endif
-		    )
-		    {
-			environ[0] = Nullch;
-		    }
-#endif
-#endif /* !PERL_MICRO */
+#  if defined(USE_ENVIRON_ARRAY)
+		    if (gv == PL_envgv)
+		        my_clearenv();
+#  endif /* USE_ENVIRON_ARRAY */
+#endif /* VMS */
 		}
 	    }
 	}
diff --git a/util.c b/util.c
index ecec110..6c5605c 100644
--- a/util.c
+++ b/util.c
@@ -5080,6 +5080,60 @@ Perl_my_sprintf(char *buffer, const char* pat, ...)
 }
 #endif
 
+void
+Perl_my_clearenv(pTHX)
+{
+    dVAR;
+#if ! defined(PERL_MICRO)
+#  if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
+    PerlEnv_clearenv();
+#  else /* ! (PERL_IMPLICIT_SYS || WIN32) */
+#    if defined(USE_ENVIRON_ARRAY)
+#      if defined(USE_ITHREADS)
+    /* only the parent thread can clobber the process environment */
+    if (PL_curinterp == aTHX)
+#      endif /* USE_ITHREADS */
+    {
+#      if ! defined(PERL_USE_SAFE_PUTENV)
+    if ( !PL_use_safe_putenv) {
+      I32 i;
+      if (environ == PL_origenviron)
+        environ = (char**)safesysmalloc(sizeof(char*));
+      else
+        for (i = 0; environ[i]; i++)
+          (void)safesysfree(environ[i]);
+    }
+    environ[0] = NULL;
+#      else /* PERL_USE_SAFE_PUTENV */
+#        if defined(HAS_CLEARENV)
+    (void)clearenv();
+#        elif defined(HAS_UNSETENV)
+    int bsiz = 80; /* Most envvar names will be shorter than this. */
+    char *buf = (char*)safesysmalloc(bsiz * sizeof(char));
+    while (*environ != NULL) {
+      char *e = strchr(*environ, '=');
+      int l = e ? e - *environ : strlen(*environ);
+      if (bsiz < l + 1) {
+        (void)safesysfree(buf);
+        bsiz = l + 1;
+        buf = (char*)safesysmalloc(bsiz * sizeof(char));
+      } 
+      strncpy(buf, *environ, l);
+      *(buf + l) = '\0';
+      (void)unsetenv(buf);
+    }
+    (void)safesysfree(buf);
+#        else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
+    /* Just null environ and accept the leakage. */
+    *environ = NULL;
+#        endif /* HAS_CLEARENV || HAS_UNSETENV */
+#      endif /* ! PERL_USE_SAFE_PUTENV */
+    }
+#    endif /* USE_ENVIRON_ARRAY */
+#  endif /* PERL_IMPLICIT_SYS || WIN32 */
+#endif /* PERL_MICRO */
+}
+
 /*
  * Local variables:
  * c-indentation-style: bsd