@@ -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 \

@@ -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)

@@ -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:

*/

@@ -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()

@@ -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

@@ -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') {

@@ -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)

@@ -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 */

{