+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 other
+ * threads (that look at this mutex) from destroying the result before this
+ * routine has a chance to copy the result to a place that won't be
+ * destroyed before the caller gets a chance to handle it. That place is a
+ * mortal SV. khw chose this over SAVEFREEPV because he is under the
+ * impression that the SV will hang around longer under more circumstances
+ *
+ * The reason it isn't completely thread-safe is that other code could
+ * simply not pay attention to the mutex. All of the Perl core uses the
+ * mutex, but it is possible for code from, say XS, to not use this mutex,
+ * defeating the safety.
+ *
+ * getenv() returns, in some implementations, a pointer to a spot in the
+ * **environ array, which could be invalidated at any time by this or
+ * another thread changing the environment. Other implementations copy the
+ * **environ value to a static buffer, returning a pointer to that. That
+ * buffer might or might not be invalidated by a getenv() call in another
+ * thread. If it does get zapped, we need an exclusive lock. Otherwise,
+ * many getenv() calls can safely be running simultaneously, so a
+ * many-reader (but no simultaneous writers) lock is ok. There is a
+ * Configure probe to see if another thread destroys the buffer, and the
+ * mutex is defined accordingly.
+ *
+ * But in all cases, using the mutex prevents these problems, as long as
+ * all code uses the same mutex.
+ *
+ * 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);
+ }
+
+#ifdef PERL_MEM_LOG
+
+ /* A major complication arises under PERL_MEM_LOG. When that is active,
+ * every memory allocation may result in logging, depending on the value of
+ * ENV{PERL_MEM_LOG} at the moment. That means, as we create the SV for
+ * saving ENV{foo}'s value (but before saving it), the logging code will
+ * call us recursively to find out what ENV{PERL_MEM_LOG} is. Without some
+ * care that could lead to: 1) infinite recursion; or 2) deadlock (trying to
+ * lock a boolean mutex recursively); 3) destroying the getenv() static
+ * buffer; or 4) destroying the temporary created by this for the copy
+ * causes a log entry to be made which could cause a new temporary to be
+ * created, which will need to be destroyed at some point, leading to an
+ * infinite loop.
+ *
+ * The solution adopted here (after some gnashing of teeth) is to detect
+ * the recursive calls and calls from the logger, and treat them specially.
+ * Let's say we want to do getenv("foo"). We first find
+ * getenv(PERL_MEM_LOG) and save it to a fixed-length per-interpreter
+ * variable, so no temporary is required. Then we do getenv(foo), and in
+ * the process of creating a temporary to save it, this function will be
+ * called recursively to do a getenv(PERL_MEM_LOG). On the recursed call,
+ * we detect that it is such a call and return our saved value instead of
+ * locking and doing a new getenv(). This solves all of problems 1), 2),
+ * and 3). Because all the getenv()s are done while the mutex is locked,
+ * the state cannot have changed. To solve 4), we don't create a temporary
+ * when this is called from the logging code. That code disposes of the
+ * return value while the mutex is still locked.
+ *
+ * The value of getenv(PERL_MEM_LOG) can be anything, but only initial
+ * digits and 3 particular letters are significant; the rest are ignored by
+ * the memory logging code. Thus the per-interpreter variable only needs
+ * to be large enough to save the significant information, the size of
+ * which is known at compile time. The first byte is extra, reserved for
+ * flags for our use. To protect against overflowing, only the reserved
+ * byte, as many digits as don't overflow, and the three letters are
+ * stored.
+ *
+ * The reserved byte has two bits:
+ * 0x1 if set indicates that if we get here, it is a recursive call of
+ * getenv()
+ * 0x2 if set indicates that the call is from the logging code.
+ *
+ * If the flag indicates this is a recursive call, just return the stored
+ * value of PL_mem_log; An empty value gets turned into NULL. */
+ if (strEQ(str, "PERL_MEM_LOG") && PL_mem_log[0] & 0x1) {
+ if (PL_mem_log[1] == '\0') {
+ return NULL;
+ } else {
+ return PL_mem_log + 1;
+ }
+ }
+
+#endif
+
+ GETENV_LOCK;
+
+#ifdef PERL_MEM_LOG
+
+ /* Here we are in a critical section. As explained above, we do our own
+ * getenv(PERL_MEM_LOG), saving the result safely. */
+ ret = getenv("PERL_MEM_LOG");
+ if (ret == NULL) { /* No logging active */
+
+ /* Return that immediately if called from the logging code */
+ if (PL_mem_log[0] & 0x2) {
+ GETENV_UNLOCK;
+ return NULL;
+ }
+
+ PL_mem_log[1] = '\0';
+ }
+ else {
+ char *mem_log_meat = PL_mem_log + 1; /* first byte reserved */
+
+ /* There is nothing to prevent the value of PERL_MEM_LOG from being an
+ * extremely long string. But we want only a few characters from it.
+ * PL_mem_log has been made large enough to hold just the ones we need.
+ * First the file descriptor. */
+ if (isDIGIT(*ret)) {
+ const char * s = ret;
+ if (UNLIKELY(*s == '0')) {
+
+ /* Reduce multiple leading zeros to a single one. This is to
+ * allow the caller to change what to do with leading zeros. */
+ *mem_log_meat++ = '0';
+ s++;
+ while (*s == '0') {
+ s++;
+ }
+ }
+
+ /* If the input overflows, copy just enough for the result to also
+ * overflow, plus 1 to make sure */
+ while (isDIGIT(*s) && s < ret + TYPE_DIGITS(UV) + 1) {
+ *mem_log_meat++ = *s++;
+ }
+ }
+
+ /* Then each of the four significant characters */
+ if (strchr(ret, 'm')) {
+ *mem_log_meat++ = 'm';
+ }
+ if (strchr(ret, 's')) {
+ *mem_log_meat++ = 's';
+ }
+ if (strchr(ret, 't')) {
+ *mem_log_meat++ = 't';
+ }
+ if (strchr(ret, 'c')) {
+ *mem_log_meat++ = 'c';
+ }
+ *mem_log_meat = '\0';
+
+ assert(mem_log_meat < PL_mem_log + sizeof(PL_mem_log));
+ }
+
+ /* If we are being called from the logger, it only needs the significant
+ * portion of PERL_MEM_LOG, and doesn't need a safe copy */
+ if (PL_mem_log[0] & 0x2) {
+ assert(strEQ(str, "PERL_MEM_LOG"));
+ GETENV_UNLOCK;
+ return PL_mem_log + 1;
+ }
+
+ /* Here is a generic getenv(). This could be a getenv("PERL_MEM_LOG") that
+ * is coming from other than the logging code, so it should be treated the
+ * same as any other getenv(), returning the full value, not just the
+ * significant part, and having its value saved. Set the flag that
+ * indicates any call to this routine will be a recursion from here */
+ PL_mem_log[0] = 0x1;
+
+#endif
+
+ /* Now get the value of the real desired variable, and save a copy */
+ ret = getenv(str);
+
+ if (ret != NULL) {
+ ret = SvPVX( newSVpvn_flags(ret, strlen(ret) ,SVs_TEMP) );
+ }
+
+ GETENV_UNLOCK;
+
+#ifdef PERL_MEM_LOG
+
+ /* Clear the buffer */
+ Zero(PL_mem_log, sizeof(PL_mem_log), char);
+
+#endif
+
+ return ret;
+}
+
+PERL_STATIC_INLINE bool
+Perl_sv_isbool(pTHX_ const SV *sv)
+{
+ PERL_UNUSED_CONTEXT;
+ return SvBoolFlagsOK(sv) && BOOL_INTERNALS_sv_isbool(sv);
+}
+
+#ifdef USE_ITHREADS
+
+PERL_STATIC_INLINE AV *
+Perl_cop_file_avn(pTHX_ const COP *cop) {
+
+ PERL_ARGS_ASSERT_COP_FILE_AVN;
+
+ const char *file = CopFILE(cop);
+ if (file) {
+ GV *gv = gv_fetchfile_flags(file, strlen(file), GVF_NOADD);
+ if (gv) {
+ return GvAVn(gv);
+ }
+ else
+ return NULL;
+ }
+ else
+ return NULL;
+}
+
+#endif
+
+PERL_STATIC_INLINE PADNAME *
+Perl_padname_refcnt_inc(PADNAME *pn)
+{
+ PadnameREFCNT(pn)++;
+ return pn;
+}
+
+PERL_STATIC_INLINE PADNAMELIST *
+Perl_padnamelist_refcnt_inc(PADNAMELIST *pnl)
+{
+ PadnamelistREFCNT(pnl)++;
+ return pnl;
+}
+
+/* copy a string to a safe spot */
+
+/*
+=for apidoc_section $string
+=for apidoc savepv
+
+Perl's version of C<strdup()>. Returns a pointer to a newly allocated
+string which is a duplicate of C<pv>. The size of the string is
+determined by C<strlen()>, which means it may not contain embedded C<NUL>
+characters and must have a trailing C<NUL>. To prevent memory leaks, the
+memory allocated for the new string needs to be freed when no longer needed.
+This can be done with the C<L</Safefree>> function, or
+L<C<SAVEFREEPV>|perlguts/SAVEFREEPV(p)>.
+
+On some platforms, Windows for example, all allocated memory owned by a thread
+is deallocated when that thread ends. So if you need that not to happen, you
+need to use the shared memory functions, such as C<L</savesharedpv>>.
+
+=cut
+*/
+
+PERL_STATIC_INLINE char *
+Perl_savepv(pTHX_ const char *pv)
+{
+ PERL_UNUSED_CONTEXT;
+ if (!pv)
+ return NULL;
+ else {
+ char *newaddr;
+ const STRLEN pvlen = strlen(pv)+1;
+ Newx(newaddr, pvlen, char);
+ return (char*)memcpy(newaddr, pv, pvlen);
+ }
+}
+
+/* same thing but with a known length */
+
+/*
+=for apidoc savepvn
+
+Perl's version of what C<strndup()> would be if it existed. Returns a
+pointer to a newly allocated string which is a duplicate of the first
+C<len> bytes from C<pv>, plus a trailing
+C<NUL> byte. The memory allocated for
+the new string can be freed with the C<Safefree()> function.
+
+On some platforms, Windows for example, all allocated memory owned by a thread
+is deallocated when that thread ends. So if you need that not to happen, you
+need to use the shared memory functions, such as C<L</savesharedpvn>>.
+
+=cut
+*/
+
+PERL_STATIC_INLINE char *
+Perl_savepvn(pTHX_ const char *pv, Size_t len)
+{
+ char *newaddr;
+ PERL_UNUSED_CONTEXT;
+
+ Newx(newaddr,len+1,char);
+ /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
+ if (pv) {
+ /* might not be null terminated */
+ newaddr[len] = '\0';
+ return (char *) CopyD(pv,newaddr,len,char);
+ }
+ else {
+ return (char *) ZeroD(newaddr,len+1,char);
+ }
+}
+
+/*
+=for apidoc savesvpv
+
+A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
+the passed in SV using C<SvPV()>
+
+On some platforms, Windows for example, all allocated memory owned by a thread
+is deallocated when that thread ends. So if you need that not to happen, you
+need to use the shared memory functions, such as C<L</savesharedsvpv>>.
+
+=cut
+*/
+
+PERL_STATIC_INLINE char *
+Perl_savesvpv(pTHX_ SV *sv)
+{
+ STRLEN len;
+ const char * const pv = SvPV_const(sv, len);
+ char *newaddr;
+
+ PERL_ARGS_ASSERT_SAVESVPV;
+
+ ++len;
+ Newx(newaddr,len,char);
+ return (char *) CopyD(pv,newaddr,len,char);
+}
+
+/*
+=for apidoc savesharedsvpv
+
+A version of C<savesharedpv()> which allocates the duplicate string in
+memory which is shared between threads.
+
+=cut
+*/
+
+PERL_STATIC_INLINE char *
+Perl_savesharedsvpv(pTHX_ SV *sv)
+{
+ STRLEN len;
+ const char * const pv = SvPV_const(sv, len);
+
+ PERL_ARGS_ASSERT_SAVESHAREDSVPV;
+
+ return savesharedpvn(pv, len);
+}
+
+#ifndef PERL_GET_CONTEXT_DEFINED
+
+/*
+=for apidoc_section $embedding
+=for apidoc get_context
+
+Implements L<perlapi/C<PERL_GET_CONTEXT>>, which you should use instead.
+
+=cut
+*/
+
+PERL_STATIC_INLINE void *
+Perl_get_context(void)
+{
+# if defined(USE_ITHREADS)
+# ifdef OLD_PTHREADS_API
+ pthread_addr_t t;
+ int error = pthread_getspecific(PL_thr_key, &t);
+ if (error)
+ Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
+ return (void*)t;
+# elif defined(I_MACH_CTHREADS)
+ return (void*)cthread_data(cthread_self());
+# else
+ return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
+# endif
+# else
+ return (void*)NULL;
+# endif
+}
+
+#endif
+
+PERL_STATIC_INLINE MGVTBL*
+Perl_get_vtbl(pTHX_ int vtbl_id)
+{
+ PERL_UNUSED_CONTEXT;
+
+ return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
+ ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id;
+}
+
+/*
+=for apidoc my_strlcat
+
+The C library C<strlcat> if available, or a Perl implementation of it.
+This operates on C C<NUL>-terminated strings.
+
+C<my_strlcat()> appends string C<src> to the end of C<dst>. It will append at
+most S<C<size - strlen(dst) - 1>> bytes. It will then C<NUL>-terminate,
+unless C<size> is 0 or the original C<dst> string was longer than C<size> (in
+practice this should not happen as it means that either C<size> is incorrect or
+that C<dst> is not a proper C<NUL>-terminated string).
+
+Note that C<size> is the full size of the destination buffer and
+the result is guaranteed to be C<NUL>-terminated if there is room. Note that
+room for the C<NUL> should be included in C<size>.
+
+The return value is the total length that C<dst> would have if C<size> is
+sufficiently large. Thus it is the initial length of C<dst> plus the length of
+C<src>. If C<size> is smaller than the return, the excess was not appended.
+
+=cut
+
+Description stolen from http://man.openbsd.org/strlcat.3
+*/
+#ifndef HAS_STRLCAT
+PERL_STATIC_INLINE Size_t
+Perl_my_strlcat(char *dst, const char *src, Size_t size)
+{
+ Size_t used, length, copy;
+
+ used = strlen(dst);
+ length = strlen(src);
+ if (size > 0 && used < size - 1) {
+ copy = (length >= size - used) ? size - used - 1 : length;
+ memcpy(dst + used, src, copy);
+ dst[used + copy] = '\0';
+ }
+ return used + length;
+}
+#endif
+
+
+/*
+=for apidoc my_strlcpy
+
+The C library C<strlcpy> if available, or a Perl implementation of it.
+This operates on C C<NUL>-terminated strings.
+
+C<my_strlcpy()> copies up to S<C<size - 1>> bytes from the string C<src>
+to C<dst>, C<NUL>-terminating the result if C<size> is not 0.
+
+The return value is the total length C<src> would be if the copy completely
+succeeded. If it is larger than C<size>, the excess was not copied.
+
+=cut
+
+Description stolen from http://man.openbsd.org/strlcpy.3
+*/
+#ifndef HAS_STRLCPY
+PERL_STATIC_INLINE Size_t
+Perl_my_strlcpy(char *dst, const char *src, Size_t size)
+{
+ Size_t length, copy;
+
+ length = strlen(src);
+ if (size > 0) {
+ copy = (length >= size) ? size - 1 : length;
+ memcpy(dst, src, copy);
+ dst[copy] = '\0';
+ }
+ return length;
+}
+#endif
+