X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/13d66b05c6163c3514774d3d11da5f3950e97e98..04912be77a628a4643d16a99a332a73853926079:/util.c

diff --git a/util.c b/util.c
index c9a46ae..6e1587e 100644
--- a/util.c
+++ b/util.c
@@ -214,9 +214,6 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 	? ((struct perl_memory_debug_header *)((char *)where - PERL_MEMORY_DEBUG_HEADER_SIZE))->size
 	: 0;
 #endif
-#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
-    Malloc_t PerlMem_realloc();
-#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
 
     if (!size) {
 	safesysfree(where);
@@ -442,7 +439,7 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 	ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
 #endif
     PERL_ALLOC_CHECK(ptr);
-    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size));
+    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) calloc %zu x %zu = %zu bytes\n",PTR2UV(ptr),(long)PL_an++, count, size, total_size));
     if (ptr != NULL) {
 #ifdef USE_MDH
 	{
@@ -693,7 +690,7 @@ Perl_rninstr(const char *big, const char *bigend, const char *little, const char
 
 =for apidoc fbm_compile
 
-Analyses the string in order to make fast searches on it using C<fbm_instr()>
+Analyzes the string in order to make fast searches on it using C<fbm_instr()>
 -- the Boyer-Moore algorithm.
 
 =cut
@@ -1530,6 +1527,7 @@ S_with_queued_errors(pTHX_ SV *ex)
 STATIC bool
 S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
 {
+    dVAR;
     HV *stash;
     GV *gv;
     CV *cv;
@@ -1537,7 +1535,7 @@ S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
     /* sv_2cv might call Perl_croak() or Perl_warner() */
     SV * const oldhook = *hook;
 
-    if (!oldhook)
+    if (!oldhook || oldhook == PERL_WARNHOOK_FATAL)
 	return FALSE;
 
     ENTER;
@@ -2063,151 +2061,207 @@ Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
    Copy(val, s+(nlen+1), vlen, char); \
    *(s+(nlen+1+vlen)) = '\0'
 
+
+
 #ifdef USE_ENVIRON_ARRAY
-       /* VMS' my_setenv() is in vms.c */
-#if !defined(WIN32) && !defined(NETWARE)
+/* NB: VMS' my_setenv() is in vms.c */
+
+/* Configure doesn't test for HAS_SETENV yet, so decide based on platform.
+ * For Solaris, setenv() and unsetenv() were introduced in Solaris 9, so
+ * testing for HAS UNSETENV is sufficient.
+ */
+#  if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) || defined(PERL_DARWIN)
+#    define MY_HAS_SETENV
+#  endif
+
+/* small wrapper for use by Perl_my_setenv that mallocs, or reallocs if
+ * 'current' is non-null, with up to three sizes that are added together.
+ * It handles integer overflow.
+ */
+#  ifndef MY_HAS_SETENV
+static char *
+S_env_alloc(void *current, Size_t l1, Size_t l2, Size_t l3, Size_t size)
+{
+    void *p;
+    Size_t sl, l = l1 + l2;
+
+    if (l < l2)
+        goto panic;
+    l += l3;
+    if (l < l3)
+        goto panic;
+    sl = l * size;
+    if (sl < l)
+        goto panic;
+
+    p = current
+            ? safesysrealloc(current, sl)
+            : safesysmalloc(sl);
+    if (p)
+        return (char*)p;
+
+  panic:
+    croak_memory_wrap();
+}
+#  endif
+
+
+#  if !defined(WIN32) && !defined(NETWARE)
+
 void
 Perl_my_setenv(pTHX_ const char *nam, const char *val)
 {
   dVAR;
-#ifdef __amigaos4__
+#    ifdef __amigaos4__
   amigaos4_obtain_environ(__FUNCTION__);
-#endif
-#ifdef USE_ITHREADS
+#    endif
+
+#    ifdef USE_ITHREADS
   /* only parent thread can modify process environment */
   if (PL_curinterp == aTHX)
-#endif
+#    endif
   {
-#ifndef PERL_USE_SAFE_PUTENV
+
+#    ifndef PERL_USE_SAFE_PUTENV
     if (!PL_use_safe_putenv) {
         /* most putenv()s leak, so we manipulate environ directly */
-        I32 i;
-        const I32 len = strlen(nam);
-        int nlen, vlen;
+        UV i;
+        Size_t vlen, nlen = strlen(nam);
 
         /* where does it go? */
         for (i = 0; environ[i]; i++) {
-            if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
+            if (strnEQ(environ[i], nam, nlen) && environ[i][nlen] == '=')
                 break;
         }
 
         if (environ == PL_origenviron) {   /* need we copy environment? */
-            I32 j;
-            I32 max;
+            UV j, max;
             char **tmpenv;
 
             max = i;
             while (environ[max])
                 max++;
-            tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
+
+            /* XXX shouldn't that be max+1 rather than max+2 ??? - DAPM */
+            tmpenv = (char**)S_env_alloc(NULL, max, 2, 0, sizeof(char*));
+
             for (j=0; j<max; j++) {         /* copy environment */
-                const int len = strlen(environ[j]);
-                tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
+                const Size_t len = strlen(environ[j]);
+                tmpenv[j] = S_env_alloc(NULL, len, 1, 0, 1);
                 Copy(environ[j], tmpenv[j], len+1, char);
             }
+
             tmpenv[max] = NULL;
             environ = tmpenv;               /* tell exec where it is now */
         }
+
         if (!val) {
             safesysfree(environ[i]);
             while (environ[i]) {
                 environ[i] = environ[i+1];
                 i++;
             }
-#ifdef __amigaos4__
+#      ifdef __amigaos4__
             goto my_setenv_out;
-#else
+#      else
             return;
-#endif
+#      endif
         }
+
         if (!environ[i]) {                 /* does not exist yet */
-            environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
+            environ = (char**)S_env_alloc(environ, i, 2, 0, sizeof(char*));
             environ[i+1] = NULL;    /* make sure it's null terminated */
         }
         else
             safesysfree(environ[i]);
-        nlen = strlen(nam);
+
         vlen = strlen(val);
 
-        environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
+        environ[i] = S_env_alloc(NULL, nlen, vlen, 2, 1);
         /* all that work just for this */
         my_setenv_format(environ[i], nam, nlen, val, vlen);
-    } else {
-# endif
-    /* This next branch should only be called #if defined(HAS_SETENV), but
-       Configure doesn't test for that yet.  For Solaris, setenv() and unsetenv()
-       were introduced in Solaris 9, so testing for HAS UNSETENV is sufficient.
-    */
-#   if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) || defined(PERL_DARWIN)
-#       if defined(HAS_UNSETENV)
+    }
+    else {
+
+#    endif /* !PERL_USE_SAFE_PUTENV */
+
+#    ifdef MY_HAS_SETENV
+#      if defined(HAS_UNSETENV)
         if (val == NULL) {
             (void)unsetenv(nam);
         } else {
             (void)setenv(nam, val, 1);
         }
-#       else /* ! HAS_UNSETENV */
+#      else /* ! HAS_UNSETENV */
         (void)setenv(nam, val, 1);
-#       endif /* HAS_UNSETENV */
-#   else
-#       if defined(HAS_UNSETENV)
+#      endif /* HAS_UNSETENV */
+
+#    elif defined(HAS_UNSETENV)
+
         if (val == NULL) {
             if (environ) /* old glibc can crash with null environ */
                 (void)unsetenv(nam);
         } else {
-	    const int nlen = strlen(nam);
-	    const int vlen = strlen(val);
-	    char * const new_env =
-                (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
+	    const Size_t nlen = strlen(nam);
+	    const Size_t vlen = strlen(val);
+	    char * const new_env = S_env_alloc(NULL, nlen, vlen, 2, 1);
             my_setenv_format(new_env, nam, nlen, val, vlen);
             (void)putenv(new_env);
         }
-#       else /* ! HAS_UNSETENV */
+
+#    else /* ! HAS_UNSETENV */
+
         char *new_env;
-	const int nlen = strlen(nam);
-	int vlen;
+	const Size_t nlen = strlen(nam);
+	Size_t vlen;
         if (!val) {
 	   val = "";
         }
         vlen = strlen(val);
-        new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
+        new_env = S_env_alloc(NULL, nlen, vlen, 2, 1);
         /* all that work just for this */
         my_setenv_format(new_env, nam, nlen, val, vlen);
         (void)putenv(new_env);
-#       endif /* HAS_UNSETENV */
-#   endif /* __CYGWIN__ */
-#ifndef PERL_USE_SAFE_PUTENV
+
+#    endif /* MY_HAS_SETENV */
+
+#    ifndef PERL_USE_SAFE_PUTENV
     }
-#endif
+#    endif
   }
-#ifdef __amigaos4__
+
+#    ifdef __amigaos4__
 my_setenv_out:
   amigaos4_release_environ(__FUNCTION__);
-#endif
+#    endif
 }
 
-#else /* WIN32 || NETWARE */
+#  else /* WIN32 || NETWARE */
 
 void
 Perl_my_setenv(pTHX_ const char *nam, const char *val)
 {
     dVAR;
     char *envstr;
-    const int nlen = strlen(nam);
-    int vlen;
+    const Size_t nlen = strlen(nam);
+    Size_t vlen;
 
     if (!val) {
        val = "";
     }
     vlen = strlen(val);
-    Newx(envstr, nlen+vlen+2, char);
+    envstr = S_env_alloc(NULL, nlen, vlen, 2, 1);
     my_setenv_format(envstr, nam, nlen, val, vlen);
     (void)PerlEnv_putenv(envstr);
     Safefree(envstr);
 }
 
-#endif /* WIN32 || NETWARE */
+#  endif /* WIN32 || NETWARE */
+
+#endif /* USE_ENVIRON_ARRAY */
+
+
 
-#endif /* !VMS */
 
 #ifdef UNLINK_ALL_VERSIONS
 I32
@@ -2223,61 +2277,6 @@ Perl_unlnk(pTHX_ const char *f)	/* unlink all versions of a file */
 }
 #endif
 
-#ifndef HAS_VPRINTF
-/* This vsprintf replacement should generally never get used, since
-   vsprintf was available in both System V and BSD 2.11.  (There may
-   be some cross-compilation or embedded set-ups where it is needed,
-   however.)
-
-   If you encounter a problem in this function, it's probably a symptom
-   that Configure failed to detect your system's vprintf() function.
-   See the section on "item vsprintf" in the INSTALL file.
-
-   This version may compile on systems with BSD-ish <stdio.h>,
-   but probably won't on others.
-*/
-
-#ifdef USE_CHAR_VSPRINTF
-char *
-#else
-int
-#endif
-vsprintf(char *dest, const char *pat, void *args)
-{
-    FILE fakebuf;
-
-#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
-    FILE_ptr(&fakebuf) = (STDCHAR *) dest;
-    FILE_cnt(&fakebuf) = 32767;
-#else
-    /* These probably won't compile -- If you really need
-       this, you'll have to figure out some other method. */
-    fakebuf._ptr = dest;
-    fakebuf._cnt = 32767;
-#endif
-#ifndef _IOSTRG
-#define _IOSTRG 0
-#endif
-    fakebuf._flag = _IOWRT|_IOSTRG;
-    _doprnt(pat, args, &fakebuf);	/* what a kludge */
-#if defined(STDIO_PTR_LVALUE)
-    *(FILE_ptr(&fakebuf)++) = '\0';
-#else
-    /* PerlIO has probably #defined away fputc, but we want it here. */
-#  ifdef fputc
-#    undef fputc  /* XXX Should really restore it later */
-#  endif
-    (void)fputc('\0', &fakebuf);
-#endif
-#ifdef USE_CHAR_VSPRINTF
-    return(dest);
-#else
-    return 0;		/* perl doesn't use return value */
-#endif
-}
-
-#endif /* HAS_VPRINTF */
-
 PerlIO *
 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
 {
@@ -2298,10 +2297,10 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
 	taint_env();
 	taint_proper("Insecure %s%s", "EXEC");
     }
-    if (PerlProc_pipe(p) < 0)
+    if (PerlProc_pipe_cloexec(p) < 0)
 	return NULL;
     /* Try for another pipe pair for error return */
-    if (PerlProc_pipe(pp) >= 0)
+    if (PerlProc_pipe_cloexec(pp) >= 0)
 	did_pipes = 1;
     while ((pid = PerlProc_fork()) < 0) {
 	if (errno != EAGAIN) {
@@ -2323,14 +2322,8 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
 #define THIS that
 #define THAT This
 	/* Close parent's end of error status pipe (if any) */
-	if (did_pipes) {
+	if (did_pipes)
 	    PerlLIO_close(pp[0]);
-#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
-	    /* Close error pipe automatically if exec works */
-	    if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
-                return NULL;
-#endif
-	}
 	/* Now dup our end of _the_ pipe to right position */
 	if (p[THIS] != (*mode == 'r')) {
 	    PerlLIO_dup2(p[THIS], *mode == 'r');
@@ -2338,8 +2331,10 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
 	    if (p[THAT] != (*mode == 'r'))	/* if dup2() didn't close it */
 		PerlLIO_close(p[THAT]);	/* close parent's end of _the_ pipe */
 	}
-	else
+	else {
+	    setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]);
 	    PerlLIO_close(p[THAT]);	/* close parent's end of _the_ pipe */
+        }
 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
 	/* No automatic close - do it by hand */
 #  ifndef NOFILE
@@ -2360,12 +2355,11 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
 #undef THAT
     }
     /* Parent */
-    do_execfree();	/* free any memory malloced by child on fork */
     if (did_pipes)
 	PerlLIO_close(pp[1]);
     /* Keep the lower of the two fd numbers */
     if (p[that] < p[This]) {
-	PerlLIO_dup2(p[This], p[that]);
+	PerlLIO_dup2_cloexec(p[This], p[that]);
 	PerlLIO_close(p[This]);
 	p[This] = p[that];
     }
@@ -2445,9 +2439,9 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 	taint_env();
 	taint_proper("Insecure %s%s", "EXEC");
     }
-    if (PerlProc_pipe(p) < 0)
+    if (PerlProc_pipe_cloexec(p) < 0)
 	return NULL;
-    if (doexec && PerlProc_pipe(pp) >= 0)
+    if (doexec && PerlProc_pipe_cloexec(pp) >= 0)
 	did_pipes = 1;
     while ((pid = PerlProc_fork()) < 0) {
 	if (errno != EAGAIN) {
@@ -2470,21 +2464,18 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 #undef THAT
 #define THIS that
 #define THAT This
-	if (did_pipes) {
+	if (did_pipes)
 	    PerlLIO_close(pp[0]);
-#if defined(HAS_FCNTL) && defined(F_SETFD)
-            if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
-                return NULL;
-#endif
-	}
 	if (p[THIS] != (*mode == 'r')) {
 	    PerlLIO_dup2(p[THIS], *mode == 'r');
 	    PerlLIO_close(p[THIS]);
 	    if (p[THAT] != (*mode == 'r'))	/* if dup2() didn't close it */
 		PerlLIO_close(p[THAT]);
 	}
-	else
+	else {
+	    setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]);
 	    PerlLIO_close(p[THAT]);
+	}
 #ifndef OS2
 	if (doexec) {
 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
@@ -2519,11 +2510,10 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 #undef THIS
 #undef THAT
     }
-    do_execfree();	/* free any memory malloced by child on vfork */
     if (did_pipes)
 	PerlLIO_close(pp[1]);
     if (p[that] < p[This]) {
-	PerlLIO_dup2(p[This], p[that]);
+	PerlLIO_dup2_cloexec(p[This], p[that]);
 	PerlLIO_close(p[This]);
 	p[This] = p[that];
     }
@@ -2564,8 +2554,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 	 PerlLIO_close(pp[0]);
     return PerlIO_fdopen(p[This], mode);
 }
-#else
-#if defined(DJGPP)
+#elif defined(DJGPP)
 FILE *djgpp_popen();
 PerlIO *
 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
@@ -2577,15 +2566,12 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
     */
     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
 }
-#else
-#if defined(__LIBCATAMOUNT__)
+#elif defined(__LIBCATAMOUNT__)
 PerlIO *
 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 {
     return NULL;
 }
-#endif
-#endif
 
 #endif /* !DOSISH */
 
@@ -2903,14 +2889,12 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
        : 0
     );
 }
-#else
-#if defined(__LIBCATAMOUNT__)
+#elif defined(__LIBCATAMOUNT__)
 I32
 Perl_my_pclose(pTHX_ PerlIO *ptr)
 {
     return -1;
 }
-#endif
 #endif /* !DOSISH */
 
 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
@@ -3367,12 +3351,10 @@ Perl_get_context(void)
     if (error)
 	Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
     return (void*)t;
-#  else
-#    ifdef I_MACH_CTHREADS
+#  elif defined(I_MACH_CTHREADS)
     return (void*)cthread_data(cthread_self());
-#    else
+#  else
     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
-#    endif
 #  endif
 #else
     return (void*)NULL;
@@ -3488,23 +3470,15 @@ Perl_my_fflush_all(pTHX)
     long open_max = -1;
 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
-#   else
-#    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
+#   elif defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
     open_max = sysconf(_SC_OPEN_MAX);
-#     else
-#      ifdef FOPEN_MAX
+#   elif defined(FOPEN_MAX)
     open_max = FOPEN_MAX;
-#      else
-#       ifdef OPEN_MAX
+#   elif defined(OPEN_MAX)
     open_max = OPEN_MAX;
-#       else
-#        ifdef _NFILE
+#   elif defined(_NFILE)
     open_max = _NFILE;
-#        endif
-#       endif
-#      endif
-#     endif
-#    endif
+#   endif
     if (open_max > 0) {
       long i;
       for (i = 0; i < open_max; i++)
@@ -3869,9 +3843,9 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in
   buflen = 64;
   Newx(buf, buflen, char);
 
-  GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
+  GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */
   len = strftime(buf, buflen, fmt, &mytm);
-  GCC_DIAG_RESTORE;
+  GCC_DIAG_RESTORE_STMT;
 
   /*
   ** The following is needed to handle to the situation where
@@ -3897,9 +3871,9 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in
     Renew(buf, bufsize, char);
     while (buf) {
 
-      GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
+      GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */
       buflen = strftime(buf, bufsize, fmt, &mytm);
-      GCC_DIAG_RESTORE;
+      GCC_DIAG_RESTORE_STMT;
 
       if (buflen > 0 && buflen < bufsize)
 	break;
@@ -4265,6 +4239,10 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
 	return -1;
     }
 
+#ifdef SOCK_CLOEXEC
+    type &= ~SOCK_CLOEXEC;
+#endif
+
 #ifdef EMULATE_SOCKETPAIR_UDP
     if (type == SOCK_DGRAM)
 	return S_socketpair_udp(fd);
@@ -4324,12 +4302,10 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
   abort_tidy_up_and_fail:
 #ifdef ECONNABORTED
   errno = ECONNABORTED;	/* This would be the standard thing to do. */
-#else
-#  ifdef ECONNREFUSED
+#elif defined(ECONNREFUSED)
   errno = ECONNREFUSED;	/* E.g. Symbian does not have ECONNABORTED. */
-#  else
+#else
   errno = ETIMEDOUT;	/* Desperation time. */
-#  endif
 #endif
   tidy_up_and_fail:
     {
@@ -4407,7 +4383,7 @@ Perl_parse_unicode_opts(pTHX_ const char **popt)
 
   if (*p) {
        if (isDIGIT(*p)) {
-            const char* endptr;
+            const char* endptr = p + strlen(p);
             UV uv;
             if (grok_atoUV(p, &uv, &endptr) && uv <= U32_MAX) {
                 opt = (U32)uv;
@@ -4523,7 +4499,7 @@ Perl_seed(pTHX)
 #    define PERL_RANDOM_DEVICE "/dev/urandom"
 #  endif
 #endif
-    fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
+    fd = PerlLIO_open_cloexec(PERL_RANDOM_DEVICE, 0);
     if (fd != -1) {
     	if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
 	    u = 0;
@@ -4794,7 +4770,7 @@ S_mem_log_common(enum mem_log_type mlt, const UV n,
 	 * timeval. */
 	{
 	    STRLEN len;
-            const char* endptr;
+            const char* endptr = pmlenv + strlen(pmlenv);
 	    int fd;
             UV uv;
             if (grok_atoUV(pmlenv, &uv, &endptr) /* Ignore endptr. */
@@ -4923,28 +4899,6 @@ Perl_mem_log_del_sv(const SV *sv,
 #endif /* PERL_MEM_LOG */
 
 /*
-=for apidoc my_sprintf
-
-The C library C<sprintf>, wrapped if necessary, to ensure that it will return
-the length of the string written to the buffer.  Only rare pre-ANSI systems
-need the wrapper function - usually this is a direct call to C<sprintf>.
-
-=cut
-*/
-#ifndef SPRINTF_RETURNS_STRLEN
-int
-Perl_my_sprintf(char *buffer, const char* pat, ...)
-{
-    va_list args;
-    PERL_ARGS_ASSERT_MY_SPRINTF;
-    va_start(args, pat);
-    vsprintf(buffer, pat, args);
-    va_end(args);
-    return strlen(buffer);
-}
-#endif
-
-/*
 =for apidoc quadmath_format_single
 
 C<quadmath_snprintf()> is very strict about its C<format> string and will
@@ -5053,8 +5007,12 @@ Perl_quadmath_format_needed(const char* format)
 /*
 =for apidoc my_snprintf
 
-The C library C<snprintf> functionality (using C<vsnprintf>).
-Consider using C<sv_vcatpvf> instead.
+The C library C<snprintf> functionality, if available and
+standards-compliant (uses C<vsnprintf>, actually).  However, if the
+C<vsnprintf> is not available, will unfortunately use the unsafe
+C<vsprintf> which can overrun the buffer (there is an overrun check,
+but that may be too late).  Consider using C<sv_vcatpvf> instead, or
+getting C<vsnprintf>.
 
 =cut
 */
@@ -5064,6 +5022,9 @@ Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
     int retval = -1;
     va_list ap;
     PERL_ARGS_ASSERT_MY_SNPRINTF;
+#ifndef HAS_VSNPRINTF
+    PERL_UNUSED_VAR(len);
+#endif
     va_start(ap, format);
 #ifdef USE_QUADMATH
     {
@@ -5094,14 +5055,14 @@ Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
          * Handling the "Q-less" cases right would require walking
          * through the va_list and rewriting the format, calling
          * quadmath for the NVs, building a new va_list, and then
-         * letting vsnprintf to take care of the other
+         * letting vsnprintf/vsprintf to take care of the other
          * arguments.  This may be doable.
          *
          * We do not attempt that now.  But for paranoia, we here try
          * to detect some common (but not all) cases where the
          * "Q-less" %[efgaEFGA] formats are present, and die if
          * detected.  This doesn't fix the problem, but it stops the
-         * vsnprintf pulling doubles off the va_list when
+         * vsnprintf/vsprintf pulling doubles off the va_list when
          * __float128 NVs should be pulled off instead.
          *
          * If quadmath_format_needed() returns false, we are reasonably
@@ -5112,10 +5073,20 @@ Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
     }
 #endif
     if (retval == -1)
+#ifdef HAS_VSNPRINTF
         retval = vsnprintf(buffer, len, format, ap);
+#else
+        retval = vsprintf(buffer, format, ap);
+#endif
     va_end(ap);
+    /* vsprintf() shows failure with < 0 */
+    if (retval < 0
+#ifdef HAS_VSNPRINTF
     /* vsnprintf() shows failure with >= len */
-    if (len > 0 && (Size_t)retval >= len)
+        ||
+        (len > 0 && (Size_t)retval >= len)
+#endif
+    )
 	Perl_croak_nocontext("panic: my_snprintf buffer overflow");
     return retval;
 }
@@ -5123,7 +5094,11 @@ Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
 /*
 =for apidoc my_vsnprintf
 
-The C library C<vsnprintf>.  Consider using C<sv_vcatpvf> instead.
+The C library C<vsnprintf> if available and standards-compliant.
+However, if if the C<vsnprintf> is not available, will unfortunately
+use the unsafe C<vsprintf> which can overrun the buffer (there is an
+overrun check, but that may be too late).  Consider using
+C<sv_vcatpvf> instead, or getting C<vsnprintf>.
 
 =cut
 */
@@ -5145,13 +5120,29 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap
 
     PERL_ARGS_ASSERT_MY_VSNPRINTF;
     Perl_va_copy(ap, apc);
+# ifdef HAS_VSNPRINTF
     retval = vsnprintf(buffer, len, format, apc);
+# else
+    PERL_UNUSED_ARG(len);
+    retval = vsprintf(buffer, format, apc);
+# endif
     va_end(apc);
 #else
+# ifdef HAS_VSNPRINTF
     retval = vsnprintf(buffer, len, format, ap);
+# else
+    PERL_UNUSED_ARG(len);
+    retval = vsprintf(buffer, format, ap);
+# endif
 #endif /* #ifdef NEED_VA_COPY */
+    /* vsprintf() shows failure with < 0 */
+    if (retval < 0
+#ifdef HAS_VSNPRINTF
     /* vsnprintf() shows failure with >= len */
-    if (len > 0 && (Size_t)retval >= len)
+        ||
+        (len > 0 && (Size_t)retval >= len)
+#endif
+    )
 	Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
     return retval;
 #endif
@@ -5227,10 +5218,16 @@ Perl_my_cxt_init(pTHX_ int *index, size_t size)
     dVAR;
     void *p;
     PERL_ARGS_ASSERT_MY_CXT_INIT;
+    /* do initial check without locking.
+     * -1:    not allocated or another thread currently allocating
+     *  other: already allocated by another thread
+     */
     if (*index == -1) {
-	/* this module hasn't been allocated an index yet */
 	MUTEX_LOCK(&PL_my_ctx_mutex);
-	*index = PL_my_cxt_index++;
+        /*now a stricter check with locking */
+        if (*index == -1)
+            /* this module hasn't been allocated an index yet */
+            *index = PL_my_cxt_index++;
 	MUTEX_UNLOCK(&PL_my_ctx_mutex);
     }
     
@@ -5287,9 +5284,39 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
 
     index = Perl_my_cxt_index(aTHX_ my_cxt_key);
     if (index == -1) {
-	/* this module hasn't been allocated an index yet */
 	MUTEX_LOCK(&PL_my_ctx_mutex);
-	index = PL_my_cxt_index++;
+        /*now a stricter check with locking */
+        index = Perl_my_cxt_index(aTHX_ my_cxt_key);
+        if (index == -1)
+            /* this module hasn't been allocated an index yet */
+            index = PL_my_cxt_index++;
+
+        /* Store the index in a global MY_CXT_KEY string to index mapping
+         * table. This emulates the perl-module static my_cxt_index var on
+         * builds which don't allow static vars */
+        if (PL_my_cxt_keys_size <= index) {
+            int old_size = PL_my_cxt_keys_size;
+            int i;
+            if (PL_my_cxt_keys_size) {
+                IV new_size = PL_my_cxt_keys_size;
+                while (new_size <= index)
+                    new_size *= 2;
+                PL_my_cxt_keys = (const char **)PerlMemShared_realloc(
+                                        PL_my_cxt_keys,
+                                        new_size * sizeof(const char *));
+                PL_my_cxt_keys_size = new_size;
+            }
+            else {
+                PL_my_cxt_keys_size = 16;
+                PL_my_cxt_keys = (const char **)PerlMemShared_malloc(
+                            PL_my_cxt_keys_size * sizeof(const char *));
+            }
+            for (i = old_size; i < PL_my_cxt_keys_size; i++) {
+                PL_my_cxt_keys[i] = 0;
+            }
+        }
+        PL_my_cxt_keys[index] = my_cxt_key;
+
 	MUTEX_UNLOCK(&PL_my_ctx_mutex);
     }
 
@@ -5302,20 +5329,16 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
 	    while (new_size <= index)
 		new_size *= 2;
 	    Renew(PL_my_cxt_list, new_size, void *);
-	    Renew(PL_my_cxt_keys, new_size, const char *);
             PL_my_cxt_size = new_size;
 	}
 	else {
 	    PL_my_cxt_size = 16;
 	    Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
-	    Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
 	}
 	for (i = old_size; i < PL_my_cxt_size; i++) {
-	    PL_my_cxt_keys[i] = 0;
 	    PL_my_cxt_list[i] = 0;
 	}
     }
-    PL_my_cxt_keys[index] = my_cxt_key;
     /* newSV() allocates one more than needed */
     p = (void*)SvPVX(newSV(size-1));
     PL_my_cxt_list[index] = p;
@@ -5580,6 +5603,36 @@ Perl_my_strlcpy(char *dst, const char *src, Size_t size)
 }
 #endif
 
+/*
+=for apidoc my_strnlen
+
+The C library C<strnlen> if available, or a Perl implementation of it.
+
+C<my_strnlen()> computes the length of the string, up to C<maxlen>
+characters.  It will will never attempt to address more than C<maxlen>
+characters, making it suitable for use with strings that are not
+guaranteed to be NUL-terminated.
+
+=cut
+
+Description stolen from http://man.openbsd.org/strnlen.3,
+implementation stolen from PostgreSQL.
+*/
+#ifndef HAS_STRNLEN
+Size_t
+Perl_my_strnlen(const char *str, Size_t maxlen)
+{
+    const char *p = str;
+
+    PERL_ARGS_ASSERT_MY_STRNLEN;
+
+    while(maxlen-- && *p)
+        p++;
+
+    return p - str;
+}
+#endif
+
 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
 long _ftol( double ); /* Defined by VC6 C libs. */
@@ -5673,24 +5726,22 @@ Perl_my_dirfd(DIR * dir) {
 #endif 
 }
 
-#ifndef HAS_MKSTEMP
+#if !defined(HAS_MKOSTEMP) || !defined(HAS_MKSTEMP)
 
 #define TEMP_FILE_CH "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvxyz0123456789"
 #define TEMP_FILE_CH_COUNT (sizeof(TEMP_FILE_CH)-1)
 
-int
-Perl_my_mkstemp(char *templte) {
+static int
+S_my_mkostemp(char *templte, int flags) {
     dTHX;
     STRLEN len = strlen(templte);
     int fd;
     int attempts = 0;
 
-    PERL_ARGS_ASSERT_MY_MKSTEMP;
-
     if (len < 6 ||
         templte[len-1] != 'X' || templte[len-2] != 'X' || templte[len-3] != 'X' ||
         templte[len-4] != 'X' || templte[len-5] != 'X' || templte[len-6] != 'X') {
-        errno = EINVAL;
+        SETERRNO(EINVAL, LIB_INVARG);
         return -1;
     }
 
@@ -5699,7 +5750,7 @@ Perl_my_mkstemp(char *templte) {
         for (i = 1; i <= 6; ++i) {
             templte[len-i] = TEMP_FILE_CH[(int)(Perl_internal_drand48() * TEMP_FILE_CH_COUNT)];
         }
-        fd = PerlLIO_open3(templte, O_RDWR | O_CREAT | O_EXCL, 0600);
+        fd = PerlLIO_open3(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600);
     } while (fd == -1 && errno == EEXIST && ++attempts <= 100);
 
     return fd;
@@ -5707,6 +5758,24 @@ Perl_my_mkstemp(char *templte) {
 
 #endif
 
+#ifndef HAS_MKOSTEMP
+int
+Perl_my_mkostemp(char *templte, int flags)
+{
+    PERL_ARGS_ASSERT_MY_MKOSTEMP;
+    return S_my_mkostemp(templte, flags);
+}
+#endif
+
+#ifndef HAS_MKSTEMP
+int
+Perl_my_mkstemp(char *templte)
+{
+    PERL_ARGS_ASSERT_MY_MKSTEMP;
+    return S_my_mkostemp(templte, 0);
+}
+#endif
+
 REGEXP *
 Perl_get_re_arg(pTHX_ SV *sv) {
 
@@ -5747,9 +5816,9 @@ Perl_get_re_arg(pTHX_ SV *sv) {
 
 #ifdef PERL_DRAND48_QUAD
 
-#define DRAND48_MULT U64_CONST(0x5deece66d)
+#define DRAND48_MULT UINT64_C(0x5deece66d)
 #define DRAND48_ADD  0xb
-#define DRAND48_MASK U64_CONST(0xffffffffffff)
+#define DRAND48_MASK UINT64_C(0xffffffffffff)
 
 #else
 
@@ -6015,7 +6084,7 @@ static const char* atos_parse(const char* p,
      * The matched regular expression is roughly "\(.*:\d+\)\s*$" */
     const char* source_number_start;
     const char* source_name_end;
-    const char* source_line_end;
+    const char* source_line_end = start;
     const char* close_paren;
     UV uv;