Configure: fix nl_langinfo_l() probe

[perl5.git] / util.c

diff --git a/util.c b/util.c
index 0a2c11e..d93e483 100644 (file)
--- a/util.c
+++ b/util.c
@@ -45,6 +45,10 @@
 int putenv(char *);
 #endif
 
 int putenv(char *);
 #endif
 

+#ifdef __amigaos__
+# include "amigaos4/amigaio.h"
+#endif
+

 #ifdef HAS_SELECT
 # ifdef I_SYS_SELECT
 #  include <sys/select.h>
 #ifdef HAS_SELECT
 # ifdef I_SYS_SELECT
 #  include <sys/select.h>


@@ -136,7 +140,7 @@ Perl_safesysmalloc(MEM_SIZE size)
 #endif
 #ifdef DEBUGGING
     if ((SSize_t)size < 0)
 #endif
 #ifdef DEBUGGING
     if ((SSize_t)size < 0)

-       Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
+       Perl_croak_nocontext("panic: malloc, size=%" UVuf, (UV) size);

 #endif
     if (!size) size = 1;       /* malloc(0) is NASTY on our system */
 #ifdef PERL_DEBUG_READONLY_COW
 #endif
     if (!size) size = 1;       /* malloc(0) is NASTY on our system */
 #ifdef PERL_DEBUG_READONLY_COW


@@ -176,7 +180,7 @@ Perl_safesysmalloc(MEM_SIZE size)
        header->size = size;
 #endif
        ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
        header->size = size;
 #endif
        ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);

-       DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
+       DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));

 
     }
     else {
 
     }
     else {


@@ -253,7 +257,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 #endif
 #ifdef DEBUGGING
        if ((SSize_t)size < 0)
 #endif
 #ifdef DEBUGGING
        if ((SSize_t)size < 0)

-           Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
+           Perl_croak_nocontext("panic: realloc, size=%" UVuf, (UV)size);

 #endif
 #ifdef PERL_DEBUG_READONLY_COW
        if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
 #endif
 #ifdef PERL_DEBUG_READONLY_COW
        if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,


@@ -300,8 +304,8 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
     /* In particular, must do that fixup above before logging anything via
      *printf(), as it can reallocate memory, which can cause SEGVs.  */
 
     /* In particular, must do that fixup above before logging anything via
      *printf(), as it can reallocate memory, which can cause SEGVs.  */
 

-       DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
-       DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
+       DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
+       DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));

 
        if (ptr == NULL) {
 #ifdef USE_MDH
 
        if (ptr == NULL) {
 #ifdef USE_MDH


@@ -329,7 +333,7 @@ Perl_safesysfree(Malloc_t where)
 #ifdef ALWAYS_NEED_THX
     dTHX;
 #endif
 #ifdef ALWAYS_NEED_THX
     dTHX;
 #endif

-    DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
+    DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) free\n",PTR2UV(where),(long)PL_an++));

     if (where) {
 #ifdef USE_MDH
        Malloc_t where_intrn = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
     if (where) {
 #ifdef USE_MDH
        Malloc_t where_intrn = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);


@@ -415,7 +419,7 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 #endif
 #ifdef DEBUGGING
     if ((SSize_t)size < 0 || (SSize_t)count < 0)
 #endif
 #ifdef DEBUGGING
     if ((SSize_t)size < 0 || (SSize_t)count < 0)

-       Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf,
+       Perl_croak_nocontext("panic: calloc, size=%" UVuf ", count=%" UVuf,

                             (UV)size, (UV)count);
 #endif
 #ifdef PERL_DEBUG_READONLY_COW
                             (UV)size, (UV)count);
 #endif
 #ifdef PERL_DEBUG_READONLY_COW


@@ -438,7 +442,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);
        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 %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size));

     if (ptr != NULL) {
 #ifdef USE_MDH
        {
     if (ptr != NULL) {
 #ifdef USE_MDH
        {


@@ -518,17 +522,26 @@ Free_t   Perl_mfree (Malloc_t where)
 
 #endif
 
 
 #endif
 

-/* copy a string up to some (non-backslashed) delimiter, if any */
+/* copy a string up to some (non-backslashed) delimiter, if any.
+ * With allow_escape, converts \<delimiter> to <delimiter>, while leaves
+ * \<non-delimiter> as-is.
+ * Returns the position in the src string of the closing delimiter, if
+ * any, or returns fromend otherwise.
+ * This is the internal implementation for Perl_delimcpy and
+ * Perl_delimcpy_no_escape.
+ */

 
 

-char *
-Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)
+static char *
+S_delimcpy_intern(char *to, const char *toend, const char *from,
+          const char *fromend, int delim, I32 *retlen,
+          const bool allow_escape)

 {
     I32 tolen;
 
     PERL_ARGS_ASSERT_DELIMCPY;
 
     for (tolen = 0; from < fromend; from++, tolen++) {
 {
     I32 tolen;
 
     PERL_ARGS_ASSERT_DELIMCPY;
 
     for (tolen = 0; from < fromend; from++, tolen++) {

-       if (*from == '\\') {
+       if (allow_escape && *from == '\\' && from + 1 < fromend) {

            if (from[1] != delim) {
                if (to < toend)
                    *to++ = *from;
            if (from[1] != delim) {
                if (to < toend)
                    *to++ = *from;


@@ -547,34 +560,70 @@ Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend
     return (char *)from;
 }
 
     return (char *)from;
 }
 

-/* return ptr to little string in big string, NULL if not found */
-/* This routine was donated by Corey Satten. */
-

 char *
 char *

-Perl_instr(const char *big, const char *little)
+Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)

 {
 {

+    PERL_ARGS_ASSERT_DELIMCPY;
+
+    return S_delimcpy_intern(to, toend, from, fromend, delim, retlen, 1);
+}

 
 

-    PERL_ARGS_ASSERT_INSTR;
+char *
+Perl_delimcpy_no_escape(char *to, const char *toend, const char *from,
+                       const char *fromend, int delim, I32 *retlen)
+{
+    PERL_ARGS_ASSERT_DELIMCPY_NO_ESCAPE;

 
 

-    return strstr((char*)big, (char*)little);
+    return S_delimcpy_intern(to, toend, from, fromend, delim, retlen, 0);

 }
 
 }
 

-/* same as instr but allow embedded nulls.  The end pointers point to 1 beyond
- * the final character desired to be checked */
+/*
+=head1 Miscellaneous Functions
+
+=for apidoc Am|char *|ninstr|char * big|char * bigend|char * little|char * little_end
+
+Find the first (leftmost) occurrence of a sequence of bytes within another
+sequence.  This is the Perl version of C<strstr()>, extended to handle
+arbitrary sequences, potentially containing embedded C<NUL> characters (C<NUL>
+is what the initial C<n> in the function name stands for; some systems have an
+equivalent, C<memmem()>, but with a somewhat different API).
+
+Another way of thinking about this function is finding a needle in a haystack.
+C<big> points to the first byte in the haystack.  C<big_end> points to one byte
+beyond the final byte in the haystack.  C<little> points to the first byte in
+the needle.  C<little_end> points to one byte beyond the final byte in the
+needle.  All the parameters must be non-C<NULL>.
+
+The function returns C<NULL> if there is no occurrence of C<little> within
+C<big>.  If C<little> is the empty string, C<big> is returned.
+
+Because this function operates at the byte level, and because of the inherent
+characteristics of UTF-8 (or UTF-EBCDIC), it will work properly if both the
+needle and the haystack are strings with the same UTF-8ness, but not if the
+UTF-8ness differs.
+
+=cut
+
+*/

 
 char *
 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
 {
     PERL_ARGS_ASSERT_NINSTR;
 
 char *
 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
 {
     PERL_ARGS_ASSERT_NINSTR;

+
+#ifdef HAS_MEMMEM
+    return ninstr(big, bigend, little, lend);
+#else
+

     if (little >= lend)
         return (char*)big;
     {
         const char first = *little;
     if (little >= lend)
         return (char*)big;
     {
         const char first = *little;

-        const char *s, *x;

         bigend -= lend - little++;
     OUTER:
         while (big <= bigend) {
             if (*big++ == first) {
         bigend -= lend - little++;
     OUTER:
         while (big <= bigend) {
             if (*big++ == first) {

+                const char *s, *x;

                 for (x=big,s=little; s < lend; x++,s++) {
                     if (*s != *x)
                         goto OUTER;
                 for (x=big,s=little; s < lend; x++,s++) {
                     if (*s != *x)
                         goto OUTER;


@@ -584,9 +633,23 @@ Perl_ninstr(const char *big, const char *bigend, const char *little, const char
         }
     }
     return NULL;
         }
     }
     return NULL;

+
+#endif
+

 }
 
 }
 

-/* reverse of the above--find last substring */
+/*
+=head1 Miscellaneous Functions
+
+=for apidoc Am|char *|rninstr|char * big|char * bigend|char * little|char * little_end
+
+Like C<L</ninstr>>, but instead finds the final (rightmost) occurrence of a
+sequence of bytes within another sequence, returning C<NULL> if there is no
+such occurrence.
+
+=cut
+
+*/

 
 char *
 Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend)
 
 char *
 Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend)


@@ -630,7 +693,7 @@ Perl_rninstr(const char *big, const char *bigend, const char *little, const char
 
 =for apidoc fbm_compile
 
 
 =for apidoc fbm_compile
 

-Analyses the string in order to make fast searches on it using fbm_instr()
+Analyses the string in order to make fast searches on it using C<fbm_instr()>

 -- the Boyer-Moore algorithm.
 
 =cut
 -- the Boyer-Moore algorithm.
 
 =cut


@@ -668,21 +731,8 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
     SvUPGRADE(sv, SVt_PVMG);
     SvIOK_off(sv);
     SvNOK_off(sv);
     SvUPGRADE(sv, SVt_PVMG);
     SvIOK_off(sv);
     SvNOK_off(sv);

-    SvVALID_on(sv);
-
-    /* "deep magic", the comment used to add. The use of MAGIC itself isn't
-       really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2)
-       to call SvVALID_off() if the scalar was assigned to.

 
 

-       The comment itself (and "deeper magic" below) date back to
-       378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on
-       str->str_pok |= 2;
-       where the magic (presumably) was that the scalar had a BM table hidden
-       inside itself.
-
-       As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store
-       the table instead of the previous (somewhat hacky) approach of co-opting
-       the string buffer and storing it after the string.  */
+    /* add PERL_MAGIC_bm magic holding the FBM lookup table */

 
     assert(!mg_find(sv, PERL_MAGIC_bm));
     mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
 
     assert(!mg_find(sv, PERL_MAGIC_bm));
     mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);


@@ -717,27 +767,42 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
        }
     }
     BmUSEFUL(sv) = 100;                        /* Initial value */
        }
     }
     BmUSEFUL(sv) = 100;                        /* Initial value */

-    if (flags & FBMcf_TAIL)
-       SvTAIL_on(sv);
-    DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n",
+    ((XPVNV*)SvANY(sv))->xnv_u.xnv_bm_tail = cBOOL(flags & FBMcf_TAIL);
+    DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %" UVuf "\n",

                          s[rarest], (UV)rarest));
 }
 
                          s[rarest], (UV)rarest));
 }
 

-/* If SvTAIL(littlestr), it has a fake '\n' at end. */
-/* If SvTAIL is actually due to \Z or \z, this gives false positives
-   if multiline */

 
 /*
 =for apidoc fbm_instr
 
 Returns the location of the SV in the string delimited by C<big> and
 
 /*
 =for apidoc fbm_instr
 
 Returns the location of the SV in the string delimited by C<big> and

-C<bigend>.  It returns C<NULL> if the string can't be found.  The C<sv>
-does not have to be fbm_compiled, but the search will not be as fast
+C<bigend> (C<bigend>) is the char following the last char).
+It returns C<NULL> if the string can't be found.  The C<sv>
+does not have to be C<fbm_compiled>, but the search will not be as fast

 then.
 
 =cut
 then.
 
 =cut

+
+If SvTAIL(littlestr) is true, a fake "\n" was appended to to the string
+during FBM compilation due to FBMcf_TAIL in flags. It indicates that
+the littlestr must be anchored to the end of bigstr (or to any \n if
+FBMrf_MULTILINE).
+
+E.g. The regex compiler would compile /abc/ to a littlestr of "abc",
+while /abc$/ compiles to "abc\n" with SvTAIL() true.
+
+A littlestr of "abc", !SvTAIL matches as /abc/;
+a littlestr of "ab\n", SvTAIL matches as:
+   without FBMrf_MULTILINE: /ab\n?\z/
+   with    FBMrf_MULTILINE: /ab\n/ || /ab\z/;
+
+(According to Ilya from 1999; I don't know if this is still true, DAPM 2015):
+  "If SvTAIL is actually due to \Z or \z, this gives false positives
+  if multiline".

 */
 
 */
 

+

 char *
 Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags)
 {
 char *
 Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags)
 {


@@ -746,11 +811,15 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U
     const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
     STRLEN littlelen = l;
     const I32 multiline = flags & FBMrf_MULTILINE;
     const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
     STRLEN littlelen = l;
     const I32 multiline = flags & FBMrf_MULTILINE;

+    bool valid = SvVALID(littlestr);
+    bool tail = valid ? cBOOL(SvTAIL(littlestr)) : FALSE;

 
     PERL_ARGS_ASSERT_FBM_INSTR;
 
 
     PERL_ARGS_ASSERT_FBM_INSTR;
 

+    assert(bigend >= big);
+

     if ((STRLEN)(bigend - big) < littlelen) {
     if ((STRLEN)(bigend - big) < littlelen) {

-       if ( SvTAIL(littlestr)
+       if (     tail

             && ((STRLEN)(bigend - big) == littlelen - 1)
             && (littlelen == 1
                 || (*big == *little &&
             && ((STRLEN)(bigend - big) == littlelen - 1)
             && (littlelen == 1
                 || (*big == *little &&


@@ -762,87 +831,108 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U
     switch (littlelen) { /* Special cases for 0, 1 and 2  */
     case 0:
        return (char*)big;              /* Cannot be SvTAIL! */
     switch (littlelen) { /* Special cases for 0, 1 and 2  */
     case 0:
        return (char*)big;              /* Cannot be SvTAIL! */

+

     case 1:
     case 1:

-           if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
-               /* Know that bigend != big.  */
-               if (bigend[-1] == '\n')
-                   return (char *)(bigend - 1);
-               return (char *) bigend;
-           }
-           s = big;
-           while (s < bigend) {
-               if (*s == *little)
-                   return (char *)s;
-               s++;
-           }
-           if (SvTAIL(littlestr))
+           if (tail && !multiline) /* Anchor only! */
+               /* [-1] is safe because we know that bigend != big.  */
+               return (char *) (bigend - (bigend[-1] == '\n'));
+
+           s = (unsigned char *)memchr((void*)big, *little, bigend-big);
+            if (s)
+                return (char *)s;
+           if (tail)

                return (char *) bigend;
            return NULL;
                return (char *) bigend;
            return NULL;

+

     case 2:
     case 2:

-       if (SvTAIL(littlestr) && !multiline) {
-           if (bigend[-1] == '\n' && bigend[-2] == *little)
+       if (tail && !multiline) {
+            /* a littlestr with SvTAIL must be of the form "X\n" (where X
+             * is a single char). It is anchored, and can only match
+             * "....X\n"  or  "....X" */
+            if (bigend[-2] == *little && bigend[-1] == '\n')

                return (char*)bigend - 2;
            if (bigend[-1] == *little)
                return (char*)bigend - 1;
            return NULL;
        }
                return (char*)bigend - 2;
            if (bigend[-1] == *little)
                return (char*)bigend - 1;
            return NULL;
        }

+

        {
        {

-           /* This should be better than FBM if c1 == c2, and almost
-              as good otherwise: maybe better since we do less indirection.
-              And we save a lot of memory by caching no table. */
-           const unsigned char c1 = little[0];
-           const unsigned char c2 = little[1];
-
-           s = big + 1;
-           bigend--;
-           if (c1 != c2) {
-               while (s <= bigend) {
-                   if (s[0] == c2) {
-                       if (s[-1] == c1)
-                           return (char*)s - 1;
-                       s += 2;
-                       continue;
-                   }
-                 next_chars:
-                   if (s[0] == c1) {
-                       if (s == bigend)
-                           goto check_1char_anchor;
-                       if (s[1] == c2)
-                           return (char*)s;
-                       else {
-                           s++;
-                           goto next_chars;
-                       }
-                   }
-                   else
-                       s += 2;
-               }
-               goto check_1char_anchor;
-           }
-           /* Now c1 == c2 */
-           while (s <= bigend) {
-               if (s[0] == c1) {
-                   if (s[-1] == c1)
-                       return (char*)s - 1;
-                   if (s == bigend)
-                       goto check_1char_anchor;
-                   if (s[1] == c1)
-                       return (char*)s;
-                   s += 3;
-               }
-               else
-                   s += 2;
-           }
-       }
-      check_1char_anchor:              /* One char and anchor! */
-       if (SvTAIL(littlestr) && (*bigend == *little))
-           return (char *)bigend;      /* bigend is already decremented. */
-       return NULL;
+            /* memchr() is likely to be very fast, possibly using whatever
+             * hardware support is available, such as checking a whole
+             * cache line in one instruction.
+             * So for a 2 char pattern, calling memchr() is likely to be
+             * faster than running FBM, or rolling our own. The previous
+             * version of this code was roll-your-own which typically
+             * only needed to read every 2nd char, which was good back in
+             * the day, but no longer.
+             */
+           unsigned char c1 = little[0];
+           unsigned char c2 = little[1];
+
+            /* *** for all this case, bigend points to the last char,
+             * not the trailing \0: this makes the conditions slightly
+             * simpler */
+            bigend--;
+           s = big;
+            if (c1 != c2) {
+                while (s < bigend) {
+                    /* do a quick test for c1 before calling memchr();
+                     * this avoids the expensive fn call overhead when
+                     * there are lots of c1's */
+                    if (LIKELY(*s != c1)) {
+                        s++;
+                        s = (unsigned char *)memchr((void*)s, c1, bigend - s);
+                        if (!s)
+                            break;
+                    }
+                    if (s[1] == c2)
+                        return (char*)s;
+
+                    /* failed; try searching for c2 this time; that way
+                     * we don't go pathologically slow when the string
+                     * consists mostly of c1's or vice versa.
+                     */
+                    s += 2;
+                    if (s > bigend)
+                        break;
+                    s = (unsigned char *)memchr((void*)s, c2, bigend - s + 1);
+                    if (!s)
+                        break;
+                    if (s[-1] == c1)
+                        return (char*)s - 1;
+                }
+            }
+            else {
+                /* c1, c2 the same */
+                while (s < bigend) {
+                    if (s[0] == c1) {
+                      got_1char:
+                        if (s[1] == c1)
+                            return (char*)s;
+                        s += 2;
+                    }
+                    else {
+                        s++;
+                        s = (unsigned char *)memchr((void*)s, c1, bigend - s);
+                        if (!s || s >= bigend)
+                            break;
+                        goto got_1char;
+                    }
+                }
+            }
+
+            /* failed to find 2 chars; try anchored match at end without
+             * the \n */
+            if (tail && bigend[0] == little[0])
+                return (char *)bigend;
+            return NULL;
+        }
+

     default:
        break; /* Only lengths 0 1 and 2 have special-case code.  */
     }
 
     default:
        break; /* Only lengths 0 1 and 2 have special-case code.  */
     }
 

-    if (SvTAIL(littlestr) && !multiline) {     /* tail anchored? */
+    if (tail && !multiline) {  /* tail anchored? */

        s = bigend - littlelen;
        if (s >= big && bigend[-1] == '\n' && *s == *little
            /* Automatically of length > 2 */
        s = bigend - littlelen;
        if (s >= big && bigend[-1] == '\n' && *s == *little
            /* Automatically of length > 2 */


@@ -857,20 +947,13 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U
        }
        return NULL;
     }
        }
        return NULL;
     }

-    if (!SvVALID(littlestr)) {
+
+    if (!valid) {
+        /* not compiled; use Perl_ninstr() instead */

        char * const b = ninstr((char*)big,(char*)bigend,
                         (char*)little, (char*)little + littlelen);
 
        char * const b = ninstr((char*)big,(char*)bigend,
                         (char*)little, (char*)little + littlelen);
 

-       if (!b && SvTAIL(littlestr)) {  /* Automatically multiline!  */
-           /* Chop \n from littlestr: */
-           s = bigend - littlelen + 1;
-           if (*s == *little
-               && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
-           {
-               return (char*)s;
-           }
-           return NULL;
-       }
+        assert(!tail); /* valid => FBM; tail only set on SvVALID SVs */

        return b;
     }
 
        return b;
     }
 


@@ -891,15 +974,30 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U
        oldlittle = little;
        if (s < bigend) {
            const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
        oldlittle = little;
        if (s < bigend) {
            const unsigned char * const table = (const unsigned char *) mg->mg_ptr;

+            const unsigned char lastc = *little;

            I32 tmp;
 
          top2:
            if ((tmp = table[*s])) {
            I32 tmp;
 
          top2:
            if ((tmp = table[*s])) {

-               if ((s += tmp) < bigend)
-                   goto top2;
-               goto check_end;
+                /* *s != lastc; earliest position it could match now is
+                 * tmp slots further on */
+               if ((s += tmp) >= bigend)
+                    goto check_end;
+                if (LIKELY(*s != lastc)) {
+                    s++;
+                    s = (unsigned char *)memchr((void*)s, lastc, bigend - s);
+                    if (!s) {
+                        s = bigend;
+                        goto check_end;
+                    }
+                    goto top2;
+                }

            }
            }

-           else {              /* less expensive than calling strncmp() */
+
+
+            /* hand-rolled strncmp(): less expensive than calling the
+             * real function (maybe???) */
+           {

                unsigned char * const olds = s;
 
                tmp = littlelen;
                unsigned char * const olds = s;
 
                tmp = littlelen;


@@ -918,7 +1016,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U
        }
       check_end:
        if ( s == bigend
        }
       check_end:
        if ( s == bigend

-            && SvTAIL(littlestr)
+            && tail

             && memEQ((char *)(bigend - littlelen),
                      (char *)(oldlittle - littlelen), littlelen) )
            return (char*)bigend - littlelen;
             && memEQ((char *)(bigend - littlelen),
                      (char *)(oldlittle - littlelen), littlelen) )
            return (char*)bigend - littlelen;


@@ -926,87 +1024,6 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U
     }
 }
 
     }
 }
 

-/*
-=for apidoc foldEQ
-
-Returns true if the leading len bytes of the strings s1 and s2 are the same
-case-insensitively; false otherwise.  Uppercase and lowercase ASCII range bytes
-match themselves and their opposite case counterparts.  Non-cased and non-ASCII
-range bytes match only themselves.
-
-=cut
-*/
-
-
-I32
-Perl_foldEQ(const char *s1, const char *s2, I32 len)
-{
-    const U8 *a = (const U8 *)s1;
-    const U8 *b = (const U8 *)s2;
-
-    PERL_ARGS_ASSERT_FOLDEQ;
-
-    assert(len >= 0);
-
-    while (len--) {
-       if (*a != *b && *a != PL_fold[*b])
-           return 0;
-       a++,b++;
-    }
-    return 1;
-}
-I32
-Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
-{
-    /* Compare non-utf8 using Unicode (Latin1) semantics.  Does not work on
-     * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
-     * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these.  Nor
-     * does it check that the strings each have at least 'len' characters */
-
-    const U8 *a = (const U8 *)s1;
-    const U8 *b = (const U8 *)s2;
-
-    PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
-
-    assert(len >= 0);
-
-    while (len--) {
-       if (*a != *b && *a != PL_fold_latin1[*b]) {
-           return 0;
-       }
-       a++, b++;
-    }
-    return 1;
-}
-
-/*
-=for apidoc foldEQ_locale
-
-Returns true if the leading len bytes of the strings s1 and s2 are the same
-case-insensitively in the current locale; false otherwise.
-
-=cut
-*/
-
-I32
-Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
-{
-    dVAR;
-    const U8 *a = (const U8 *)s1;
-    const U8 *b = (const U8 *)s2;
-
-    PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
-
-    assert(len >= 0);
-
-    while (len--) {
-       if (*a != *b && *a != PL_fold_locale[*b])
-           return 0;
-       a++,b++;
-    }
-    return 1;
-}
-

 /* copy a string to a safe spot */
 
 /*
 /* copy a string to a safe spot */
 
 /*


@@ -1110,7 +1127,7 @@ Perl_savesharedpv(pTHX_ const char *pv)
 =for apidoc savesharedpvn
 
 A version of C<savepvn()> which allocates the duplicate string in memory
 =for apidoc savesharedpvn
 
 A version of C<savepvn()> which allocates the duplicate string in memory

-which is shared between threads.  (With the specific difference that a NULL
+which is shared between threads.  (With the specific difference that a C<NULL>

 pointer is not acceptable)
 
 =cut
 pointer is not acceptable)
 
 =cut


@@ -1411,14 +1428,17 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
         * from the sibling of PL_curcop.
         */
 
         * from the sibling of PL_curcop.
         */
 

-       const COP *cop =
-           closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE);
-       if (!cop)
-           cop = PL_curcop;
+        if (PL_curcop) {
+            const COP *cop =
+                closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE);
+            if (!cop)
+                cop = PL_curcop;
+
+            if (CopLINE(cop))
+                Perl_sv_catpvf(aTHX_ sv, " at %s line %" IVdf,
+                                OutCopFILE(cop), (IV)CopLINE(cop));
+        }

 
 

-       if (CopLINE(cop))
-           Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
-           OutCopFILE(cop), (IV)CopLINE(cop));

        /* Seems that GvIO() can be untrustworthy during global destruction. */
        if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
                && IoLINES(GvIOp(PL_last_in_gv)))
        /* Seems that GvIO() can be untrustworthy during global destruction. */
        if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
                && IoLINES(GvIOp(PL_last_in_gv)))


@@ -1426,7 +1446,7 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
            STRLEN l;
            const bool line_mode = (RsSIMPLE(PL_rs) &&
                                   *SvPV_const(PL_rs,l) == '\n' && l == 1);
            STRLEN l;
            const bool line_mode = (RsSIMPLE(PL_rs) &&
                                   *SvPV_const(PL_rs,l) == '\n' && l == 1);

-           Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf,
+           Perl_sv_catpvf(aTHX_ sv, ", <%" SVf "> %s %" IVdf,

                           SVfARG(PL_last_in_gv == PL_argvgv
                                  ? &PL_sv_no
                                  : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
                           SVfARG(PL_last_in_gv == PL_argvgv
                                  ? &PL_sv_no
                                  : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),


@@ -1444,7 +1464,8 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
 =for apidoc Am|SV *|vmess|const char *pat|va_list *args
 
 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
 =for apidoc Am|SV *|vmess|const char *pat|va_list *args
 
 C<pat> and C<args> are a sprintf-style format pattern and encapsulated

-argument list.  These are used to generate a string message.  If the
+argument list, respectively.  These are used to generate a string message.  If
+the

 message does not end with a newline, then it will be extended with
 some indication of the current location in the code, as described for
 L</mess_sv>.
 message does not end with a newline, then it will be extended with
 some indication of the current location in the code, as described for
 L</mess_sv>.


@@ -2049,6 +2070,9 @@ void
 Perl_my_setenv(pTHX_ const char *nam, const char *val)
 {
   dVAR;
 Perl_my_setenv(pTHX_ const char *nam, const char *val)
 {
   dVAR;

+#ifdef __amigaos4__
+  amigaos4_obtain_environ(__FUNCTION__);
+#endif

 #ifdef USE_ITHREADS
   /* only parent thread can modify process environment */
   if (PL_curinterp == aTHX)
 #ifdef USE_ITHREADS
   /* only parent thread can modify process environment */
   if (PL_curinterp == aTHX)


@@ -2090,7 +2114,11 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
                 environ[i] = environ[i+1];
                 i++;
             }
                 environ[i] = environ[i+1];
                 i++;
             }

+#ifdef __amigaos4__
+            goto my_setenv_out;
+#else

             return;
             return;

+#endif

         }
         if (!environ[i]) {                 /* does not exist yet */
             environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
         }
         if (!environ[i]) {                 /* does not exist yet */
             environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));


@@ -2110,7 +2138,7 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
        Configure doesn't test for that yet.  For Solaris, setenv() and unsetenv()
        were introduced in Solaris 9, so testing for HAS UNSETENV is sufficient.
     */
        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))
+#   if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) || defined(PERL_DARWIN)

 #       if defined(HAS_UNSETENV)
         if (val == NULL) {
             (void)unsetenv(nam);
 #       if defined(HAS_UNSETENV)
         if (val == NULL) {
             (void)unsetenv(nam);


@@ -2151,6 +2179,10 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
     }
 #endif
   }
     }
 #endif
   }

+#ifdef __amigaos4__
+my_setenv_out:
+  amigaos4_release_environ(__FUNCTION__);
+#endif

 }
 
 #else /* WIN32 || NETWARE */
 }
 
 #else /* WIN32 || NETWARE */


@@ -2191,17 +2223,20 @@ Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
 }
 #endif
 
 }
 #endif
 

-/* this is a drop-in replacement for bcopy() */
-#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
-char *
-Perl_my_bcopy(const char *from, char *to, I32 len)
+/* this is a drop-in replacement for bcopy(), except for the return
+ * value, which we need to be able to emulate memcpy()  */
+#if !defined(HAS_MEMCPY) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY))
+void *
+Perl_my_bcopy(const void *vfrom, void *vto, size_t len)

 {
 {

-    char * const retval = to;
+#if defined(HAS_BCOPY) && defined(HAS_SAFE_BCOPY)
+    bcopy(vfrom, vto, len);
+#else
+    const unsigned char *from = (const unsigned char *)vfrom;
+    unsigned char *to = (unsigned char *)vto;

 
     PERL_ARGS_ASSERT_MY_BCOPY;
 
 
     PERL_ARGS_ASSERT_MY_BCOPY;
 

-    assert(len >= 0);
-

     if (from - to >= 0) {
        while (len--)
            *to++ = *from++;
     if (from - to >= 0) {
        while (len--)
            *to++ = *from++;


@@ -2212,57 +2247,53 @@ Perl_my_bcopy(const char *from, char *to, I32 len)
        while (len--)
            *(--to) = *(--from);
     }
        while (len--)
            *(--to) = *(--from);
     }

-    return retval;
+#endif
+
+    return vto;

 }
 #endif
 
 /* this is a drop-in replacement for memset() */
 #ifndef HAS_MEMSET
 void *
 }
 #endif
 
 /* this is a drop-in replacement for memset() */
 #ifndef HAS_MEMSET
 void *

-Perl_my_memset(char *loc, I32 ch, I32 len)
+Perl_my_memset(void *vloc, int ch, size_t len)

 {
 {

-    char * const retval = loc;
+    unsigned char *loc = (unsigned char *)vloc;

 
     PERL_ARGS_ASSERT_MY_MEMSET;
 
 
     PERL_ARGS_ASSERT_MY_MEMSET;
 

-    assert(len >= 0);
-

     while (len--)
        *loc++ = ch;
     while (len--)
        *loc++ = ch;

-    return retval;
+    return vloc;

 }
 #endif
 
 /* this is a drop-in replacement for bzero() */
 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
 }
 #endif
 
 /* this is a drop-in replacement for bzero() */
 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)

-char *
-Perl_my_bzero(char *loc, I32 len)
+void *
+Perl_my_bzero(void *vloc, size_t len)

 {
 {

-    char * const retval = loc;
+    unsigned char *loc = (unsigned char *)vloc;

 
     PERL_ARGS_ASSERT_MY_BZERO;
 
 
     PERL_ARGS_ASSERT_MY_BZERO;
 

-    assert(len >= 0);
-

     while (len--)
        *loc++ = 0;
     while (len--)
        *loc++ = 0;

-    return retval;
+    return vloc;

 }
 #endif
 
 /* this is a drop-in replacement for memcmp() */
 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
 }
 #endif
 
 /* this is a drop-in replacement for memcmp() */
 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)

-I32
-Perl_my_memcmp(const char *s1, const char *s2, I32 len)
+int
+Perl_my_memcmp(const void *vs1, const void *vs2, size_t len)

 {
 {

-    const U8 *a = (const U8 *)s1;
-    const U8 *b = (const U8 *)s2;
-    I32 tmp;
+    const U8 *a = (const U8 *)vs1;
+    const U8 *b = (const U8 *)vs2;
+    int tmp;

 
     PERL_ARGS_ASSERT_MY_MEMCMP;
 
 
     PERL_ARGS_ASSERT_MY_MEMCMP;
 

-    assert(len >= 0);
-

     while (len--) {
         if ((tmp = *a++ - *b++))
            return tmp;
     while (len--) {
         if ((tmp = *a++ - *b++))
            return tmp;


@@ -2329,7 +2360,7 @@ vsprintf(char *dest, const char *pat, void *args)
 PerlIO *
 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
 {
 PerlIO *
 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
 {

-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)

     int p[2];
     I32 This, that;
     Pid_t pid;
     int p[2];
     I32 This, that;
     Pid_t pid;


@@ -2373,7 +2404,7 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
        /* Close parent's end of error status pipe (if any) */
        if (did_pipes) {
            PerlLIO_close(pp[0]);
        /* Close parent's end of error status pipe (if any) */
        if (did_pipes) {
            PerlLIO_close(pp[0]);

-#if defined(HAS_FCNTL) && defined(F_SETFD)
+#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;
            /* Close error pipe automatically if exec works */
            if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
                 return NULL;


@@ -2428,10 +2459,9 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
     if (did_pipes && pid > 0) {
        int errkid;
        unsigned n = 0;
     if (did_pipes && pid > 0) {
        int errkid;
        unsigned n = 0;

-       SSize_t n1;

 
        while (n < sizeof(int)) {
 
        while (n < sizeof(int)) {

-           n1 = PerlLIO_read(pp[0],
+            const SSize_t n1 = PerlLIO_read(pp[0],

                              (void*)(((char*)&errkid)+n),
                              (sizeof(int)) - n);
            if (n1 <= 0)
                              (void*)(((char*)&errkid)+n),
                              (sizeof(int)) - n);
            if (n1 <= 0)


@@ -2467,8 +2497,8 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
 #endif
 }
 
 #endif
 }
 

-    /* VMS' my_popen() is in VMS.c, same with OS/2. */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
+    /* VMS' my_popen() is in VMS.c, same with OS/2 and AmigaOS 4. */
+#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)

 PerlIO *
 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 {
 PerlIO *
 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 {


@@ -2586,10 +2616,9 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
     if (did_pipes && pid > 0) {
        int errkid;
        unsigned n = 0;
     if (did_pipes && pid > 0) {
        int errkid;
        unsigned n = 0;

-       SSize_t n1;

 
        while (n < sizeof(int)) {
 
        while (n < sizeof(int)) {

-           n1 = PerlLIO_read(pp[0],
+            const SSize_t n1 = PerlLIO_read(pp[0],

                              (void*)(((char*)&errkid)+n),
                              (sizeof(int)) - n);
            if (n1 <= 0)
                              (void*)(((char*)&errkid)+n),
                              (sizeof(int)) - n);
            if (n1 <= 0)


@@ -2642,6 +2671,15 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 /* this is called in parent before the fork() */
 void
 Perl_atfork_lock(void)
 /* this is called in parent before the fork() */
 void
 Perl_atfork_lock(void)

+#if defined(USE_ITHREADS)
+#  ifdef USE_PERLIO
+  PERL_TSA_ACQUIRE(PL_perlio_mutex)
+#  endif
+#  ifdef MYMALLOC
+  PERL_TSA_ACQUIRE(PL_malloc_mutex)
+#  endif
+  PERL_TSA_ACQUIRE(PL_op_mutex)
+#endif

 {
 #if defined(USE_ITHREADS)
     dVAR;
 {
 #if defined(USE_ITHREADS)
     dVAR;


@@ -2659,6 +2697,15 @@ Perl_atfork_lock(void)
 /* this is called in both parent and child after the fork() */
 void
 Perl_atfork_unlock(void)
 /* this is called in both parent and child after the fork() */
 void
 Perl_atfork_unlock(void)

+#if defined(USE_ITHREADS)
+#  ifdef USE_PERLIO
+  PERL_TSA_RELEASE(PL_perlio_mutex)
+#  endif
+#  ifdef MYMALLOC
+  PERL_TSA_RELEASE(PL_malloc_mutex)
+#  endif
+  PERL_TSA_RELEASE(PL_op_mutex)
+#endif

 {
 #if defined(USE_ITHREADS)
     dVAR;
 {
 #if defined(USE_ITHREADS)
     dVAR;


@@ -2688,6 +2735,8 @@ Perl_my_fork(void)
     pid = fork();
 #endif
     return pid;
     pid = fork();
 #endif
     return pid;

+#elif defined(__amigaos4__)
+    return amigaos_fork();

 #else
     /* this "canna happen" since nothing should be calling here if !HAS_FORK */
     Perl_croak_nocontext("fork() not available");
 #else
     /* this "canna happen" since nothing should be calling here if !HAS_FORK */
     Perl_croak_nocontext("fork() not available");


@@ -2887,7 +2936,7 @@ Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
 #endif /* !PERL_MICRO */
 
     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
 #endif /* !PERL_MICRO */
 
     /* VMS' my_pclose() is in VMS.c; same with OS/2 */

-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)

 I32
 Perl_my_pclose(pTHX_ PerlIO *ptr)
 {
 I32
 Perl_my_pclose(pTHX_ PerlIO *ptr)
 {


@@ -3233,6 +3282,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
        while (deftypes ||
               (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
        {
        while (deftypes ||
               (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
        {

+           Stat_t statbuf;

            if (deftypes) {
                deftypes = 0;
                *tmpbuf = '\0';
            if (deftypes) {
                deftypes = 0;
                *tmpbuf = '\0';


@@ -3259,13 +3309,16 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
 #endif
            DEBUG_p(PerlIO_printf(Perl_debug_log,
                                  "Looking for %s\n",cur));
 #endif
            DEBUG_p(PerlIO_printf(Perl_debug_log,
                                  "Looking for %s\n",cur));

-           if (PerlLIO_stat(cur,&PL_statbuf) >= 0
-               && !S_ISDIR(PL_statbuf.st_mode)) {
-               dosearch = 0;
-               scriptname = cur;
+           {
+               Stat_t statbuf;
+               if (PerlLIO_stat(cur,&statbuf) >= 0
+                   && !S_ISDIR(statbuf.st_mode)) {
+                   dosearch = 0;
+                   scriptname = cur;

 #ifdef SEARCH_EXTS
 #ifdef SEARCH_EXTS

-               break;
+                   break;

 #endif
 #endif

+               }

            }
 #ifdef SEARCH_EXTS
            if (cur == scriptname) {
            }
 #ifdef SEARCH_EXTS
            if (cur == scriptname) {


@@ -3291,6 +3344,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
 
        bufend = s + strlen(s);
        while (s < bufend) {
 
        bufend = s + strlen(s);
        while (s < bufend) {

+           Stat_t statbuf;

 #  ifdef DOSISH
            for (len = 0; *s
                    && *s != ';'; len++, s++) {
 #  ifdef DOSISH
            for (len = 0; *s
                    && *s != ';'; len++, s++) {


@@ -3300,9 +3354,8 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
            if (len < sizeof tmpbuf)
                tmpbuf[len] = '\0';
 #  else
            if (len < sizeof tmpbuf)
                tmpbuf[len] = '\0';
 #  else

-           s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
-                       ':',
-                       &len);
+           s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
+                                   ':', &len);

 #  endif
            if (s < bufend)
                s++;
 #  endif
            if (s < bufend)
                s++;


@@ -3327,8 +3380,8 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
            do {
 #endif
                DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
            do {
 #endif
                DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));

-               retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
-               if (S_ISDIR(PL_statbuf.st_mode)) {
+               retval = PerlLIO_stat(tmpbuf,&statbuf);
+               if (S_ISDIR(statbuf.st_mode)) {

                    retval = -1;
                }
 #ifdef SEARCH_EXTS
                    retval = -1;
                }
 #ifdef SEARCH_EXTS


@@ -3339,10 +3392,10 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
 #endif
            if (retval < 0)
                continue;
 #endif
            if (retval < 0)
                continue;

-           if (S_ISREG(PL_statbuf.st_mode)
-               && cando(S_IRUSR,TRUE,&PL_statbuf)
+           if (S_ISREG(statbuf.st_mode)
+               && cando(S_IRUSR,TRUE,&statbuf)

 #if !defined(DOSISH)
 #if !defined(DOSISH)

-               && cando(S_IXUSR,TRUE,&PL_statbuf)
+               && cando(S_IXUSR,TRUE,&statbuf)

 #endif
                )
            {
 #endif
                )
            {


@@ -3353,11 +3406,16 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
                xfailed = savepv(tmpbuf);
        }
 #ifndef DOSISH
                xfailed = savepv(tmpbuf);
        }
 #ifndef DOSISH

-       if (!xfound && !seen_dot && !xfailed &&
-           (PerlLIO_stat(scriptname,&PL_statbuf) < 0
-            || S_ISDIR(PL_statbuf.st_mode)))
+       {
+           Stat_t statbuf;
+           if (!xfound && !seen_dot && !xfailed &&
+               (PerlLIO_stat(scriptname,&statbuf) < 0
+                || S_ISDIR(statbuf.st_mode)))
+#endif
+               seen_dot = 1;                   /* Disable message. */
+#ifndef DOSISH
+       }

 #endif
 #endif

-           seen_dot = 1;                       /* Disable message. */

        if (!xfound) {
            if (flags & 1) {                    /* do or die? */
                /* diag_listed_as: Can't execute %s */
        if (!xfound) {
            if (flags & 1) {                    /* do or die? */
                /* diag_listed_as: Can't execute %s */


@@ -3554,7 +3612,7 @@ Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
 
        if (name && HEK_LEN(name))
            Perl_warner(aTHX_ packWARN(WARN_IO),
 
        if (name && HEK_LEN(name))
            Perl_warner(aTHX_ packWARN(WARN_IO),

-                       "Filehandle %"HEKf" opened only for %sput",
+                       "Filehandle %" HEKf " opened only for %sput",

                        HEKfARG(name), direction);
        else
            Perl_warner(aTHX_ packWARN(WARN_IO),
                        HEKfARG(name), direction);
        else
            Perl_warner(aTHX_ packWARN(WARN_IO),


@@ -3597,13 +3655,13 @@ Perl_report_evil_fh(pTHX_ const GV *gv)
             ? "socket" : "filehandle");
        const bool have_name = name && SvCUR(name);
        Perl_warner(aTHX_ packWARN(warn_type),
             ? "socket" : "filehandle");
        const bool have_name = name && SvCUR(name);
        Perl_warner(aTHX_ packWARN(warn_type),

-                  "%s%s on %s %s%s%"SVf, func, pars, vile, type,
+                  "%s%s on %s %s%s%" SVf, func, pars, vile, type,

                    have_name ? " " : "",
                    SVfARG(have_name ? name : &PL_sv_no));
        if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
                Perl_warner(
                            aTHX_ packWARN(warn_type),
                    have_name ? " " : "",
                    SVfARG(have_name ? name : &PL_sv_no));
        if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
                Perl_warner(
                            aTHX_ packWARN(warn_type),

-                       "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
+                       "\t(Are you trying to call %s%s on dirhandle%s%" SVf "?)\n",

                        func, pars, have_name ? " " : "",
                        SVfARG(have_name ? name : &PL_sv_no)
                            );
                        func, pars, have_name ? " " : "",
                        SVfARG(have_name ? name : &PL_sv_no)
                            );


@@ -3737,6 +3795,8 @@ Perl_mini_mktime(struct tm *ptm)
  * This algorithm also fails to handle years before A.D. 1 gracefully, but
  * that's still outside the scope for POSIX time manipulation, so I don't
  * care.
  * This algorithm also fails to handle years before A.D. 1 gracefully, but
  * that's still outside the scope for POSIX time manipulation, so I don't
  * care.

+ *
+ * - lwall

  */
 
     year = 1900 + ptm->tm_year;
  */
 
     year = 1900 + ptm->tm_year;


@@ -3845,7 +3905,13 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in
 {
 #ifdef HAS_STRFTIME
 
 {
 #ifdef HAS_STRFTIME
 

-  /* Note that yday and wday effectively are ignored by this function, as mini_mktime() overwrites them */
+  /* strftime(), but with a different API so that the return value is a pointer
+   * to the formatted result (which MUST be arranged to be FREED BY THE
+   * CALLER).  This allows this function to increase the buffer size as needed,
+   * so that the caller doesn't have to worry about that.
+   *
+   * Note that yday and wday effectively are ignored by this function, as
+   * mini_mktime() overwrites them */

 
   char *buf;
   int buflen;
 
   char *buf;
   int buflen;


@@ -3935,8 +4001,8 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in
 
 
 #define SV_CWD_RETURN_UNDEF \
 
 
 #define SV_CWD_RETURN_UNDEF \

-sv_setsv(sv, &PL_sv_undef); \
-return FALSE
+    sv_set_undef(sv); \
+    return FALSE

 
 #define SV_CWD_ISDOT(dp) \
     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
 
 #define SV_CWD_ISDOT(dp) \
     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \


@@ -3947,7 +4013,7 @@ return FALSE
 
 =for apidoc getcwd_sv
 
 
 =for apidoc getcwd_sv
 

-Fill the sv with current working directory
+Fill C<sv> with current working directory

 
 =cut
 */
 
 =cut
 */


@@ -3980,8 +4046,7 @@ Perl_getcwd_sv(pTHX_ SV *sv)
            return TRUE;
        }
        else {
            return TRUE;
        }
        else {

-           sv_setsv(sv, &PL_sv_undef);
-           return FALSE;
+           SV_CWD_RETURN_UNDEF;

        }
     }
 
        }
     }
 


@@ -4378,7 +4443,7 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
 Dummy routine which "shares" an SV when there is no sharing module present.
 Or "locks" it.  Or "unlocks" it.  In other
 words, ignores its single SV argument.
 Dummy routine which "shares" an SV when there is no sharing module present.
 Or "locks" it.  Or "unlocks" it.  In other
 words, ignores its single SV argument.

-Exists to avoid test for a NULL function pointer and because it could
+Exists to avoid test for a C<NULL> function pointer and because it could

 potentially warn under some level of strict-ness.
 
 =cut
 potentially warn under some level of strict-ness.
 
 =cut


@@ -4397,7 +4462,7 @@ Perl_sv_nosharing(pTHX_ SV *sv)
 
 Dummy routine which reports that object can be destroyed when there is no
 sharing module present.  It ignores its single SV argument, and returns
 
 Dummy routine which reports that object can be destroyed when there is no
 sharing module present.  It ignores its single SV argument, and returns

-'true'.  Exists to avoid test for a NULL function pointer and because it
+'true'.  Exists to avoid test for a C<NULL> function pointer and because it

 could potentially warn under some level of strict-ness.
 
 =cut
 could potentially warn under some level of strict-ness.
 
 =cut


@@ -4433,6 +4498,9 @@ Perl_parse_unicode_opts(pTHX_ const char **popt)
                         Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
                 }
             }
                         Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
                 }
             }

+            else {
+                Perl_croak(aTHX_ "Invalid number '%s' for -C option.\n", p);
+            }

         }
         else {
            for (; *p; p++) {
         }
         else {
            for (; *p; p++) {


@@ -4474,7 +4542,7 @@ Perl_parse_unicode_opts(pTHX_ const char **popt)
   the_end_of_the_opts_parser:
 
   if (opt & ~PERL_UNICODE_ALL_FLAGS)
   the_end_of_the_opts_parser:
 
   if (opt & ~PERL_UNICODE_ALL_FLAGS)

-       Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
+       Perl_croak(aTHX_ "Unknown Unicode option value %" UVuf,

                  (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
 
   *popt = p;
                  (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
 
   *popt = p;


@@ -4528,7 +4596,11 @@ Perl_seed(pTHX)
     * if there isn't enough entropy available.  You can compile with
     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
     * is enough real entropy to fill the seed. */
     * if there isn't enough entropy available.  You can compile with
     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
     * is enough real entropy to fill the seed. */

-#  define PERL_RANDOM_DEVICE "/dev/urandom"
+#  ifdef __amigaos4__
+#    define PERL_RANDOM_DEVICE "RANDOM:SIZE=4"
+#  else
+#    define PERL_RANDOM_DEVICE "/dev/urandom"
+#  endif

 #endif
     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
     if (fd != -1) {
 #endif
     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
     if (fd != -1) {


@@ -4558,20 +4630,22 @@ Perl_seed(pTHX)
 void
 Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
 {
 void
 Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
 {

+#ifndef NO_PERL_HASH_ENV

     const char *env_pv;
     const char *env_pv;

+#endif

     unsigned long i;
 
     PERL_ARGS_ASSERT_GET_HASH_SEED;
 
     unsigned long i;
 
     PERL_ARGS_ASSERT_GET_HASH_SEED;
 

+#ifndef NO_PERL_HASH_ENV

     env_pv= PerlEnv_getenv("PERL_HASH_SEED");
 
     if ( env_pv )
     env_pv= PerlEnv_getenv("PERL_HASH_SEED");
 
     if ( env_pv )

-#ifndef USE_HASH_SEED_EXPLICIT

     {
         /* ignore leading spaces */
         while (isSPACE(*env_pv))
             env_pv++;
     {
         /* ignore leading spaces */
         while (isSPACE(*env_pv))
             env_pv++;

-#ifdef USE_PERL_PERTURB_KEYS
+#    ifdef USE_PERL_PERTURB_KEYS

         /* if they set it to "0" we disable key traversal randomization completely */
         if (strEQ(env_pv,"0")) {
             PL_hash_rand_bits_enabled= 0;
         /* if they set it to "0" we disable key traversal randomization completely */
         if (strEQ(env_pv,"0")) {
             PL_hash_rand_bits_enabled= 0;


@@ -4579,7 +4653,7 @@ Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
             /* otherwise switch to deterministic mode */
             PL_hash_rand_bits_enabled= 2;
         }
             /* otherwise switch to deterministic mode */
             PL_hash_rand_bits_enabled= 2;
         }

-#endif
+#    endif

         /* ignore a leading 0x... if it is there */
         if (env_pv[0] == '0' && env_pv[1] == 'x')
             env_pv += 2;
         /* ignore a leading 0x... if it is there */
         if (env_pv[0] == '0' && env_pv[1] == 'x')
             env_pv += 2;


@@ -4601,12 +4675,10 @@ Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
         /* should we warn about insufficient hex? */
     }
     else
         /* should we warn about insufficient hex? */
     }
     else

-#endif
+#endif /* NO_PERL_HASH_ENV */

     {
     {

-        (void)seedDrand01((Rand_seed_t)seed());
-

         for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
         for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {

-            seed_buffer[i] = (unsigned char)(Drand01() * (U8_MAX+1));
+            seed_buffer[i] = (unsigned char)(Perl_internal_drand48() * (U8_MAX+1));

         }
     }
 #ifdef USE_PERL_PERTURB_KEYS
         }
     }
 #ifdef USE_PERL_PERTURB_KEYS


@@ -4620,6 +4692,7 @@ Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
             PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
         }
     }
             PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
         }
     }

+#  ifndef NO_PERL_HASH_ENV

     env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
     if (env_pv) {
         if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
     env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
     if (env_pv) {
         if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {


@@ -4632,6 +4705,7 @@ Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
             Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
         }
     }
             Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
         }
     }

+#  endif

 #endif
 }
 
 #endif
 }
 


@@ -4794,7 +4868,7 @@ S_mem_log_common(enum mem_log_type mlt, const UV n,
         (void)time(&when);
 #   endif
        /* If there are other OS specific ways of hires time than
         (void)time(&when);
 #   endif
        /* If there are other OS specific ways of hires time than

-        * gettimeofday() (see ext/Time-HiRes), the easiest way is
+        * gettimeofday() (see dist/Time-HiRes), the easiest way is

         * probably that they would be used to fill in the struct
         * timeval. */
        {
         * probably that they would be used to fill in the struct
         * timeval. */
        {


@@ -4818,29 +4892,29 @@ S_mem_log_common(enum mem_log_type mlt, const UV n,
            switch (mlt) {
            case MLT_ALLOC:
                len = my_snprintf(buf, sizeof(buf),
            switch (mlt) {
            case MLT_ALLOC:
                len = my_snprintf(buf, sizeof(buf),

-                       "alloc: %s:%d:%s: %"IVdf" %"UVuf
-                       " %s = %"IVdf": %"UVxf"\n",
+                       "alloc: %s:%d:%s: %" IVdf " %" UVuf
+                       " %s = %" IVdf ": %" UVxf "\n",

                        filename, linenumber, funcname, n, typesize,
                        type_name, n * typesize, PTR2UV(newalloc));
                break;
            case MLT_REALLOC:
                len = my_snprintf(buf, sizeof(buf),
                        filename, linenumber, funcname, n, typesize,
                        type_name, n * typesize, PTR2UV(newalloc));
                break;
            case MLT_REALLOC:
                len = my_snprintf(buf, sizeof(buf),

-                       "realloc: %s:%d:%s: %"IVdf" %"UVuf
-                       " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
+                       "realloc: %s:%d:%s: %" IVdf " %" UVuf
+                       " %s = %" IVdf ": %" UVxf " -> %" UVxf "\n",

                        filename, linenumber, funcname, n, typesize,
                        type_name, n * typesize, PTR2UV(oldalloc),
                        PTR2UV(newalloc));
                break;
            case MLT_FREE:
                len = my_snprintf(buf, sizeof(buf),
                        filename, linenumber, funcname, n, typesize,
                        type_name, n * typesize, PTR2UV(oldalloc),
                        PTR2UV(newalloc));
                break;
            case MLT_FREE:
                len = my_snprintf(buf, sizeof(buf),

-                       "free: %s:%d:%s: %"UVxf"\n",
+                       "free: %s:%d:%s: %" UVxf "\n",

                        filename, linenumber, funcname,
                        PTR2UV(oldalloc));
                break;
            case MLT_NEW_SV:
            case MLT_DEL_SV:
                len = my_snprintf(buf, sizeof(buf),
                        filename, linenumber, funcname,
                        PTR2UV(oldalloc));
                break;
            case MLT_NEW_SV:
            case MLT_DEL_SV:
                len = my_snprintf(buf, sizeof(buf),

-                       "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
+                       "%s_SV: %s:%d:%s: %" UVxf SV_LOG_SERIAL_FMT "\n",

                        mlt == MLT_NEW_SV ? "new" : "del",
                        filename, linenumber, funcname,
                        PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
                        mlt == MLT_NEW_SV ? "new" : "del",
                        filename, linenumber, funcname,
                        PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));


@@ -4873,6 +4947,8 @@ Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
                   const char *filename, const int linenumber,
                   const char *funcname)
 {
                   const char *filename, const int linenumber,
                   const char *funcname)
 {

+    PERL_ARGS_ASSERT_MEM_LOG_ALLOC;
+

     mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
                      NULL, NULL, newalloc,
                      filename, linenumber, funcname);
     mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
                      NULL, NULL, newalloc,
                      filename, linenumber, funcname);


@@ -4885,6 +4961,8 @@ Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
                     const char *filename, const int linenumber, 
                     const char *funcname)
 {
                     const char *filename, const int linenumber, 
                     const char *funcname)
 {

+    PERL_ARGS_ASSERT_MEM_LOG_REALLOC;
+

     mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
                      NULL, oldalloc, newalloc, 
                      filename, linenumber, funcname);
     mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
                      NULL, oldalloc, newalloc, 
                      filename, linenumber, funcname);


@@ -4896,6 +4974,8 @@ Perl_mem_log_free(Malloc_t oldalloc,
                  const char *filename, const int linenumber, 
                  const char *funcname)
 {
                  const char *filename, const int linenumber, 
                  const char *funcname)
 {

+    PERL_ARGS_ASSERT_MEM_LOG_FREE;
+

     mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, 
                      filename, linenumber, funcname);
     return oldalloc;
     mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, 
                      filename, linenumber, funcname);
     return oldalloc;


@@ -4946,18 +5026,18 @@ Perl_my_sprintf(char *buffer, const char* pat, ...)
 /*
 =for apidoc quadmath_format_single
 
 /*
 =for apidoc quadmath_format_single
 

-quadmath_snprintf() is very strict about its format string and will
-fail, returning -1, if the format is invalid.  It acccepts exactly
+C<quadmath_snprintf()> is very strict about its C<format> string and will
+fail, returning -1, if the format is invalid.  It accepts exactly

 one format spec.
 
 one format spec.
 

-quadmath_format_single() checks that the intended single spec looks
+C<quadmath_format_single()> checks that the intended single spec looks

 sane: begins with C<%>, has only one C<%>, ends with C<[efgaEFGA]>,
 and has C<Q> before it.  This is not a full "printf syntax check",
 just the basics.
 
 Returns the format if it is valid, NULL if not.
 
 sane: begins with C<%>, has only one C<%>, ends with C<[efgaEFGA]>,
 and has C<Q> before it.  This is not a full "printf syntax check",
 just the basics.
 
 Returns the format if it is valid, NULL if not.
 

-quadmath_format_single() can and will actually patch in the missing
+C<quadmath_format_single()> can and will actually patch in the missing

 C<Q>, if necessary.  In this case it will return the modified copy of
 the format, B<which the caller will need to free.>
 
 C<Q>, if necessary.  In this case it will return the modified copy of
 the format, B<which the caller will need to free.>
 


@@ -4995,18 +5075,18 @@ Perl_quadmath_format_single(const char* format)
 /*
 =for apidoc quadmath_format_needed
 
 /*
 =for apidoc quadmath_format_needed
 

-quadmath_format_needed() returns true if the format string seems to
-contain at least one non-Q-prefixed %[efgaEFGA] format specifier,
+C<quadmath_format_needed()> returns true if the C<format> string seems to
+contain at least one non-Q-prefixed C<%[efgaEFGA]> format specifier,

 or returns false otherwise.
 
 The format specifier detection is not complete printf-syntax detection,
 but it should catch most common cases.
 
 If true is returned, those arguments B<should> in theory be processed
 or returns false otherwise.
 
 The format specifier detection is not complete printf-syntax detection,
 but it should catch most common cases.
 
 If true is returned, those arguments B<should> in theory be processed

-with quadmath_snprintf(), but in case there is more than one such
+with C<quadmath_snprintf()>, but in case there is more than one such

 format specifier (see L</quadmath_format_single>), and if there is
 anything else beyond that one (even just a single byte), they
 format specifier (see L</quadmath_format_single>), and if there is
 anything else beyond that one (even just a single byte), they

-B<cannot> be processed because quadmath_snprintf() is very strict,
+B<cannot> be processed because C<quadmath_snprintf()> is very strict,

 accepting only one format spec, and nothing else.
 In this case, the code should probably fail.
 
 accepting only one format spec, and nothing else.
 In this case, the code should probably fail.
 


@@ -5078,8 +5158,13 @@ Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
         if (qfmt) {
             /* If the format looked promising, use it as quadmath. */
             retval = quadmath_snprintf(buffer, len, qfmt, va_arg(ap, NV));
         if (qfmt) {
             /* If the format looked promising, use it as quadmath. */
             retval = quadmath_snprintf(buffer, len, qfmt, va_arg(ap, NV));

-            if (retval == -1)
+            if (retval == -1) {
+                if (qfmt != format) {
+                    dTHX;
+                    SAVEFREEPV(qfmt);
+                }

                 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
                 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);

+            }

             quadmath_valid = TRUE;
             if (qfmt != format)
                 Safefree(qfmt);
             quadmath_valid = TRUE;
             if (qfmt != format)
                 Safefree(qfmt);


@@ -5149,7 +5234,8 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap
     PERL_UNUSED_ARG(buffer);
     PERL_UNUSED_ARG(len);
     PERL_UNUSED_ARG(format);
     PERL_UNUSED_ARG(buffer);
     PERL_UNUSED_ARG(len);
     PERL_UNUSED_ARG(format);

-    PERL_UNUSED_ARG(ap);
+    /* the cast is to avoid gcc -Wsizeof-array-argument complaining */
+    PERL_UNUSED_ARG((void*)ap);

     Perl_croak_nocontext("panic: my_vsnprintf not available with quadmath");
     return 0;
 #else
     Perl_croak_nocontext("panic: my_vsnprintf not available with quadmath");
     return 0;
 #else


@@ -5158,13 +5244,11 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap
     va_list apc;
 
     PERL_ARGS_ASSERT_MY_VSNPRINTF;
     va_list apc;
 
     PERL_ARGS_ASSERT_MY_VSNPRINTF;

-#ifndef HAS_VSNPRINTF
-    PERL_UNUSED_VAR(len);
-#endif

     Perl_va_copy(ap, apc);
 # ifdef HAS_VSNPRINTF
     retval = vsnprintf(buffer, len, format, apc);
 # else
     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);
     retval = vsprintf(buffer, format, apc);
 # endif
     va_end(apc);


@@ -5172,6 +5256,7 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap
 # ifdef HAS_VSNPRINTF
     retval = vsnprintf(buffer, len, format, ap);
 # 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 */
     retval = vsprintf(buffer, format, ap);
 # endif
 #endif /* #ifdef NEED_VA_COPY */


@@ -5260,21 +5345,19 @@ Perl_my_cxt_init(pTHX_ int *index, size_t size)
     PERL_ARGS_ASSERT_MY_CXT_INIT;
     if (*index == -1) {
        /* this module hasn't been allocated an index yet */
     PERL_ARGS_ASSERT_MY_CXT_INIT;
     if (*index == -1) {
        /* this module hasn't been allocated an index yet */

-#if defined(USE_ITHREADS)

        MUTEX_LOCK(&PL_my_ctx_mutex);
        MUTEX_LOCK(&PL_my_ctx_mutex);

-#endif

        *index = PL_my_cxt_index++;
        *index = PL_my_cxt_index++;

-#if defined(USE_ITHREADS)

        MUTEX_UNLOCK(&PL_my_ctx_mutex);
        MUTEX_UNLOCK(&PL_my_ctx_mutex);

-#endif

     }
     
     /* make sure the array is big enough */
     if (PL_my_cxt_size <= *index) {
        if (PL_my_cxt_size) {
     }
     
     /* make sure the array is big enough */
     if (PL_my_cxt_size <= *index) {
        if (PL_my_cxt_size) {

-           while (PL_my_cxt_size <= *index)
-               PL_my_cxt_size *= 2;
-           Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
+            IV new_size = PL_my_cxt_size;
+           while (new_size <= *index)
+               new_size *= 2;
+           Renew(PL_my_cxt_list, new_size, void *);
+            PL_my_cxt_size = new_size;

        }
        else {
            PL_my_cxt_size = 16;
        }
        else {
            PL_my_cxt_size = 16;


@@ -5321,13 +5404,9 @@ 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 */
     index = Perl_my_cxt_index(aTHX_ my_cxt_key);
     if (index == -1) {
        /* this module hasn't been allocated an index yet */

-#if defined(USE_ITHREADS)

        MUTEX_LOCK(&PL_my_ctx_mutex);
        MUTEX_LOCK(&PL_my_ctx_mutex);

-#endif

        index = PL_my_cxt_index++;
        index = PL_my_cxt_index++;

-#if defined(USE_ITHREADS)

        MUTEX_UNLOCK(&PL_my_ctx_mutex);
        MUTEX_UNLOCK(&PL_my_ctx_mutex);

-#endif

     }
 
     /* make sure the array is big enough */
     }
 
     /* make sure the array is big enough */


@@ -5335,10 +5414,12 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
        int old_size = PL_my_cxt_size;
        int i;
        if (PL_my_cxt_size) {
        int old_size = PL_my_cxt_size;
        int i;
        if (PL_my_cxt_size) {

-           while (PL_my_cxt_size <= index)
-               PL_my_cxt_size *= 2;
-           Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
-           Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
+            IV new_size = PL_my_cxt_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;
        }
        else {
            PL_my_cxt_size = 16;


@@ -5452,7 +5533,9 @@ Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...)
        SAVEPPTR(PL_xsubfilename);/* which was require'd from a XSUB BEGIN */
        PL_xsubfilename = file;   /* so the old name must be restored for
                                     additional XSUBs to register themselves */
        SAVEPPTR(PL_xsubfilename);/* which was require'd from a XSUB BEGIN */
        PL_xsubfilename = file;   /* so the old name must be restored for
                                     additional XSUBs to register themselves */

-       (void)gv_fetchfile(file);
+       /* XSUBs can't be perl lang/perl5db.pl debugged
+       if (PERLDB_LINE_OR_SAVESRC)
+           (void)gv_fetchfile(file); */

     }
 
     if(key & HSf_POPMARK) {
     }
 
     if(key & HSf_POPMARK) {


@@ -5474,7 +5557,7 @@ Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...)
            if(apiverlen != sizeof("v" PERL_API_VERSION_STRING)-1
                || memNE(api_p, "v" PERL_API_VERSION_STRING,
                         sizeof("v" PERL_API_VERSION_STRING)-1))
            if(apiverlen != sizeof("v" PERL_API_VERSION_STRING)-1
                || memNE(api_p, "v" PERL_API_VERSION_STRING,
                         sizeof("v" PERL_API_VERSION_STRING)-1))

-               Perl_croak_nocontext("Perl API version %s of %"SVf" does not match %s",
+               Perl_croak_nocontext("Perl API version %s of %" SVf " does not match %s",

                                    api_p, SVfARG(PL_stack_base[ax + 0]),
                                    "v" PERL_API_VERSION_STRING);
        }
                                    api_p, SVfARG(PL_stack_base[ax + 0]),
                                    "v" PERL_API_VERSION_STRING);
        }


@@ -5506,10 +5589,10 @@ S_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
     else {
        /* XXX GV_ADDWARN */
        vn = "XS_VERSION";
     else {
        /* XXX GV_ADDWARN */
        vn = "XS_VERSION";

-       sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", SVfARG(module), vn), 0);
+       sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0);

        if (!sv || !SvOK(sv)) {
            vn = "VERSION";
        if (!sv || !SvOK(sv)) {
            vn = "VERSION";

-           sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", SVfARG(module), vn), 0);
+           sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0);

        }
     }
     if (sv) {
        }
     }
     if (sv) {


@@ -5519,17 +5602,17 @@ S_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
        xssv = upg_version(xssv, 0);
        if ( vcmp(pmsv,xssv) ) {
            SV *string = vstringify(xssv);
        xssv = upg_version(xssv, 0);
        if ( vcmp(pmsv,xssv) ) {
            SV *string = vstringify(xssv);

-           SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
+           SV *xpt = Perl_newSVpvf(aTHX_ "%" SVf " object version %" SVf

                                    " does not match ", SVfARG(module), SVfARG(string));
 
            SvREFCNT_dec(string);
            string = vstringify(pmsv);
 
            if (vn) {
                                    " does not match ", SVfARG(module), SVfARG(string));
 
            SvREFCNT_dec(string);
            string = vstringify(pmsv);
 
            if (vn) {

-               Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, SVfARG(module), vn,
+               Perl_sv_catpvf(aTHX_ xpt, "$%" SVf "::%s %" SVf, SVfARG(module), vn,

                               SVfARG(string));
            } else {
                               SVfARG(string));
            } else {

-               Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, SVfARG(string));
+               Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %" SVf, SVfARG(string));

            }
            SvREFCNT_dec(string);
 
            }
            SvREFCNT_dec(string);
 


@@ -5555,9 +5638,13 @@ 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 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
 
 =cut
 

-Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcat
+Description stolen from http://man.openbsd.org/strlcat.3

 */
 #ifndef HAS_STRLCAT
 Size_t
 */
 #ifndef HAS_STRLCAT
 Size_t


@@ -5586,9 +5673,12 @@ This operates on C C<NUL>-terminated strings.
 C<my_strlcpy()> copies up to S<C<size - 1>> characters from the string C<src>
 to C<dst>, C<NUL>-terminating the result if C<size> is not 0.
 
 C<my_strlcpy()> copies up to S<C<size - 1>> characters 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
 
 =cut
 

-Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcpy
+Description stolen from http://man.openbsd.org/strlcpy.3

 */
 #ifndef HAS_STRLCPY
 Size_t
 */
 #ifndef HAS_STRLCPY
 Size_t


@@ -5699,6 +5789,40 @@ Perl_my_dirfd(DIR * dir) {
 #endif 
 }
 
 #endif 
 }
 

+#ifndef HAS_MKSTEMP
+
+#define TEMP_FILE_CH "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvxyz0123456789"
+#define TEMP_FILE_CH_COUNT (sizeof(TEMP_FILE_CH)-1)
+
+int
+Perl_my_mkstemp(char *templte) {
+    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;
+        return -1;
+    }
+
+    do {
+        int i;
+        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);
+    } while (fd == -1 && errno == EEXIST && ++attempts <= 100);
+
+    return fd;
+}
+
+#endif
+

 REGEXP *
 Perl_get_re_arg(pTHX_ SV *sv) {
 
 REGEXP *
 Perl_get_re_arg(pTHX_ SV *sv) {
 


@@ -6012,17 +6136,17 @@ static const char* atos_parse(const char* p,
     UV uv;
 
     /* Skip trailing whitespace. */
     UV uv;
 
     /* Skip trailing whitespace. */

-    while (p > start && isspace(*p)) p--;
+    while (p > start && isSPACE(*p)) p--;

     /* Now we should be at the close paren. */
     if (p == start || *p != ')')
         return NULL;
     close_paren = p;
     p--;
     /* Now we should be in the line number. */
     /* Now we should be at the close paren. */
     if (p == start || *p != ')')
         return NULL;
     close_paren = p;
     p--;
     /* Now we should be in the line number. */

-    if (p == start || !isdigit(*p))
+    if (p == start || !isDIGIT(*p))

         return NULL;
     /* Skip over the digits. */
         return NULL;
     /* Skip over the digits. */

-    while (p > start && isdigit(*p))
+    while (p > start && isDIGIT(*p))

         p--;
     /* Now we should be at the colon. */
     if (p == start || *p != ':')
         p--;
     /* Now we should be at the colon. */
     if (p == start || *p != ':')


@@ -6039,7 +6163,7 @@ static const char* atos_parse(const char* p,
     *source_name_size = source_name_end - p;
     if (grok_atoUV(source_number_start, &uv,  &source_line_end)
         && source_line_end == close_paren
     *source_name_size = source_name_end - p;
     if (grok_atoUV(source_number_start, &uv,  &source_line_end)
         && source_line_end == close_paren

-        && uv <= MAX_STRLEN
+        && uv <= PERL_INT_MAX

     ) {
         *source_line = (STRLEN)uv;
         return p;
     ) {
         *source_line = (STRLEN)uv;
         return p;


@@ -6067,7 +6191,7 @@ static void atos_symbolize(atos_context* ctx,
      * the object name (used as "-o '%s'" ), leave since at least
      * partially the user controls it. */
     for (p = ctx->fname; *p; p++) {
      * the object name (used as "-o '%s'" ), leave since at least
      * partially the user controls it. */
     for (p = ctx->fname; *p; p++) {

-        if (*p == '\'' || iscntrl(*p)) {
+        if (*p == '\'' || isCNTRL(*p)) {

             ctx->unavail = TRUE;
             return;
         }
             ctx->unavail = TRUE;
             return;
         }


@@ -6106,14 +6230,14 @@ static void atos_symbolize(atos_context* ctx,
             char out[1024];
             UV cnt = fread(out, 1, sizeof(out), fp);
             if (cnt < sizeof(out)) {
             char out[1024];
             UV cnt = fread(out, 1, sizeof(out), fp);
             if (cnt < sizeof(out)) {

-                const char* p = atos_parse(out + cnt, out,
+                const char* p = atos_parse(out + cnt - 1, out,

                                            source_name_size,
                                            source_line);
                 if (p) {
                     Newx(*source_name,
                                            source_name_size,
                                            source_line);
                 if (p) {
                     Newx(*source_name,

-                         *source_name_size + 1, char);
+                         *source_name_size, char);

                     Copy(p, *source_name,
                     Copy(p, *source_name,

-                         *source_name_size + 1,  char);
+                         *source_name_size,  char);

                 }
             }
             pclose(fp);
                 }
             }
             pclose(fp);


@@ -6127,10 +6251,10 @@ static void atos_symbolize(atos_context* ctx,
 =for apidoc get_c_backtrace
 
 Collects the backtrace (aka "stacktrace") into a single linear
 =for apidoc get_c_backtrace
 
 Collects the backtrace (aka "stacktrace") into a single linear

-malloced buffer, which the caller B<must> Perl_free_c_backtrace().
+malloced buffer, which the caller B<must> C<Perl_free_c_backtrace()>.

 
 

-Scans the frames back by depth + skip, then drops the skip innermost,
-returning at most depth frames.
+Scans the frames back by S<C<depth + skip>>, then drops the C<skip> innermost,
+returning at most C<depth> frames.

 
 =cut
 */
 
 =cut
 */


@@ -6238,14 +6362,15 @@ Perl_get_c_backtrace(pTHX_ int depth, int skip)
         for (i = skip; i < try_depth; i++) {
             Dl_info* dl_info = &dl_infos[i];
 
         for (i = skip; i < try_depth; i++) {
             Dl_info* dl_info = &dl_infos[i];
 

-            total_bytes += sizeof(Perl_c_backtrace_frame);
-
+            object_name_sizes[i] = 0;

             source_names[i] = NULL;
             source_name_sizes[i] = 0;
             source_lines[i] = 0;
 
             /* Yes, zero from dladdr() is failure. */
             if (dladdr(raw_frames[i], dl_info)) {
             source_names[i] = NULL;
             source_name_sizes[i] = 0;
             source_lines[i] = 0;
 
             /* Yes, zero from dladdr() is failure. */
             if (dladdr(raw_frames[i], dl_info)) {

+                total_bytes += sizeof(Perl_c_backtrace_frame);
+

                 object_name_sizes[i] =
                     dl_info->dli_fname ? strlen(dl_info->dli_fname) : 0;
                 symbol_name_sizes[i] =
                 object_name_sizes[i] =
                     dl_info->dli_fname ? strlen(dl_info->dli_fname) : 0;
                 symbol_name_sizes[i] =


@@ -6376,8 +6501,8 @@ Deallocates a backtrace received from get_c_bracktrace.
 /*
 =for apidoc get_c_backtrace_dump
 
 /*
 =for apidoc get_c_backtrace_dump
 

-Returns a SV a dump of |depth| frames of the call stack, skipping
-the |skip| innermost ones.  depth of 20 is usually enough.
+Returns a SV containing a dump of C<depth> frames of the call stack, skipping
+the C<skip> innermost ones.  C<depth> of 20 is usually enough.

 
 The appended output looks like:
 
 
 The appended output looks like:
 


@@ -6388,10 +6513,10 @@ The appended output looks like:
 
 The fields are tab-separated.  The first column is the depth (zero
 being the innermost non-skipped frame).  In the hex:offset, the hex is
 
 The fields are tab-separated.  The first column is the depth (zero
 being the innermost non-skipped frame).  In the hex:offset, the hex is

-where the program counter was in S_parse_body, and the :offset (might
-be missing) tells how much inside the S_parse_body the program counter was.
+where the program counter was in C<S_parse_body>, and the :offset (might
+be missing) tells how much inside the C<S_parse_body> the program counter was.

 
 

-The util.c:1716 is the source code file and line number.
+The C<util.c:1716> is the source code file and line number.

 
 The F</usr/bin/perl> is obvious (hopefully).
 
 
 The F</usr/bin/perl> is obvious (hopefully).
 


@@ -6433,7 +6558,7 @@ Perl_get_c_backtrace_dump(pTHX_ int depth, int skip)
             if (frame->source_name_size &&
                 frame->source_name_offset &&
                 frame->source_line_number) {
             if (frame->source_name_size &&
                 frame->source_name_offset &&
                 frame->source_line_number) {

-                Perl_sv_catpvf(aTHX_ dsv, "\t%s:%"UVuf,
+                Perl_sv_catpvf(aTHX_ dsv, "\t%s:%" UVuf,

                                (char*)bt + frame->source_name_offset,
                                (UV)frame->source_line_number);
             } else {
                                (char*)bt + frame->source_name_offset,
                                (UV)frame->source_line_number);
             } else {


@@ -6448,7 +6573,7 @@ Perl_get_c_backtrace_dump(pTHX_ int depth, int skip)
             sv_catpvs(dsv, "\n");
         }
 
             sv_catpvs(dsv, "\n");
         }
 

-        Perl_free_c_backtrace(aTHX_ bt);
+        Perl_free_c_backtrace(bt);

 
         return dsv;
     }
 
         return dsv;
     }


@@ -6459,7 +6584,7 @@ Perl_get_c_backtrace_dump(pTHX_ int depth, int skip)
 /*
 =for apidoc dump_c_backtrace
 
 /*
 =for apidoc dump_c_backtrace
 

-Dumps the C backtrace to the given fp.
+Dumps the C backtrace to the given C<fp>.

 
 Returns true if a backtrace could be retrieved, false if not.
 
 
 Returns true if a backtrace could be retrieved, false if not.
 


@@ -6484,6 +6609,106 @@ Perl_dump_c_backtrace(pTHX_ PerlIO* fp, int depth, int skip)
 
 #endif /* #ifdef USE_C_BACKTRACE */
 
 
 #endif /* #ifdef USE_C_BACKTRACE */
 

+#ifdef PERL_TSA_ACTIVE
+
+/* pthread_mutex_t and perl_mutex are typedef equivalent
+ * so casting the pointers is fine. */
+
+int perl_tsa_mutex_lock(perl_mutex* mutex)
+{
+    return pthread_mutex_lock((pthread_mutex_t *) mutex);
+}
+
+int perl_tsa_mutex_unlock(perl_mutex* mutex)
+{
+    return pthread_mutex_unlock((pthread_mutex_t *) mutex);
+}
+
+int perl_tsa_mutex_destroy(perl_mutex* mutex)
+{
+    return pthread_mutex_destroy((pthread_mutex_t *) mutex);
+}
+
+#endif
+
+
+#ifdef USE_DTRACE
+
+/* log a sub call or return */
+
+void
+Perl_dtrace_probe_call(pTHX_ CV *cv, bool is_call)
+{
+    const char *func;
+    const char *file;
+    const char *stash;
+    const COP  *start;
+    line_t      line;
+
+    PERL_ARGS_ASSERT_DTRACE_PROBE_CALL;
+
+    if (CvNAMED(cv)) {
+        HEK *hek = CvNAME_HEK(cv);
+        func = HEK_KEY(hek);
+    }
+    else {
+        GV  *gv = CvGV(cv);
+        func = GvENAME(gv);
+    }
+    start = (const COP *)CvSTART(cv);
+    file  = CopFILE(start);
+    line  = CopLINE(start);
+    stash = CopSTASHPV(start);
+
+    if (is_call) {
+        PERL_SUB_ENTRY(func, file, line, stash);
+    }
+    else {
+        PERL_SUB_RETURN(func, file, line, stash);
+    }
+}
+
+
+/* log a require file loading/loaded  */
+
+void
+Perl_dtrace_probe_load(pTHX_ const char *name, bool is_loading)
+{
+    PERL_ARGS_ASSERT_DTRACE_PROBE_LOAD;
+
+    if (is_loading) {
+       PERL_LOADING_FILE(name);
+    }
+    else {
+       PERL_LOADED_FILE(name);
+    }
+}
+
+
+/* log an op execution */
+
+void
+Perl_dtrace_probe_op(pTHX_ const OP *op)
+{
+    PERL_ARGS_ASSERT_DTRACE_PROBE_OP;
+
+    PERL_OP_ENTRY(OP_NAME(op));
+}
+
+
+/* log a compile/run phase change */
+
+void
+Perl_dtrace_probe_phase(pTHX_ enum perl_phase phase)
+{
+    const char *ph_old = PL_phase_names[PL_phase];
+    const char *ph_new = PL_phase_names[phase];
+
+    PERL_PHASE_CHANGE(ph_new, ph_old);
+}
+
+#endif
+

 /*
  * ex: set ts=8 sts=4 sw=4 et:
  */
 /*
  * ex: set ts=8 sts=4 sw=4 et:
  */