Add thread safety to some environment accesses

The previous commit added a mutex specifically for protecting against
simultaneous accesses of the environment.  This commit changes the
normal getenv, putenv, and clearenv functions to use it, to avoid races.

This makes the code simpler in places where we've gotten burned and
added stuff to avoid races.  Other places where we haven't known we were
getting burned could have existed until now.  Now that comes
automatically, and we can remove the special cases we earlier stumbled
over.

getenv() returns a pointer to static memory, which can be overwritten at
any moment from another thread, or even another getenv from the same
thread.  This commit changes the accesses to be under control of a
mutex, and in the case of getenv, a mortalized copy is created so that
there is no possible race.

Author: khwilliamson

embed.fnc

@@ -453,6 +453,8 @@
 :
 : Individual flags may be separated by non-tab whitespace.
 
+CipRTX	|char *	|mortal_getenv	|NN const char * str
+
 #if defined(PERL_IMPLICIT_SYS)
 ATo	|PerlInterpreter*|perl_alloc_using \
 				|NN struct IPerlMem *ipM \

embed.h

@@ -313,6 +313,7 @@
 #define mg_size(a)		Perl_mg_size(aTHX_ a)
 #define mini_mktime		Perl_mini_mktime
 #define moreswitches(a)		Perl_moreswitches(aTHX_ a)
+#define mortal_getenv		Perl_mortal_getenv
 #define mro_get_linear_isa(a)	Perl_mro_get_linear_isa(aTHX_ a)
 #define mro_method_changed_in(a)	Perl_mro_method_changed_in(aTHX_ a)
 #define my_atof(a)		Perl_my_atof(aTHX_ a)

inline.h

@@ -2586,6 +2586,59 @@ S_my_memrchr(const char * s, const char c, const STRLEN len)
 
 #endif
 
+PERL_STATIC_INLINE char *
+Perl_mortal_getenv(const char * str)
+{
+    /* This implements a (mostly) thread-safe, sequential-call-safe getenv().
+     *
+     * It's (mostly) thread-safe because it uses a mutex to prevent
+     * simultaneous access from other threads that use the same mutex, and
+     * makes a copy of the result before releasing that mutex.  All of the Perl
+     * core uses that mutex, but, like all mutexes, everything has to cooperate
+     * for it to completely work.  It is possible for code from, say XS, to not
+     * use this mutex, defeating the safety.
+     *
+     * On some platforms, getenv() is not sequential-call-safe, because
+     * subsequent calls destroy the static storage inside the C library
+     * returned by an earlier call.  The result must be copied or completely
+     * acted upon before a subsequent getenv call.  Those calls could come from
+     * another thread.  Again, making a copy while controlling the mutex
+     * prevents these problems..
+     *
+     * To prevent leaks, the copy is made by creating a new SV containing it,
+     * mortalizing the SV, and returning the SV's string (the copy).  Thus this
+     * is a drop-in replacement for getenv().
+     *
+     * A complication is that this can be called during phases where the
+     * mortalization process isn't available.  These are in interpreter
+     * destruction or early in construction.  khw believes that at these times
+     * there shouldn't be anything else going on, so plain getenv is safe AS
+     * LONG AS the caller acts on the return before calling it again. */
+
+    char * ret;
+    dTHX;
+
+    PERL_ARGS_ASSERT_MORTAL_GETENV;
+
+    /* Can't mortalize without stacks.  khw believes that no other threads
+     * should be running, so no need to lock things, and this may be during a
+     * phase when locking isn't even available */
+    if (UNLIKELY(PL_scopestack_ix == 0)) {
+        return getenv(str);
+    }
+
+    ENV_LOCK;
+
+    ret = getenv(str);
+
+    if (ret != NULL) {
+        ret = SvPVX(sv_2mortal(newSVpv(ret, 0)));
+    }
+
+    ENV_UNLOCK;
+    return ret;
+}
+
 /*
  * ex: set ts=8 sts=4 sw=4 et:
  */

iperlsys.h

@@ -562,10 +562,18 @@ struct IPerlEnvInfo
 	(*PL_Env->pGetChildIO)(PL_Env, ptr)
 #endif
 
-#else	/* PERL_IMPLICIT_SYS */
-
-#define PerlEnv_putenv(str)		putenv((str))
-#define PerlEnv_getenv(str)		getenv((str))
+#else	/* below is ! PERL_IMPLICIT_SYS */
+#  ifdef USE_ITHREADS
+
+     /* Use the comma operator to return 0/non-zero, while avoiding putting
+      * this in an inline function */
+#    define PerlEnv_putenv(str)	(ENV_LOCK, (putenv(str)                 \
+                                            ? (ENV_UNLOCK, 1)           \
+                                            : (ENV_UNLOCK, 0)))
+#  else
+#    define PerlEnv_putenv(str)		putenv(str)
+#  endif
+#define PerlEnv_getenv(str)		mortal_getenv(str)
 #define PerlEnv_getenv_len(str,l)	getenv_len((str), (l))
 #ifdef HAS_ENVGETENV
 #  define PerlEnv_ENVgetenv(str)	ENVgetenv((str))
@@ -588,7 +596,9 @@ struct IPerlEnvInfo
 #define PerlEnv_get_childdir()		win32_get_childdir()
 #define PerlEnv_free_childdir(d)	win32_free_childdir((d))
 #else
-#define PerlEnv_clearenv()		clearenv()
+#define PerlEnv_clearenv(str)	        (ENV_LOCK, (clearenv(str)           \
+                                                    ? (ENV_UNLOCK, 1)       \
+                                                    : (ENV_UNLOCK, 0)))
 #define PerlEnv_get_childenv()		get_childenv()
 #define PerlEnv_free_childenv(e)	free_childenv((e))
 #define PerlEnv_get_childdir()		get_childdir()

locale.c

@@ -791,16 +791,6 @@ S_emulate_setlocale(const int category,
             if (! default_name || strEQ(default_name, "")) {
                 default_name = "C";
             }
-            else if (PL_scopestack_ix != 0) {
-                /* To minimize other threads messing with the environment,
-                 * we copy the variable, making it a temporary.  But this
-                 * doesn't work upon program initialization before any
-                 * scopes are created, and at this time, there's nothing
-                 * else going on that would interfere.  So skip the copy
-                 * in that case */
-                default_name = savepv(default_name);
-                SAVEFREEPV(default_name);
-            }
 
             if (category != LC_ALL) {
                 const char * const name = PerlEnv_getenv(category_names[index]);
@@ -835,22 +825,19 @@ S_emulate_setlocale(const int category,
 
                 for (i = 0; i < LC_ALL_INDEX; i++) {
                     const char * const env_override
-                                    = savepv(PerlEnv_getenv(category_names[i]));
+                                            = PerlEnv_getenv(category_names[i]);
                     const char * this_locale = (   env_override
                                                 && strNE(env_override, ""))
                                                ? env_override
                                                : default_name;
                     if (! emulate_setlocale(categories[i], this_locale, i, TRUE))
                     {
-                        Safefree(env_override);
                         return NULL;
                     }
 
                     if (strNE(this_locale, default_name)) {
                         did_override = TRUE;
                     }
-
-                    Safefree(env_override);
                 }
 
                 /* If all the categories are the same, we can set LC_ALL to
@@ -3310,7 +3297,7 @@ Perl_init_i18nl10n(pTHX_ int printwarn)
 #else  /* USE_LOCALE */
 #  ifdef __GLIBC__
 
-    const char * const language   = savepv(PerlEnv_getenv("LANGUAGE"));
+    const char * const language = PerlEnv_getenv("LANGUAGE");
 
 #  endif
 
@@ -3320,8 +3307,8 @@ Perl_init_i18nl10n(pTHX_ int printwarn)
                                         : "";
     const char* trial_locales[5];   /* 5 = 1 each for "", LC_ALL, LANG, "", C */
     unsigned int trial_locales_count;
-    const char * const lc_all     = savepv(PerlEnv_getenv("LC_ALL"));
-    const char * const lang       = savepv(PerlEnv_getenv("LANG"));
+    const char * const lc_all     = PerlEnv_getenv("LC_ALL");
+    const char * const lang       = PerlEnv_getenv("LANG");
     bool setlocale_failure = FALSE;
     unsigned int i;
 
@@ -3909,15 +3896,6 @@ Perl_init_i18nl10n(pTHX_ int printwarn)
     }
 
 #  endif
-#  ifdef __GLIBC__
-
-    Safefree(language);
-
-#  endif
-
-    Safefree(lc_all);
-    Safefree(lang);
-
 #endif /* USE_LOCALE */
 #ifdef DEBUGGING
 

perl.c

@@ -2283,10 +2283,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 #endif
 	(s = PerlEnv_getenv("PERL5OPT")))
     {
-        /* s points to static memory in getenv(), which may be overwritten at
-         * any time; use a mortal copy instead */
-	s = SvPVX(sv_2mortal(newSVpv(s, 0)));
-
 	while (isSPACE(*s))
 	    s++;
 	if (*s == '-' && *(s+1) == 'T') {

proto.h

@@ -2045,6 +2045,13 @@ PERL_CALLCONV void *	Perl_more_bodies(pTHX_ const svtype sv_type, const size_t b
 PERL_CALLCONV const char*	Perl_moreswitches(pTHX_ const char* s);
 #define PERL_ARGS_ASSERT_MORESWITCHES	\
 	assert(s)
+#ifndef PERL_NO_INLINE_FUNCTIONS
+PERL_STATIC_INLINE char *	Perl_mortal_getenv(const char * str)
+			__attribute__warn_unused_result__;
+#define PERL_ARGS_ASSERT_MORTAL_GETENV	\
+	assert(str)
+#endif
+
 PERL_CALLCONV const struct mro_alg *	Perl_mro_get_from_name(pTHX_ SV *name);
 #define PERL_ARGS_ASSERT_MRO_GET_FROM_NAME	\
 	assert(name)

util.c

@@ -2139,7 +2139,8 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
 #    endif
 
 #    ifdef USE_ITHREADS
-  /* only parent thread can modify process environment */
+  /* only parent thread can modify process environment, so no need to use a
+   * mutex */
   if (PL_curinterp == aTHX)
 #    endif
   {
@@ -5169,7 +5170,8 @@ Perl_my_clearenv(pTHX)
 #  else /* ! (PERL_IMPLICIT_SYS || WIN32) */
 #    if defined(USE_ENVIRON_ARRAY)
 #      if defined(USE_ITHREADS)
-    /* only the parent thread can clobber the process environment */
+    /* only the parent thread can clobber the process environment, so no need
+     * to use a mutex */
     if (PL_curinterp == aTHX)
 #      endif /* USE_ITHREADS */
     {