This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Eliminate OP_SETSTATE from cop.h header
[perl5.git] / util.c
diff --git a/util.c b/util.c
index 50e0141..0aab786 100644 (file)
--- a/util.c
+++ b/util.c
@@ -1,7 +1,7 @@
 /*    util.c
  *
 /*    util.c
  *
- *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- *    2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
+ *    2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -9,8 +9,10 @@
  */
 
 /*
  */
 
 /*
- * "Very useful, no doubt, that was to Saruman; yet it seems that he was
- * not content."  --Gandalf
+ * 'Very useful, no doubt, that was to Saruman; yet it seems that he was
+ *  not content.'                                    --Gandalf to Pippin
+ *
+ *     [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"]
  */
 
 /* This file contains assorted utility routines.
  */
 
 /* This file contains assorted utility routines.
@@ -99,7 +101,7 @@ Perl_safesysmalloc(MEM_SIZE size)
 #endif
 
 #ifdef PERL_POISON
 #endif
 
 #ifdef PERL_POISON
-       Poison(((char *)ptr), size, char);
+       PoisonNew(((char *)ptr), size, char);
 #endif
 
 #ifdef PERL_TRACK_MEMPOOL
 #endif
 
 #ifdef PERL_TRACK_MEMPOOL
@@ -165,7 +167,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
        if (header->size > size) {
            const MEM_SIZE freed_up = header->size - size;
            char *start_of_freed = ((char *)where) + size;
        if (header->size > size) {
            const MEM_SIZE freed_up = header->size - size;
            char *start_of_freed = ((char *)where) + size;
-           Poison(start_of_freed, freed_up, char);
+           PoisonFree(start_of_freed, freed_up, char);
        }
        header->size = size;
 #  endif
        }
        header->size = size;
 #  endif
@@ -178,11 +180,11 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
     ptr = (Malloc_t)PerlMem_realloc(where,size);
     PERL_ALLOC_CHECK(ptr);
 
     ptr = (Malloc_t)PerlMem_realloc(where,size);
     PERL_ALLOC_CHECK(ptr);
 
-    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) {
+    /* MUST do this fixup first, before doing ANYTHING else, as anything else
+       might allocate memory/free/move memory, and until we do the fixup, it
+       may well be chasing (and writing to) free memory.  */
 #ifdef PERL_TRACK_MEMPOOL
 #ifdef PERL_TRACK_MEMPOOL
+    if (ptr != NULL) {
        struct perl_memory_debug_header *const header
            = (struct perl_memory_debug_header *)ptr;
 
        struct perl_memory_debug_header *const header
            = (struct perl_memory_debug_header *)ptr;
 
@@ -190,7 +192,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
        if (header->size < size) {
            const MEM_SIZE fresh = size - header->size;
            char *start_of_fresh = ((char *)ptr) + size;
        if (header->size < size) {
            const MEM_SIZE fresh = size - header->size;
            char *start_of_fresh = ((char *)ptr) + size;
-           Poison(start_of_fresh, fresh, char);
+           PoisonNew(start_of_fresh, fresh, char);
        }
 #  endif
 
        }
 #  endif
 
@@ -198,7 +200,17 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
        header->prev->next = header;
 
         ptr = (Malloc_t)((char*)ptr+sTHX);
        header->prev->next = header;
 
         ptr = (Malloc_t)((char*)ptr+sTHX);
+    }
 #endif
 #endif
+
+    /* 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));
+
+
+    if (ptr != NULL) {
        return ptr;
     }
     else if (PL_nomemok)
        return ptr;
     }
     else if (PL_nomemok)
@@ -241,7 +253,7 @@ Perl_safesysfree(Malloc_t where)
            header->next->prev = header->prev;
            header->prev->next = header->next;
 #  ifdef PERL_POISON
            header->next->prev = header->prev;
            header->prev->next = header->next;
 #  ifdef PERL_POISON
-           Poison(where, header->size, char);
+           PoisonNew(where, header->size, char);
 #  endif
            /* Trigger the duplicate free warning.  */
            header->next = NULL;
 #  endif
            /* Trigger the duplicate free warning.  */
            header->next = NULL;
@@ -258,11 +270,23 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 {
     dTHX;
     Malloc_t ptr;
 {
     dTHX;
     Malloc_t ptr;
+    MEM_SIZE total_size = 0;
 
 
+    /* Even though calloc() for zero bytes is strange, be robust. */
+    if (size && (count <= MEM_SIZE_MAX / size))
+       total_size = size * count;
+    else
+       Perl_croak_nocontext("%s", PL_memory_wrap);
+#ifdef PERL_TRACK_MEMPOOL
+    if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
+       total_size += sTHX;
+    else
+       Perl_croak_nocontext("%s", PL_memory_wrap);
+#endif
 #ifdef HAS_64K_LIMIT
 #ifdef HAS_64K_LIMIT
-    if (size * count > 0xffff) {
+    if (total_size > 0xffff) {
        PerlIO_printf(Perl_error_log,
        PerlIO_printf(Perl_error_log,
-                     "Allocation too large: %lx\n", size * count) FLUSH;
+                     "Allocation too large: %lx\n", total_size) FLUSH;
        my_exit(1);
     }
 #endif /* HAS_64K_LIMIT */
        my_exit(1);
     }
 #endif /* HAS_64K_LIMIT */
@@ -270,20 +294,28 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
     if ((long)size < 0 || (long)count < 0)
        Perl_croak_nocontext("panic: calloc");
 #endif
     if ((long)size < 0 || (long)count < 0)
        Perl_croak_nocontext("panic: calloc");
 #endif
-    size *= count;
 #ifdef PERL_TRACK_MEMPOOL
 #ifdef PERL_TRACK_MEMPOOL
-    size += sTHX;
+    /* Have to use malloc() because we've added some space for our tracking
+       header.  */
+    /* malloc(0) is non-portable. */
+    ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
+#else
+    /* Use calloc() because it might save a memset() if the memory is fresh
+       and clean from the OS.  */
+    if (count && size)
+       ptr = (Malloc_t)PerlMem_calloc(count, size);
+    else /* calloc(0) is non-portable. */
+       ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
 #endif
 #endif
-    ptr = (Malloc_t)PerlMem_malloc(size?size:1);       /* malloc(0) is NASTY on our system */
     PERL_ALLOC_CHECK(ptr);
     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)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) {
     if (ptr != NULL) {
-       memset((void*)ptr, 0, size);
 #ifdef PERL_TRACK_MEMPOOL
        {
            struct perl_memory_debug_header *const header
                = (struct perl_memory_debug_header *)ptr;
 
 #ifdef PERL_TRACK_MEMPOOL
        {
            struct perl_memory_debug_header *const header
                = (struct perl_memory_debug_header *)ptr;
 
+           memset((void*)ptr, 0, total_size);
            header->interpreter = aTHX;
            /* Link us into the list.  */
            header->prev = &PL_memory_debug_header;
            header->interpreter = aTHX;
            /* Link us into the list.  */
            header->prev = &PL_memory_debug_header;
@@ -291,7 +323,7 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
            PL_memory_debug_header.next = header;
            header->next->prev = header;
 #  ifdef PERL_POISON
            PL_memory_debug_header.next = header;
            header->next->prev = header;
 #  ifdef PERL_POISON
-           header->size = size;
+           header->size = total_size;
 #  endif
            ptr = (Malloc_t)((char*)ptr+sTHX);
        }
 #  endif
            ptr = (Malloc_t)((char*)ptr+sTHX);
        }
@@ -337,19 +369,20 @@ Free_t   Perl_mfree (Malloc_t where)
 /* copy a string up to some (non-backslashed) delimiter, if any */
 
 char *
 /* copy a string up to some (non-backslashed) delimiter, if any */
 
 char *
-Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
+Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
 {
     register I32 tolen;
 {
     register I32 tolen;
+
+    PERL_ARGS_ASSERT_DELIMCPY;
+
     for (tolen = 0; from < fromend; from++, tolen++) {
        if (*from == '\\') {
     for (tolen = 0; from < fromend; from++, tolen++) {
        if (*from == '\\') {
-           if (from[1] == delim)
-               from++;
-           else {
+           if (from[1] != delim) {
                if (to < toend)
                    *to++ = *from;
                tolen++;
                if (to < toend)
                    *to++ = *from;
                tolen++;
-               from++;
            }
            }
+           from++;
        }
        else if (*from == delim)
            break;
        }
        else if (*from == delim)
            break;
@@ -366,10 +399,12 @@ Perl_delimcpy(pTHX_ register char *to, register const char *toend, register cons
 /* This routine was donated by Corey Satten. */
 
 char *
 /* This routine was donated by Corey Satten. */
 
 char *
-Perl_instr(pTHX_ register const char *big, register const char *little)
+Perl_instr(register const char *big, register const char *little)
 {
     register I32 first;
 
 {
     register I32 first;
 
+    PERL_ARGS_ASSERT_INSTR;
+
     if (!little)
        return (char*)big;
     first = *little++;
     if (!little)
        return (char*)big;
     first = *little++;
@@ -398,23 +433,24 @@ Perl_instr(pTHX_ register const char *big, register const char *little)
 /* same as instr but allow embedded nulls */
 
 char *
 /* same as instr but allow embedded nulls */
 
 char *
-Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend)
+Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
 {
 {
+    PERL_ARGS_ASSERT_NINSTR;
     if (little >= lend)
         return (char*)big;
     {
     if (little >= lend)
         return (char*)big;
     {
-        char first = *little++;
+        const char first = *little;
         const char *s, *x;
         const char *s, *x;
-        bigend -= lend - little;
+        bigend -= lend - little++;
     OUTER:
         while (big <= bigend) {
     OUTER:
         while (big <= bigend) {
-            if (*big++ != first)
-                goto OUTER;
-            for (x=big,s=little; s < lend; x++,s++) {
-                if (*s != *x)
-                    goto OUTER;
+            if (*big++ == first) {
+                for (x=big,s=little; s < lend; x++,s++) {
+                    if (*s != *x)
+                        goto OUTER;
+                }
+                return (char*)(big-1);
             }
             }
-            return (char*)(big-1);
         }
     }
     return NULL;
         }
     }
     return NULL;
@@ -423,12 +459,14 @@ Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const
 /* reverse of the above--find last substring */
 
 char *
 /* reverse of the above--find last substring */
 
 char *
-Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
+Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend)
 {
     register const char *bigbeg;
     register const I32 first = *little;
     register const char * const littleend = lend;
 
 {
     register const char *bigbeg;
     register const I32 first = *little;
     register const char * const littleend = lend;
 
+    PERL_ARGS_ASSERT_RNINSTR;
+
     if (little >= littleend)
        return (char*)bigend;
     bigbeg = big;
     if (little >= littleend)
        return (char*)bigend;
     bigbeg = big;
@@ -451,8 +489,6 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit
     return NULL;
 }
 
     return NULL;
 }
 
-#define FBM_TABLE_OFFSET 2     /* Number of bytes between EOS and table*/
-
 /* As a space optimization, we do not compile tables for strings of length
    0 and 1, and for strings of length 2 unless FBMcf_TAIL.  These are
    special-cased in fbm_instr().
 /* As a space optimization, we do not compile tables for strings of length
    0 and 1, and for strings of length 2 unless FBMcf_TAIL.  These are
    special-cased in fbm_instr().
@@ -477,9 +513,11 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
     register const U8 *s;
     register U32 i;
     STRLEN len;
     register const U8 *s;
     register U32 i;
     STRLEN len;
-    I32 rarest = 0;
+    U32 rarest = 0;
     U32 frequency = 256;
 
     U32 frequency = 256;
 
+    PERL_ARGS_ASSERT_FBM_COMPILE;
+
     if (flags & FBMcf_TAIL) {
        MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
        sv_catpvs(sv, "\n");            /* Taken into account in fbm_instr() */
     if (flags & FBMcf_TAIL) {
        MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
        sv_catpvs(sv, "\n");            /* Taken into account in fbm_instr() */
@@ -487,19 +525,22 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
            mg->mg_len++;
     }
     s = (U8*)SvPV_force_mutable(sv, len);
            mg->mg_len++;
     }
     s = (U8*)SvPV_force_mutable(sv, len);
-    SvUPGRADE(sv, SVt_PVBM);
     if (len == 0)              /* TAIL might be on a zero-length string. */
        return;
     if (len == 0)              /* TAIL might be on a zero-length string. */
        return;
+    SvUPGRADE(sv, SVt_PVGV);
+    SvIOK_off(sv);
+    SvNOK_off(sv);
+    SvVALID_on(sv);
     if (len > 2) {
        const unsigned char *sb;
        const U8 mlen = (len>255) ? 255 : (U8)len;
        register U8 *table;
 
     if (len > 2) {
        const unsigned char *sb;
        const U8 mlen = (len>255) ? 255 : (U8)len;
        register U8 *table;
 
-       Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
-       table = (unsigned char*)(SvPVX_mutable(sv) + len + FBM_TABLE_OFFSET);
-       s = table - 1 - FBM_TABLE_OFFSET;       /* last char */
+       Sv_Grow(sv, len + 256 + PERL_FBM_TABLE_OFFSET);
+       table
+           = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
+       s = table - 1 - PERL_FBM_TABLE_OFFSET;  /* last char */
        memset((void*)table, mlen, 256);
        memset((void*)table, mlen, 256);
-       table[-1] = (U8)flags;
        i = 0;
        sb = s - mlen + 1;                      /* first char (maybe) */
        while (s >= sb) {
        i = 0;
        sb = s - mlen + 1;                      /* first char (maybe) */
        while (s >= sb) {
@@ -507,9 +548,10 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
                table[*s] = (U8)i;
            s--, i++;
        }
                table[*s] = (U8)i;
            s--, i++;
        }
+    } else {
+       Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET);
     }
     sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0);        /* deep magic */
     }
     sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0);        /* deep magic */
-    SvVALID_on(sv);
 
     s = (const unsigned char*)(SvPVX_const(sv));       /* deeper magic */
     for (i = 0; i < len; i++) {
 
     s = (const unsigned char*)(SvPVX_const(sv));       /* deeper magic */
     for (i = 0; i < len; i++) {
@@ -518,13 +560,14 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
            frequency = PL_freq[s[i]];
        }
     }
            frequency = PL_freq[s[i]];
        }
     }
+    BmFLAGS(sv) = (U8)flags;
     BmRARE(sv) = s[rarest];
     BmRARE(sv) = s[rarest];
-    BmPREVIOUS(sv) = (U16)rarest;
+    BmPREVIOUS(sv) = rarest;
     BmUSEFUL(sv) = 100;                        /* Initial value */
     if (flags & FBMcf_TAIL)
        SvTAIL_on(sv);
     BmUSEFUL(sv) = 100;                        /* Initial value */
     if (flags & FBMcf_TAIL)
        SvTAIL_on(sv);
-    DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
-                         BmRARE(sv),BmPREVIOUS(sv)));
+    DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n",
+                         BmRARE(sv),(unsigned long)BmPREVIOUS(sv)));
 }
 
 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
 }
 
 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
@@ -552,6 +595,8 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
     register STRLEN littlelen = l;
     register const I32 multiline = flags & FBMrf_MULTILINE;
 
     register STRLEN littlelen = l;
     register const I32 multiline = flags & FBMrf_MULTILINE;
 
+    PERL_ARGS_ASSERT_FBM_INSTR;
+
     if ((STRLEN)(bigend - big) < littlelen) {
        if ( SvTAIL(littlestr)
             && ((STRLEN)(bigend - big) == littlelen - 1)
     if ((STRLEN)(bigend - big) < littlelen) {
        if ( SvTAIL(littlestr)
             && ((STRLEN)(bigend - big) == littlelen - 1)
@@ -660,7 +705,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
        }
        return NULL;
     }
        }
        return NULL;
     }
-    if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
+    if (!SvVALID(littlestr)) {
        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);
 
@@ -677,12 +722,15 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
        return b;
     }
 
        return b;
     }
 
-    {  /* Do actual FBM.  */
-       register const unsigned char * const table = little + littlelen + FBM_TABLE_OFFSET;
+    /* Do actual FBM.  */
+    if (littlelen > (STRLEN)(bigend - big))
+       return NULL;
+
+    {
+       register const unsigned char * const table
+           = little + littlelen + PERL_FBM_TABLE_OFFSET;
        register const unsigned char *oldlittle;
 
        register const unsigned char *oldlittle;
 
-       if (littlelen > (STRLEN)(bigend - big))
-           return NULL;
        --littlelen;                    /* Last char found by table lookup */
 
        s = big + littlelen;
        --littlelen;                    /* Last char found by table lookup */
 
        s = big + littlelen;
@@ -715,7 +763,8 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
            }
        }
       check_end:
            }
        }
       check_end:
-       if ( s == bigend && (table[-1] & FBMcf_TAIL)
+       if ( s == bigend
+            && (BmFLAGS(littlestr) & FBMcf_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;
@@ -751,6 +800,11 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
     register const unsigned char *littleend;
     I32 found = 0;
 
     register const unsigned char *littleend;
     I32 found = 0;
 
+    PERL_ARGS_ASSERT_SCREAMINSTR;
+
+    assert(SvTYPE(littlestr) == SVt_PVGV);
+    assert(SvVALID(littlestr));
+
     if (*old_posp == -1
        ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
        : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
     if (*old_posp == -1
        ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
        : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
@@ -825,10 +879,13 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
 }
 
 I32
 }
 
 I32
-Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
+Perl_ibcmp(const char *s1, const char *s2, register I32 len)
 {
     register const U8 *a = (const U8 *)s1;
     register const U8 *b = (const U8 *)s2;
 {
     register const U8 *a = (const U8 *)s1;
     register const U8 *b = (const U8 *)s2;
+
+    PERL_ARGS_ASSERT_IBCMP;
+
     while (len--) {
        if (*a != *b && *a != PL_fold[*b])
            return 1;
     while (len--) {
        if (*a != *b && *a != PL_fold[*b])
            return 1;
@@ -838,11 +895,14 @@ Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
 }
 
 I32
 }
 
 I32
-Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
+Perl_ibcmp_locale(const char *s1, const char *s2, register I32 len)
 {
     dVAR;
     register const U8 *a = (const U8 *)s1;
     register const U8 *b = (const U8 *)s2;
 {
     dVAR;
     register const U8 *a = (const U8 *)s1;
     register const U8 *b = (const U8 *)s2;
+
+    PERL_ARGS_ASSERT_IBCMP_LOCALE;
+
     while (len--) {
        if (*a != *b && *a != PL_fold_locale[*b])
            return 1;
     while (len--) {
        if (*a != *b && *a != PL_fold_locale[*b])
            return 1;
@@ -869,15 +929,15 @@ be freed with the C<Safefree()> function.
 char *
 Perl_savepv(pTHX_ const char *pv)
 {
 char *
 Perl_savepv(pTHX_ const char *pv)
 {
+    PERL_UNUSED_CONTEXT;
     if (!pv)
        return NULL;
     else {
        char *newaddr;
        const STRLEN pvlen = strlen(pv)+1;
     if (!pv)
        return NULL;
     else {
        char *newaddr;
        const STRLEN pvlen = strlen(pv)+1;
-       Newx(newaddr,pvlen,char);
-       return memcpy(newaddr,pv,pvlen);
+       Newx(newaddr, pvlen, char);
+       return (char*)memcpy(newaddr, pv, pvlen);
     }
     }
-
 }
 
 /* same thing but with a known length */
 }
 
 /* same thing but with a known length */
@@ -887,8 +947,8 @@ Perl_savepv(pTHX_ const char *pv)
 
 Perl's version of what C<strndup()> would be if it existed. Returns a
 pointer to a newly allocated string which is a duplicate of the first
 
 Perl's version of what C<strndup()> would be if it existed. Returns a
 pointer to a newly allocated string which is a duplicate of the first
-C<len> bytes from C<pv>. The memory allocated for the new string can be
-freed with the C<Safefree()> function.
+C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
+the new string can be freed with the C<Safefree()> function.
 
 =cut
 */
 
 =cut
 */
@@ -897,6 +957,7 @@ char *
 Perl_savepvn(pTHX_ const char *pv, register I32 len)
 {
     register char *newaddr;
 Perl_savepvn(pTHX_ const char *pv, register I32 len)
 {
     register char *newaddr;
+    PERL_UNUSED_CONTEXT;
 
     Newx(newaddr,len+1,char);
     /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
 
     Newx(newaddr,len+1,char);
     /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
@@ -931,7 +992,30 @@ Perl_savesharedpv(pTHX_ const char *pv)
     if (!newaddr) {
        return write_no_mem();
     }
     if (!newaddr) {
        return write_no_mem();
     }
-    return memcpy(newaddr,pv,pvlen);
+    return (char*)memcpy(newaddr, pv, pvlen);
+}
+
+/*
+=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
+pointer is not acceptable)
+
+=cut
+*/
+char *
+Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
+{
+    char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
+
+    PERL_ARGS_ASSERT_SAVESHAREDPVN;
+
+    if (!newaddr) {
+       return write_no_mem();
+    }
+    newaddr[len] = '\0';
+    return (char*)memcpy(newaddr, pv, len);
 }
 
 /*
 }
 
 /*
@@ -950,6 +1034,8 @@ Perl_savesvpv(pTHX_ SV *sv)
     const char * const pv = SvPV_const(sv, len);
     register char *newaddr;
 
     const char * const pv = SvPV_const(sv, len);
     register char *newaddr;
 
+    PERL_ARGS_ASSERT_SAVESVPV;
+
     ++len;
     Newx(newaddr,len,char);
     return (char *) CopyD(pv,newaddr,len,char);
     ++len;
     Newx(newaddr,len,char);
     return (char *) CopyD(pv,newaddr,len,char);
@@ -966,7 +1052,7 @@ S_mess_alloc(pTHX)
     XPVMG *any;
 
     if (!PL_dirty)
     XPVMG *any;
 
     if (!PL_dirty)
-       return sv_2mortal(newSVpvs(""));
+       return newSVpvs_flags("", SVs_TEMP);
 
     if (PL_mess_sv)
        return PL_mess_sv;
 
     if (PL_mess_sv)
        return PL_mess_sv;
@@ -989,6 +1075,7 @@ Perl_form_nocontext(const char* pat, ...)
     dTHX;
     char *retval;
     va_list args;
     dTHX;
     char *retval;
     va_list args;
+    PERL_ARGS_ASSERT_FORM_NOCONTEXT;
     va_start(args, pat);
     retval = vform(pat, &args);
     va_end(args);
     va_start(args, pat);
     retval = vform(pat, &args);
     va_end(args);
@@ -1021,6 +1108,7 @@ Perl_form(pTHX_ const char* pat, ...)
 {
     char *retval;
     va_list args;
 {
     char *retval;
     va_list args;
+    PERL_ARGS_ASSERT_FORM;
     va_start(args, pat);
     retval = vform(pat, &args);
     va_end(args);
     va_start(args, pat);
     retval = vform(pat, &args);
     va_end(args);
@@ -1031,6 +1119,7 @@ char *
 Perl_vform(pTHX_ const char *pat, va_list *args)
 {
     SV * const sv = mess_alloc();
 Perl_vform(pTHX_ const char *pat, va_list *args)
 {
     SV * const sv = mess_alloc();
+    PERL_ARGS_ASSERT_VFORM;
     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
     return SvPVX(sv);
 }
     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
     return SvPVX(sv);
 }
@@ -1042,6 +1131,7 @@ Perl_mess_nocontext(const char *pat, ...)
     dTHX;
     SV *retval;
     va_list args;
     dTHX;
     SV *retval;
     va_list args;
+    PERL_ARGS_ASSERT_MESS_NOCONTEXT;
     va_start(args, pat);
     retval = vmess(pat, &args);
     va_end(args);
     va_start(args, pat);
     retval = vmess(pat, &args);
     va_end(args);
@@ -1054,6 +1144,7 @@ Perl_mess(pTHX_ const char *pat, ...)
 {
     SV *retval;
     va_list args;
 {
     SV *retval;
     va_list args;
+    PERL_ARGS_ASSERT_MESS;
     va_start(args, pat);
     retval = vmess(pat, &args);
     va_end(args);
     va_start(args, pat);
     retval = vmess(pat, &args);
     va_end(args);
@@ -1066,6 +1157,8 @@ S_closest_cop(pTHX_ const COP *cop, const OP *o)
     dVAR;
     /* Look for PL_op starting from o.  cop is the last COP we've seen. */
 
     dVAR;
     /* Look for PL_op starting from o.  cop is the last COP we've seen. */
 
+    PERL_ARGS_ASSERT_CLOSEST_COP;
+
     if (!o || o == PL_op)
        return cop;
 
     if (!o || o == PL_op)
        return cop;
 
@@ -1099,6 +1192,8 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
     dVAR;
     SV * const sv = mess_alloc();
 
     dVAR;
     SV * const sv = mess_alloc();
 
+    PERL_ARGS_ASSERT_VMESS;
+
     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
        /*
     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
        /*
@@ -1115,7 +1210,10 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
        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));
-       if (GvIO(PL_last_in_gv) && 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)))
+       {
            const bool line_mode = (RsSIMPLE(PL_rs) &&
                              SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
            Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
            const bool line_mode = (RsSIMPLE(PL_rs) &&
                              SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
            Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
@@ -1131,15 +1229,17 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
 }
 
 void
 }
 
 void
-Perl_write_to_stderr(pTHX_ const char* message, int msglen)
+Perl_write_to_stderr(pTHX_ SV* msv)
 {
     dVAR;
     IO *io;
     MAGIC *mg;
 
 {
     dVAR;
     IO *io;
     MAGIC *mg;
 
+    PERL_ARGS_ASSERT_WRITE_TO_STDERR;
+
     if (PL_stderrgv && SvREFCNT(PL_stderrgv) 
        && (io = GvIO(PL_stderrgv))
     if (PL_stderrgv && SvREFCNT(PL_stderrgv) 
        && (io = GvIO(PL_stderrgv))
-       && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) 
+       && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) 
     {
        dSP;
        ENTER;
     {
        dSP;
        ENTER;
@@ -1153,8 +1253,8 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
 
        PUSHMARK(SP);
        EXTEND(SP,2);
 
        PUSHMARK(SP);
        EXTEND(SP,2);
-       PUSHs(SvTIED_obj((SV*)io, mg));
-       PUSHs(sv_2mortal(newSVpvn(message, msglen)));
+       PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
+       PUSHs(msv);
        PUTBACK;
        call_method("PRINT", G_SCALAR);
 
        PUTBACK;
        call_method("PRINT", G_SCALAR);
 
@@ -1165,14 +1265,16 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
     else {
 #ifdef USE_SFIO
        /* SFIO can really mess with your errno */
     else {
 #ifdef USE_SFIO
        /* SFIO can really mess with your errno */
-       const int e = errno;
+       dSAVED_ERRNO;
 #endif
        PerlIO * const serr = Perl_error_log;
 #endif
        PerlIO * const serr = Perl_error_log;
+       STRLEN msglen;
+       const char* message = SvPVx_const(msv, msglen);
 
        PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
        (void)PerlIO_flush(serr);
 #ifdef USE_SFIO
 
        PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
        (void)PerlIO_flush(serr);
 #ifdef USE_SFIO
-       errno = e;
+       RESTORE_ERRNO;
 #endif
     }
 }
 #endif
     }
 }
@@ -1180,7 +1282,7 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
 /* Common code used by vcroak, vdie, vwarn and vwarner  */
 
 STATIC bool
 /* Common code used by vcroak, vdie, vwarn and vwarner  */
 
 STATIC bool
-S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
+S_vdie_common(pTHX_ SV *message, bool warn)
 {
     dVAR;
     HV *stash;
 {
     dVAR;
     HV *stash;
@@ -1208,8 +1310,7 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
            *hook = NULL;
        }
        if (warn || message) {
            *hook = NULL;
        }
        if (warn || message) {
-           msg = newSVpvn(message, msglen);
-           SvFLAGS(msg) |= utf8;
+           msg = newSVsv(message);
            SvREADONLY_on(msg);
            SAVEFREESV(msg);
        }
            SvREADONLY_on(msg);
            SAVEFREESV(msg);
        }
@@ -1221,7 +1322,7 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
        PUSHMARK(SP);
        XPUSHs(msg);
        PUTBACK;
        PUSHMARK(SP);
        XPUSHs(msg);
        PUTBACK;
-       call_sv((SV*)cv, G_DISCARD);
+       call_sv(MUTABLE_SV(cv), G_DISCARD);
        POPSTACK;
        LEAVE;
        return TRUE;
        POPSTACK;
        LEAVE;
        return TRUE;
@@ -1229,60 +1330,43 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
     return FALSE;
 }
 
     return FALSE;
 }
 
-STATIC const char *
-S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
-                   I32* utf8)
+STATIC SV *
+S_vdie_croak_common(pTHX_ const char* pat, va_list* args)
 {
     dVAR;
 {
     dVAR;
-    const char *message;
+    SV *message;
 
     if (pat) {
        SV * const msv = vmess(pat, args);
        if (PL_errors && SvCUR(PL_errors)) {
            sv_catsv(PL_errors, msv);
 
     if (pat) {
        SV * const msv = vmess(pat, args);
        if (PL_errors && SvCUR(PL_errors)) {
            sv_catsv(PL_errors, msv);
-           message = SvPV_const(PL_errors, *msglen);
+           message = sv_mortalcopy(PL_errors);
            SvCUR_set(PL_errors, 0);
        }
        else
            SvCUR_set(PL_errors, 0);
        }
        else
-           message = SvPV_const(msv,*msglen);
-       *utf8 = SvUTF8(msv);
+           message = msv;
     }
     else {
        message = NULL;
     }
 
     }
     else {
        message = NULL;
     }
 
-    DEBUG_S(PerlIO_printf(Perl_debug_log,
-                         "%p: die/croak: message = %s\ndiehook = %p\n",
-                         thr, message, PL_diehook));
     if (PL_diehook) {
     if (PL_diehook) {
-       S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
+       S_vdie_common(aTHX_ message, FALSE);
     }
     return message;
 }
 
     }
     return message;
 }
 
-OP *
-Perl_vdie(pTHX_ const char* pat, va_list *args)
+static OP *
+S_vdie(pTHX_ const char* pat, va_list *args)
 {
     dVAR;
 {
     dVAR;
-    const char *message;
-    const int was_in_eval = PL_in_eval;
-    STRLEN msglen;
-    I32 utf8 = 0;
-
-    DEBUG_S(PerlIO_printf(Perl_debug_log,
-                         "%p: die: curstack = %p, mainstack = %p\n",
-                         thr, PL_curstack, PL_mainstack));
+    SV *message;
 
 
-    message = vdie_croak_common(pat, args, &msglen, &utf8);
+    message = vdie_croak_common(pat, args);
 
 
-    PL_restartop = die_where(message, msglen);
-    SvFLAGS(ERRSV) |= utf8;
-    DEBUG_S(PerlIO_printf(Perl_debug_log,
-         "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
-         thr, PL_restartop, was_in_eval, PL_top_env));
-    if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
-       JMPENV_JUMP(3);
-    return PL_restartop;
+    die_where(message);
+    /* NOTREACHED */
+    return NULL;
 }
 
 #if defined(PERL_IMPLICIT_CONTEXT)
 }
 
 #if defined(PERL_IMPLICIT_CONTEXT)
@@ -1314,22 +1398,11 @@ void
 Perl_vcroak(pTHX_ const char* pat, va_list *args)
 {
     dVAR;
 Perl_vcroak(pTHX_ const char* pat, va_list *args)
 {
     dVAR;
-    const char *message;
-    STRLEN msglen;
-    I32 utf8 = 0;
+    SV *msv;
 
 
-    message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
-
-    if (PL_in_eval) {
-       PL_restartop = die_where(message, msglen);
-       SvFLAGS(ERRSV) |= utf8;
-       JMPENV_JUMP(3);
-    }
-    else if (!message)
-       message = SvPVx_const(ERRSV, msglen);
+    msv = S_vdie_croak_common(aTHX_ pat, args);
 
 
-    write_to_stderr(message, msglen);
-    my_failure_exit();
+    die_where(msv);
 }
 
 #if defined(PERL_IMPLICIT_CONTEXT)
 }
 
 #if defined(PERL_IMPLICIT_CONTEXT)
@@ -1358,7 +1431,7 @@ sidestepping the normal C order of execution. See C<warn>.
 If you want to throw an exception object, assign the object to
 C<$@> and then pass C<NULL> to croak():
 
 If you want to throw an exception object, assign the object to
 C<$@> and then pass C<NULL> to croak():
 
-   errsv = get_sv("@", TRUE);
+   errsv = get_sv("@", GV_ADD);
    sv_setsv(errsv, exception_object);
    croak(NULL);
 
    sv_setsv(errsv, exception_object);
    croak(NULL);
 
@@ -1379,17 +1452,16 @@ void
 Perl_vwarn(pTHX_ const char* pat, va_list *args)
 {
     dVAR;
 Perl_vwarn(pTHX_ const char* pat, va_list *args)
 {
     dVAR;
-    STRLEN msglen;
     SV * const msv = vmess(pat, args);
     SV * const msv = vmess(pat, args);
-    const I32 utf8 = SvUTF8(msv);
-    const char * const message = SvPV_const(msv, msglen);
+
+    PERL_ARGS_ASSERT_VWARN;
 
     if (PL_warnhook) {
 
     if (PL_warnhook) {
-       if (vdie_common(message, msglen, utf8, TRUE))
+       if (vdie_common(msv, TRUE))
            return;
     }
 
            return;
     }
 
-    write_to_stderr(message, msglen);
+    write_to_stderr(msv);
 }
 
 #if defined(PERL_IMPLICIT_CONTEXT)
 }
 
 #if defined(PERL_IMPLICIT_CONTEXT)
@@ -1398,6 +1470,7 @@ Perl_warn_nocontext(const char *pat, ...)
 {
     dTHX;
     va_list args;
 {
     dTHX;
     va_list args;
+    PERL_ARGS_ASSERT_WARN_NOCONTEXT;
     va_start(args, pat);
     vwarn(pat, &args);
     va_end(args);
     va_start(args, pat);
     vwarn(pat, &args);
     va_end(args);
@@ -1417,6 +1490,7 @@ void
 Perl_warn(pTHX_ const char *pat, ...)
 {
     va_list args;
 Perl_warn(pTHX_ const char *pat, ...)
 {
     va_list args;
+    PERL_ARGS_ASSERT_WARN;
     va_start(args, pat);
     vwarn(pat, &args);
     va_end(args);
     va_start(args, pat);
     vwarn(pat, &args);
     va_end(args);
@@ -1428,6 +1502,7 @@ Perl_warner_nocontext(U32 err, const char *pat, ...)
 {
     dTHX; 
     va_list args;
 {
     dTHX; 
     va_list args;
+    PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
     va_start(args, pat);
     vwarner(err, pat, &args);
     va_end(args);
     va_start(args, pat);
     vwarner(err, pat, &args);
     va_end(args);
@@ -1435,9 +1510,36 @@ Perl_warner_nocontext(U32 err, const char *pat, ...)
 #endif /* PERL_IMPLICIT_CONTEXT */
 
 void
 #endif /* PERL_IMPLICIT_CONTEXT */
 
 void
+Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
+{
+    PERL_ARGS_ASSERT_CK_WARNER_D;
+
+    if (Perl_ckwarn_d(aTHX_ err)) {
+       va_list args;
+       va_start(args, pat);
+       vwarner(err, pat, &args);
+       va_end(args);
+    }
+}
+
+void
+Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
+{
+    PERL_ARGS_ASSERT_CK_WARNER;
+
+    if (Perl_ckwarn(aTHX_ err)) {
+       va_list args;
+       va_start(args, pat);
+       vwarner(err, pat, &args);
+       va_end(args);
+    }
+}
+
+void
 Perl_warner(pTHX_ U32  err, const char* pat,...)
 {
     va_list args;
 Perl_warner(pTHX_ U32  err, const char* pat,...)
 {
     va_list args;
+    PERL_ARGS_ASSERT_WARNER;
     va_start(args, pat);
     vwarner(err, pat, &args);
     va_end(args);
     va_start(args, pat);
     vwarner(err, pat, &args);
     va_end(args);
@@ -1447,23 +1549,15 @@ void
 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
 {
     dVAR;
 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
 {
     dVAR;
-    if (ckDEAD(err)) {
+    PERL_ARGS_ASSERT_VWARNER;
+    if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
        SV * const msv = vmess(pat, args);
        SV * const msv = vmess(pat, args);
-       STRLEN msglen;
-       const char * const message = SvPV_const(msv, msglen);
-       const I32 utf8 = SvUTF8(msv);
 
        if (PL_diehook) {
 
        if (PL_diehook) {
-           assert(message);
-           S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
-       }
-       if (PL_in_eval) {
-           PL_restartop = die_where(message, msglen);
-           SvFLAGS(ERRSV) |= utf8;
-           JMPENV_JUMP(3);
+           assert(msv);
+           S_vdie_common(aTHX_ msv, FALSE);
        }
        }
-       write_to_stderr(message, msglen);
-       my_failure_exit();
+       die_where(msv);
     }
     else {
        Perl_vwarn(aTHX_ pat, args);
     }
     else {
        Perl_vwarn(aTHX_ pat, args);
@@ -1476,26 +1570,11 @@ bool
 Perl_ckwarn(pTHX_ U32 w)
 {
     dVAR;
 Perl_ckwarn(pTHX_ U32 w)
 {
     dVAR;
-    return
-       (
-              isLEXWARN_on
-           && PL_curcop->cop_warnings != pWARN_NONE
-           && (
-                  PL_curcop->cop_warnings == pWARN_ALL
-               || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
-               || (unpackWARN2(w) &&
-                    isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
-               || (unpackWARN3(w) &&
-                    isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
-               || (unpackWARN4(w) &&
-                    isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
-               )
-       )
-       ||
-       (
-           isLEXWARN_off && PL_dowarn & G_WARN_ON
-       )
-       ;
+    /* If lexical warnings have not been set, use $^W.  */
+    if (isLEXWARN_off)
+       return PL_dowarn & G_WARN_ON;
+
+    return ckwarn_common(w);
 }
 
 /* implements the ckWARN?_d macro */
 }
 
 /* implements the ckWARN?_d macro */
@@ -1504,25 +1583,60 @@ bool
 Perl_ckwarn_d(pTHX_ U32 w)
 {
     dVAR;
 Perl_ckwarn_d(pTHX_ U32 w)
 {
     dVAR;
-    return
-          isLEXWARN_off
-       || PL_curcop->cop_warnings == pWARN_ALL
-       || (
-             PL_curcop->cop_warnings != pWARN_NONE 
-          && (
-                  isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
-             || (unpackWARN2(w) &&
-                  isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
-             || (unpackWARN3(w) &&
-                  isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
-             || (unpackWARN4(w) &&
-                  isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
-             )
-          )
-       ;
+    /* If lexical warnings have not been set then default classes warn.  */
+    if (isLEXWARN_off)
+       return TRUE;
+
+    return ckwarn_common(w);
+}
+
+static bool
+S_ckwarn_common(pTHX_ U32 w)
+{
+    if (PL_curcop->cop_warnings == pWARN_ALL)
+       return TRUE;
+
+    if (PL_curcop->cop_warnings == pWARN_NONE)
+       return FALSE;
+
+    /* Check the assumption that at least the first slot is non-zero.  */
+    assert(unpackWARN1(w));
+
+    /* Check the assumption that it is valid to stop as soon as a zero slot is
+       seen.  */
+    if (!unpackWARN2(w)) {
+       assert(!unpackWARN3(w));
+       assert(!unpackWARN4(w));
+    } else if (!unpackWARN3(w)) {
+       assert(!unpackWARN4(w));
+    }
+       
+    /* Right, dealt with all the special cases, which are implemented as non-
+       pointers, so there is a pointer to a real warnings mask.  */
+    do {
+       if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
+           return TRUE;
+    } while (w >>= WARNshift);
+
+    return FALSE;
 }
 
 }
 
+/* Set buffer=NULL to get a new one.  */
+STRLEN *
+Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
+                          STRLEN size) {
+    const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
+    PERL_UNUSED_CONTEXT;
+    PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
 
 
+    buffer = (STRLEN*)
+       (specialWARN(buffer) ?
+        PerlMemShared_malloc(len_wanted) :
+        PerlMemShared_realloc(buffer, len_wanted));
+    buffer[0] = size;
+    Copy(bits, (buffer + 1), size, char);
+    return buffer;
+}
 
 /* since we've already done strlen() for both nam and val
  * we can use that info to make things faster than
 
 /* since we've already done strlen() for both nam and val
  * we can use that info to make things faster than
@@ -1549,47 +1663,56 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
 #ifndef PERL_USE_SAFE_PUTENV
     if (!PL_use_safe_putenv) {
     /* most putenv()s leak, so we manipulate environ directly */
 #ifndef PERL_USE_SAFE_PUTENV
     if (!PL_use_safe_putenv) {
     /* most putenv()s leak, so we manipulate environ directly */
-    register I32 i=setenv_getix(nam);          /* where does it go? */
+    register I32 i;
+    register const I32 len = strlen(nam);
     int nlen, vlen;
 
     int nlen, vlen;
 
-    if (environ == PL_origenviron) {   /* need we copy environment? */
-       I32 j;
-       I32 max;
-       char **tmpenv;
-
-       for (max = i; environ[max]; max++) ;
-       tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
-       for (j=0; j<max; j++) {         /* copy environment */
-           const int len = strlen(environ[j]);
-           tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
-           Copy(environ[j], tmpenv[j], len+1, char);
-       }
-       tmpenv[max] = NULL;
-       environ = tmpenv;               /* tell exec where it is now */
+    /* where does it go? */
+    for (i = 0; environ[i]; i++) {
+        if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
+            break;
+    }
+
+    if (environ == PL_origenviron) {   /* need we copy environment? */
+       I32 j;
+       I32 max;
+       char **tmpenv;
+
+       max = i;
+       while (environ[max])
+           max++;
+       tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
+       for (j=0; j<max; j++) {         /* copy environment */
+           const int len = strlen(environ[j]);
+           tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
+           Copy(environ[j], tmpenv[j], len+1, char);
+       }
+       tmpenv[max] = NULL;
+       environ = tmpenv;               /* tell exec where it is now */
     }
     if (!val) {
     }
     if (!val) {
-       safesysfree(environ[i]);
-       while (environ[i]) {
-           environ[i] = environ[i+1];
-           i++;
+       safesysfree(environ[i]);
+       while (environ[i]) {
+           environ[i] = environ[i+1];
+           i++;
        }
        }
-       return;
+       return;
     }
     }
-    if (!environ[i]) {                 /* does not exist yet */
-       environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
-       environ[i+1] = NULL;    /* make sure it's null terminated */
+    if (!environ[i]) {                 /* does not exist yet */
+       environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
+       environ[i+1] = NULL;    /* make sure it's null terminated */
     }
     else
     }
     else
-       safesysfree(environ[i]);
-    nlen = strlen(nam);
-    vlen = strlen(val);
+       safesysfree(environ[i]);
+       nlen = strlen(nam);
+       vlen = strlen(val);
 
 
-    environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
-    /* all that work just for this */
-    my_setenv_format(environ[i], nam, nlen, val, vlen);
+       environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
+       /* all that work just for this */
+       my_setenv_format(environ[i], nam, nlen, val, vlen);
     } else {
 # endif
     } else {
 # endif
-#   if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__)
+#   if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
 #       if defined(HAS_UNSETENV)
         if (val == NULL) {
             (void)unsetenv(nam);
 #       if defined(HAS_UNSETENV)
         if (val == NULL) {
             (void)unsetenv(nam);
@@ -1642,7 +1765,7 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
     int vlen;
 
     if (!val) {
     int vlen;
 
     if (!val) {
-       val = "";
+       val = "";
     }
     vlen = strlen(val);
     Newx(envstr, nlen+vlen+2, char);
     }
     vlen = strlen(val);
     Newx(envstr, nlen+vlen+2, char);
@@ -1653,37 +1776,19 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
 
 #endif /* WIN32 || NETWARE */
 
 
 #endif /* WIN32 || NETWARE */
 
-#ifndef PERL_MICRO
-I32
-Perl_setenv_getix(pTHX_ const char *nam)
-{
-    register I32 i;
-    register const I32 len = strlen(nam);
-
-    for (i = 0; environ[i]; i++) {
-       if (
-#ifdef WIN32
-           strnicmp(environ[i],nam,len) == 0
-#else
-           strnEQ(environ[i],nam,len)
-#endif
-           && environ[i][len] == '=')
-           break;                      /* strnEQ must come first to avoid */
-    }                                  /* potential SEGV's */
-    return i;
-}
-#endif /* !PERL_MICRO */
-
 #endif /* !VMS && !EPOC*/
 
 #ifdef UNLINK_ALL_VERSIONS
 I32
 Perl_unlnk(pTHX_ const char *f)        /* unlink all versions of a file */
 {
 #endif /* !VMS && !EPOC*/
 
 #ifdef UNLINK_ALL_VERSIONS
 I32
 Perl_unlnk(pTHX_ const char *f)        /* unlink all versions of a file */
 {
-    I32 i;
+    I32 retries = 0;
 
 
-    for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
-    return i ? 0 : -1;
+    PERL_ARGS_ASSERT_UNLNK;
+
+    while (PerlLIO_unlink(f) >= 0)
+       retries++;
+    return retries ? 0 : -1;
 }
 #endif
 
 }
 #endif
 
@@ -1694,6 +1799,8 @@ Perl_my_bcopy(register const char *from,register char *to,register I32 len)
 {
     char * const retval = to;
 
 {
     char * const retval = to;
 
+    PERL_ARGS_ASSERT_MY_BCOPY;
+
     if (from - to >= 0) {
        while (len--)
            *to++ = *from++;
     if (from - to >= 0) {
        while (len--)
            *to++ = *from++;
@@ -1715,6 +1822,8 @@ Perl_my_memset(register char *loc, register I32 ch, register I32 len)
 {
     char * const retval = loc;
 
 {
     char * const retval = loc;
 
+    PERL_ARGS_ASSERT_MY_MEMSET;
+
     while (len--)
        *loc++ = ch;
     return retval;
     while (len--)
        *loc++ = ch;
     return retval;
@@ -1728,6 +1837,8 @@ Perl_my_bzero(register char *loc, register I32 len)
 {
     char * const retval = loc;
 
 {
     char * const retval = loc;
 
+    PERL_ARGS_ASSERT_MY_BZERO;
+
     while (len--)
        *loc++ = 0;
     return retval;
     while (len--)
        *loc++ = 0;
     return retval;
@@ -1743,6 +1854,8 @@ Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
     register const U8 *b = (const U8 *)s2;
     register I32 tmp;
 
     register const U8 *b = (const U8 *)s2;
     register I32 tmp;
 
+    PERL_ARGS_ASSERT_MY_MEMCMP;
+
     while (len--) {
         if ((tmp = *a++ - *b++))
            return tmp;
     while (len--) {
         if ((tmp = *a++ - *b++))
            return tmp;
@@ -1752,24 +1865,51 @@ Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
 
 #ifndef HAS_VPRINTF
 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
 
 #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
 
 #ifdef USE_CHAR_VSPRINTF
 char *
 #else
 int
 #endif
-vsprintf(char *dest, const char *pat, char *args)
+vsprintf(char *dest, const char *pat, void *args)
 {
     FILE fakebuf;
 
 {
     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;
     fakebuf._ptr = dest;
     fakebuf._cnt = 32767;
+#endif
 #ifndef _IOSTRG
 #define _IOSTRG 0
 #endif
     fakebuf._flag = _IOWRT|_IOSTRG;
     _doprnt(pat, args, &fakebuf);      /* what a kludge */
 #ifndef _IOSTRG
 #define _IOSTRG 0
 #endif
     fakebuf._flag = _IOWRT|_IOSTRG;
     _doprnt(pat, args, &fakebuf);      /* what a kludge */
-    (void)putc('\0', &fakebuf);
+#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
 #ifdef USE_CHAR_VSPRINTF
     return(dest);
 #else
@@ -1802,7 +1942,10 @@ Perl_my_htonl(pTHX_ long l)
        char c[sizeof(long)];
     } u;
 
        char c[sizeof(long)];
     } u;
 
-#if BYTEORDER == 0x1234
+#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
+#if BYTEORDER == 0x12345678
+    u.result = 0; 
+#endif 
     u.c[0] = (l >> 24) & 255;
     u.c[1] = (l >> 16) & 255;
     u.c[2] = (l >> 8) & 255;
     u.c[0] = (l >> 24) & 255;
     u.c[1] = (l >> 16) & 255;
     u.c[2] = (l >> 8) & 255;
@@ -1873,8 +2016,8 @@ Perl_my_ntohl(pTHX_ long l)
                type value;                                     \
                char c[sizeof(type)];                           \
            } u;                                                \
                type value;                                     \
                char c[sizeof(type)];                           \
            } u;                                                \
-           register I32 i;                                     \
-           register I32 s = 0;                                 \
+           register U32 i;                                     \
+           register U32 s = 0;                                 \
            for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
                u.c[i] = (n >> s) & 0xFF;                       \
            }                                                   \
            for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
                u.c[i] = (n >> s) & 0xFF;                       \
            }                                                   \
@@ -1889,8 +2032,8 @@ Perl_my_ntohl(pTHX_ long l)
                type value;                                     \
                char c[sizeof(type)];                           \
            } u;                                                \
                type value;                                     \
                char c[sizeof(type)];                           \
            } u;                                                \
-           register I32 i;                                     \
-           register I32 s = 0;                                 \
+           register U32 i;                                     \
+           register U32 s = 0;                                 \
            u.value = n;                                        \
            n = 0;                                              \
            for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
            u.value = n;                                        \
            n = 0;                                              \
            for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
@@ -1911,8 +2054,8 @@ Perl_my_ntohl(pTHX_ long l)
                type value;                                     \
                char c[sizeof(type)];                           \
            } u;                                                \
                type value;                                     \
                char c[sizeof(type)];                           \
            } u;                                                \
-           register I32 i;                                     \
-           register I32 s = 8*(sizeof(u.c)-1);                 \
+           register U32 i;                                     \
+           register U32 s = 8*(sizeof(u.c)-1);                 \
            for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
                u.c[i] = (n >> s) & 0xFF;                       \
            }                                                   \
            for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
                u.c[i] = (n >> s) & 0xFF;                       \
            }                                                   \
@@ -1927,8 +2070,8 @@ Perl_my_ntohl(pTHX_ long l)
                type value;                                     \
                char c[sizeof(type)];                           \
            } u;                                                \
                type value;                                     \
                char c[sizeof(type)];                           \
            } u;                                                \
-           register I32 i;                                     \
-           register I32 s = 8*(sizeof(u.c)-1);                 \
+           register U32 i;                                     \
+           register U32 s = 8*(sizeof(u.c)-1);                 \
            u.value = n;                                        \
            n = 0;                                              \
            for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
            u.value = n;                                        \
            n = 0;                                              \
            for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
@@ -2096,6 +2239,8 @@ Perl_my_swabn(void *ptr, int n)
     register char *e = s + (n-1);
     register char tc;
 
     register char *e = s + (n-1);
     register char tc;
 
+    PERL_ARGS_ASSERT_MY_SWABN;
+
     for (n /= 2; n > 0; s++, e--, n--) {
       tc = *s;
       *s = *e;
     for (n /= 2; n > 0; s++, e--, n--) {
       tc = *s;
       *s = *e;
@@ -2104,9 +2249,9 @@ Perl_my_swabn(void *ptr, int n)
 }
 
 PerlIO *
 }
 
 PerlIO *
-Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
+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(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
     dVAR;
     int p[2];
     register I32 This, that;
     dVAR;
     int p[2];
     register I32 This, that;
@@ -2115,6 +2260,8 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
     I32 did_pipes = 0;
     int pp[2];
 
     I32 did_pipes = 0;
     int pp[2];
 
+    PERL_ARGS_ASSERT_MY_POPEN_LIST;
+
     PERL_FLUSHALL_FOR_CHILD;
     This = (*mode == 'w');
     that = !This;
     PERL_FLUSHALL_FOR_CHILD;
     This = (*mode == 'w');
     that = !This;
@@ -2137,6 +2284,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
            }
            return NULL;
        }
            }
            return NULL;
        }
+       Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
        sleep(5);
     }
     if (pid == 0) {
        sleep(5);
     }
     if (pid == 0) {
@@ -2194,16 +2342,15 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
     else
        PerlLIO_close(p[that]);         /* close child's end of pipe */
 
     else
        PerlLIO_close(p[that]);         /* close child's end of pipe */
 
-    LOCK_FDPID_MUTEX;
     sv = *av_fetch(PL_fdpid,p[This],TRUE);
     sv = *av_fetch(PL_fdpid,p[This],TRUE);
-    UNLOCK_FDPID_MUTEX;
     SvUPGRADE(sv,SVt_IV);
     SvIV_set(sv, pid);
     PL_forkprocess = pid;
     /* If we managed to get status pipe check for exec fail */
     if (did_pipes && pid > 0) {
        int errkid;
     SvUPGRADE(sv,SVt_IV);
     SvIV_set(sv, pid);
     PL_forkprocess = pid;
     /* If we managed to get status pipe check for exec fail */
     if (did_pipes && pid > 0) {
        int errkid;
-       int n = 0, n1;
+       unsigned n = 0;
+       SSize_t n1;
 
        while (n < sizeof(int)) {
            n1 = PerlLIO_read(pp[0],
 
        while (n < sizeof(int)) {
            n1 = PerlLIO_read(pp[0],
@@ -2231,13 +2378,17 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
         PerlLIO_close(pp[0]);
     return PerlIO_fdopen(p[This], mode);
 #else
         PerlLIO_close(pp[0]);
     return PerlIO_fdopen(p[This], mode);
 #else
+#  ifdef OS2   /* Same, without fork()ing and all extra overhead... */
+    return my_syspopen4(aTHX_ NULL, mode, n, args);
+#  else
     Perl_croak(aTHX_ "List form of piped open not implemented");
     return (PerlIO *) NULL;
     Perl_croak(aTHX_ "List form of piped open not implemented");
     return (PerlIO *) NULL;
+#  endif
 #endif
 }
 
     /* VMS' my_popen() is in VMS.c, same with OS/2. */
 #endif
 }
 
     /* VMS' my_popen() is in VMS.c, same with OS/2. */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
 PerlIO *
 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 {
 PerlIO *
 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 {
@@ -2250,6 +2401,8 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
     I32 did_pipes = 0;
     int pp[2];
 
     I32 did_pipes = 0;
     int pp[2];
 
+    PERL_ARGS_ASSERT_MY_POPEN;
+
     PERL_FLUSHALL_FOR_CHILD;
 #ifdef OS2
     if (doexec) {
     PERL_FLUSHALL_FOR_CHILD;
 #ifdef OS2
     if (doexec) {
@@ -2275,9 +2428,10 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
                PerlLIO_close(pp[1]);
            }
            if (!doexec)
                PerlLIO_close(pp[1]);
            }
            if (!doexec)
-               Perl_croak(aTHX_ "Can't fork");
+               Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
            return NULL;
        }
            return NULL;
        }
+       Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
        sleep(5);
     }
     if (pid == 0) {
        sleep(5);
     }
     if (pid == 0) {
@@ -2320,6 +2474,14 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
            PerlProc__exit(1);
        }
 #endif /* defined OS2 */
            PerlProc__exit(1);
        }
 #endif /* defined OS2 */
+
+#ifdef PERLIO_USING_CRLF
+   /* Since we circumvent IO layers when we manipulate low-level
+      filedescriptors directly, need to manually switch to the
+      default, binary, low-level mode; see PerlIOBuf_open(). */
+   PerlLIO_setmode((*mode == 'r'), O_BINARY);
+#endif 
+
        if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
            SvREADONLY_off(GvSV(tmpgv));
            sv_setiv(GvSV(tmpgv), PerlProc_getpid());
        if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
            SvREADONLY_off(GvSV(tmpgv));
            sv_setiv(GvSV(tmpgv), PerlProc_getpid());
@@ -2347,15 +2509,14 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
     else
        PerlLIO_close(p[that]);
 
     else
        PerlLIO_close(p[that]);
 
-    LOCK_FDPID_MUTEX;
     sv = *av_fetch(PL_fdpid,p[This],TRUE);
     sv = *av_fetch(PL_fdpid,p[This],TRUE);
-    UNLOCK_FDPID_MUTEX;
     SvUPGRADE(sv,SVt_IV);
     SvIV_set(sv, pid);
     PL_forkprocess = pid;
     if (did_pipes && pid > 0) {
        int errkid;
     SvUPGRADE(sv,SVt_IV);
     SvIV_set(sv, pid);
     PL_forkprocess = pid;
     if (did_pipes && pid > 0) {
        int errkid;
-       int n = 0, n1;
+       unsigned n = 0;
+       SSize_t n1;
 
        while (n < sizeof(int)) {
            n1 = PerlLIO_read(pp[0],
 
        while (n < sizeof(int)) {
            n1 = PerlLIO_read(pp[0],
@@ -2387,8 +2548,9 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 #if defined(atarist) || defined(EPOC)
 FILE *popen();
 PerlIO *
 #if defined(atarist) || defined(EPOC)
 FILE *popen();
 PerlIO *
-Perl_my_popen(pTHX_ char *cmd, char *mode)
+Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 {
 {
+    PERL_ARGS_ASSERT_MY_POPEN;
     PERL_FLUSHALL_FOR_CHILD;
     /* Call system's popen() to get a FILE *, then import it.
        used 0 for 2nd parameter to PerlIO_importFILE;
     PERL_FLUSHALL_FOR_CHILD;
     /* Call system's popen() to get a FILE *, then import it.
        used 0 for 2nd parameter to PerlIO_importFILE;
@@ -2400,7 +2562,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
 #if defined(DJGPP)
 FILE *djgpp_popen();
 PerlIO *
 #if defined(DJGPP)
 FILE *djgpp_popen();
 PerlIO *
-Perl_my_popen(pTHX_ char *cmd, char *mode)
+Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 {
     PERL_FLUSHALL_FOR_CHILD;
     /* Call system's popen() to get a FILE *, then import it.
 {
     PERL_FLUSHALL_FOR_CHILD;
     /* Call system's popen() to get a FILE *, then import it.
@@ -2409,6 +2571,14 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
     */
     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
 }
     */
     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
 }
+#else
+#if defined(__LIBCATAMOUNT__)
+PerlIO *
+Perl_my_popen(pTHX_ const char *cmd, const char *mode)
+{
+    return NULL;
+}
+#endif
 #endif
 #endif
 
 #endif
 #endif
 
@@ -2466,11 +2636,13 @@ Perl_my_fork(void)
 
 #ifdef DUMP_FDS
 void
 
 #ifdef DUMP_FDS
 void
-Perl_dump_fds(pTHX_ char *s)
+Perl_dump_fds(pTHX_ const char *const s)
 {
     int fd;
     Stat_t tmpstatbuf;
 
 {
     int fd;
     Stat_t tmpstatbuf;
 
+    PERL_ARGS_ASSERT_DUMP_FDS;
+
     PerlIO_printf(Perl_debug_log,"%s", s);
     for (fd = 0; fd < 32; fd++) {
        if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
     PerlIO_printf(Perl_debug_log,"%s", s);
     for (fd = 0; fd < 32; fd++) {
        if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
@@ -2518,11 +2690,6 @@ dup2(int oldfd, int newfd)
 #ifndef PERL_MICRO
 #ifdef HAS_SIGACTION
 
 #ifndef PERL_MICRO
 #ifdef HAS_SIGACTION
 
-#ifdef MACOS_TRADITIONAL
-/* We don't want restart behavior on MacOS */
-#undef SA_RESTART
-#endif
-
 Sighandler_t
 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
 {
 Sighandler_t
 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
 {
@@ -2556,6 +2723,7 @@ Sighandler_t
 Perl_rsignal_state(pTHX_ int signo)
 {
     struct sigaction oact;
 Perl_rsignal_state(pTHX_ int signo)
 {
     struct sigaction oact;
+    PERL_UNUSED_CONTEXT;
 
     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
        return (Sighandler_t) SIG_ERR;
 
     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
        return (Sighandler_t) SIG_ERR;
@@ -2569,6 +2737,8 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
     dVAR;
     struct sigaction act;
 
     dVAR;
     struct sigaction act;
 
+    PERL_ARGS_ASSERT_RSIGNAL_SAVE;
+
 #ifdef USE_ITHREADS
     /* only "parent" interpreter can diddle signals */
     if (PL_curinterp != aTHX)
 #ifdef USE_ITHREADS
     /* only "parent" interpreter can diddle signals */
     if (PL_curinterp != aTHX)
@@ -2670,7 +2840,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(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
 I32
 Perl_my_pclose(pTHX_ PerlIO *ptr)
 {
 I32
 Perl_my_pclose(pTHX_ PerlIO *ptr)
 {
@@ -2681,14 +2851,9 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
     Pid_t pid;
     Pid_t pid2;
     bool close_failed;
     Pid_t pid;
     Pid_t pid2;
     bool close_failed;
-    int saved_errno = 0;
-#ifdef WIN32
-    int saved_win32_errno;
-#endif
+    dSAVEDERRNO;
 
 
-    LOCK_FDPID_MUTEX;
     svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
     svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
-    UNLOCK_FDPID_MUTEX;
     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
     SvREFCNT_dec(*svp);
     *svp = &PL_sv_undef;
     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
     SvREFCNT_dec(*svp);
     *svp = &PL_sv_undef;
@@ -2697,12 +2862,8 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
        return my_syspclose(ptr);
     }
 #endif
        return my_syspclose(ptr);
     }
 #endif
-    if ((close_failed = (PerlIO_close(ptr) == EOF))) {
-       saved_errno = errno;
-#ifdef WIN32
-       saved_win32_errno = GetLastError();
-#endif
-    }
+    close_failed = (PerlIO_close(ptr) == EOF);
+    SAVE_ERRNO;
 #ifdef UTS
     if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
 #endif
 #ifdef UTS
     if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
 #endif
@@ -2720,19 +2881,28 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
     rsignal_restore(SIGQUIT, &qstat);
 #endif
     if (close_failed) {
     rsignal_restore(SIGQUIT, &qstat);
 #endif
     if (close_failed) {
-       SETERRNO(saved_errno, 0);
+       RESTORE_ERRNO;
        return -1;
     }
     return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
 }
        return -1;
     }
     return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
 }
+#else
+#if defined(__LIBCATAMOUNT__)
+I32
+Perl_my_pclose(pTHX_ PerlIO *ptr)
+{
+    return -1;
+}
+#endif
 #endif /* !DOSISH */
 
 #endif /* !DOSISH */
 
-#if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
+#if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
 I32
 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 {
     dVAR;
     I32 result = 0;
 I32
 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 {
     dVAR;
     I32 result = 0;
+    PERL_ARGS_ASSERT_WAIT4PID;
     if (!pid)
        return -1;
 #ifdef PERL_USES_PL_PIDSTATUS
     if (!pid)
        return -1;
 #ifdef PERL_USES_PL_PIDSTATUS
@@ -2805,6 +2975,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 #endif
     if (result < 0 && errno == EINTR) {
        PERL_ASYNC_CHECK();
 #endif
     if (result < 0 && errno == EINTR) {
        PERL_ASYNC_CHECK();
+       errno = EINTR; /* reset in case a signal handler changed $! */
     }
     return result;
 }
     }
     return result;
 }
@@ -2812,7 +2983,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 
 #ifdef PERL_USES_PL_PIDSTATUS
 void
 
 #ifdef PERL_USES_PL_PIDSTATUS
 void
-Perl_pidgone(pTHX_ Pid_t pid, int status)
+S_pidgone(pTHX_ Pid_t pid, int status)
 {
     register SV *sv;
 
 {
     register SV *sv;
 
@@ -2856,23 +3027,36 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
 }
 #endif
 
 }
 #endif
 
+#define PERL_REPEATCPY_LINEAR 4
 void
 void
-Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
+Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
 {
 {
-    register I32 todo;
-    register const char * const frombase = from;
+    PERL_ARGS_ASSERT_REPEATCPY;
+
+    if (len == 1)
+       memset(to, *from, count);
+    else if (count) {
+       register char *p = to;
+       I32 items, linear, half;
+
+       linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
+       for (items = 0; items < linear; ++items) {
+           register const char *q = from;
+           I32 todo;
+           for (todo = len; todo > 0; todo--)
+               *p++ = *q++;
+        }
 
 
-    if (len == 1) {
-       register const char c = *from;
-       while (count-- > 0)
-           *to++ = c;
-       return;
-    }
-    while (count-- > 0) {
-       for (todo = len; todo > 0; todo--) {
-           *to++ = *from++;
+       half = count / 2;
+       while (items <= half) {
+           I32 size = items * len;
+           memcpy(p, to, size);
+           p     += size;
+           items *= 2;
        }
        }
-       from = frombase;
+
+       if (count > items)
+           memcpy(p, to, (count - items) * len);
     }
 }
 
     }
 }
 
@@ -2886,6 +3070,8 @@ Perl_same_dirent(pTHX_ const char *a, const char *b)
     Stat_t tmpstatbuf2;
     SV * const tmpsv = sv_newmortal();
 
     Stat_t tmpstatbuf2;
     SV * const tmpsv = sv_newmortal();
 
+    PERL_ARGS_ASSERT_SAME_DIRENT;
+
     if (fa)
        fa++;
     else
     if (fa)
        fa++;
     else
@@ -2897,13 +3083,13 @@ Perl_same_dirent(pTHX_ const char *a, const char *b)
     if (strNE(a,b))
        return FALSE;
     if (fa == a)
     if (strNE(a,b))
        return FALSE;
     if (fa == a)
-       sv_setpvn(tmpsv, ".", 1);
+       sv_setpvs(tmpsv, ".");
     else
        sv_setpvn(tmpsv, a, fa - a);
     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
        return FALSE;
     if (fb == b)
     else
        sv_setpvn(tmpsv, a, fa - a);
     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
        return FALSE;
     if (fb == b)
-       sv_setpvn(tmpsv, ".", 1);
+       sv_setpvs(tmpsv, ".");
     else
        sv_setpvn(tmpsv, b, fb - b);
     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
     else
        sv_setpvn(tmpsv, b, fb - b);
     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
@@ -2924,6 +3110,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
     register char *s;
     I32 len = 0;
     int retval;
     register char *s;
     I32 len = 0;
     int retval;
+    char *bufend;
 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
 #  define SEARCH_EXTS ".bat", ".cmd", NULL
 #  define MAX_EXT_LEN 4
 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
 #  define SEARCH_EXTS ".bat", ".cmd", NULL
 #  define MAX_EXT_LEN 4
@@ -2947,6 +3134,8 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
 #  define MAX_EXT_LEN 0
 #endif
 
 #  define MAX_EXT_LEN 0
 #endif
 
+    PERL_ARGS_ASSERT_FIND_SCRIPT;
+
     /*
      * If dosearch is true and if scriptname does not contain path
      * delimiters, search the PATH for scriptname.
     /*
      * If dosearch is true and if scriptname does not contain path
      * delimiters, search the PATH for scriptname.
@@ -2994,7 +3183,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
            if ((strlen(tmpbuf) + strlen(scriptname)
                 + MAX_EXT_LEN) >= sizeof tmpbuf)
                continue;       /* don't search dir with too-long name */
            if ((strlen(tmpbuf) + strlen(scriptname)
                 + MAX_EXT_LEN) >= sizeof tmpbuf)
                continue;       /* don't search dir with too-long name */
-           strcat(tmpbuf, scriptname);
+           my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
 #else  /* !VMS */
 
 #ifdef DOSISH
 #else  /* !VMS */
 
 #ifdef DOSISH
@@ -3026,35 +3215,25 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
                len = strlen(scriptname);
                if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
                    break;
                len = strlen(scriptname);
                if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
                    break;
-               /* FIXME? Convert to memcpy  */
-               cur = strcpy(tmpbuf, scriptname);
+               my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
+               cur = tmpbuf;
            }
        } while (extidx >= 0 && ext[extidx]     /* try an extension? */
            }
        } while (extidx >= 0 && ext[extidx]     /* try an extension? */
-                && strcpy(tmpbuf+len, ext[extidx++]));
+                && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
 #endif
     }
 #endif
 
 #endif
     }
 #endif
 
-#ifdef MACOS_TRADITIONAL
-    if (dosearch && !strchr(scriptname, ':') &&
-       (s = PerlEnv_getenv("Commands")))
-#else
     if (dosearch && !strchr(scriptname, '/')
 #ifdef DOSISH
                 && !strchr(scriptname, '\\')
 #endif
                 && (s = PerlEnv_getenv("PATH")))
     if (dosearch && !strchr(scriptname, '/')
 #ifdef DOSISH
                 && !strchr(scriptname, '\\')
 #endif
                 && (s = PerlEnv_getenv("PATH")))
-#endif
     {
        bool seen_dot = 0;
 
     {
        bool seen_dot = 0;
 
-       PL_bufend = s + strlen(s);
-       while (s < PL_bufend) {
-#ifdef MACOS_TRADITIONAL
-           s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
-                       ',',
-                       &len);
-#else
+       bufend = s + strlen(s);
+       while (s < bufend) {
 #if defined(atarist) || defined(DOSISH)
            for (len = 0; *s
 #  ifdef atarist
 #if defined(atarist) || defined(DOSISH)
            for (len = 0; *s
 #  ifdef atarist
@@ -3067,21 +3246,16 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
            if (len < sizeof tmpbuf)
                tmpbuf[len] = '\0';
 #else  /* ! (atarist || DOSISH) */
            if (len < sizeof tmpbuf)
                tmpbuf[len] = '\0';
 #else  /* ! (atarist || DOSISH) */
-           s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
+           s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
                        ':',
                        &len);
 #endif /* ! (atarist || DOSISH) */
                        ':',
                        &len);
 #endif /* ! (atarist || DOSISH) */
-#endif /* MACOS_TRADITIONAL */
-           if (s < PL_bufend)
+           if (s < bufend)
                s++;
            if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
                continue;       /* don't search dir with too-long name */
                s++;
            if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
                continue;       /* don't search dir with too-long name */
-#ifdef MACOS_TRADITIONAL
-           if (len && tmpbuf[len - 1] != ':')
-               tmpbuf[len++] = ':';
-#else
            if (len
            if (len
-#  if defined(atarist) || defined(__MINT__) || defined(DOSISH)
+#  if defined(atarist) || defined(DOSISH)
                && tmpbuf[len - 1] != '/'
                && tmpbuf[len - 1] != '\\'
 #  endif
                && tmpbuf[len - 1] != '/'
                && tmpbuf[len - 1] != '\\'
 #  endif
@@ -3089,10 +3263,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
                tmpbuf[len++] = '/';
            if (len == 2 && tmpbuf[0] == '.')
                seen_dot = 1;
                tmpbuf[len++] = '/';
            if (len == 2 && tmpbuf[0] == '.')
                seen_dot = 1;
-#endif
-           /* FIXME? Convert to memcpy by storing previous strlen(scriptname)
-            */
-           (void)strcpy(tmpbuf + len, scriptname);
+           (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
 #endif  /* !VMS */
 
 #ifdef SEARCH_EXTS
 #endif  /* !VMS */
 
 #ifdef SEARCH_EXTS
@@ -3109,14 +3280,14 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
 #ifdef SEARCH_EXTS
            } while (  retval < 0               /* not there */
                    && extidx>=0 && ext[extidx] /* try an extension? */
 #ifdef SEARCH_EXTS
            } while (  retval < 0               /* not there */
                    && extidx>=0 && ext[extidx] /* try an extension? */
-                   && strcpy(tmpbuf+len, ext[extidx++])
+                   && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
                );
 #endif
            if (retval < 0)
                continue;
            if (S_ISREG(PL_statbuf.st_mode)
                && cando(S_IRUSR,TRUE,&PL_statbuf)
                );
 #endif
            if (retval < 0)
                continue;
            if (S_ISREG(PL_statbuf.st_mode)
                && cando(S_IRUSR,TRUE,&PL_statbuf)
-#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
+#if !defined(DOSISH)
                && cando(S_IXUSR,TRUE,&PL_statbuf)
 #endif
                )
                && cando(S_IXUSR,TRUE,&PL_statbuf)
 #endif
                )
@@ -3177,6 +3348,7 @@ void
 Perl_set_context(void *t)
 {
     dVAR;
 Perl_set_context(void *t)
 {
     dVAR;
+    PERL_ARGS_ASSERT_SET_CONTEXT;
 #if defined(USE_ITHREADS)
 #  ifdef I_MACH_CTHREADS
     cthread_set_data(cthread_self(), t);
 #if defined(USE_ITHREADS)
 #  ifdef I_MACH_CTHREADS
     cthread_set_data(cthread_self(), t);
@@ -3202,32 +3374,37 @@ Perl_GetVars(pTHX)
 char **
 Perl_get_op_names(pTHX)
 {
 char **
 Perl_get_op_names(pTHX)
 {
- return (char **)PL_op_name;
+    PERL_UNUSED_CONTEXT;
+    return (char **)PL_op_name;
 }
 
 char **
 Perl_get_op_descs(pTHX)
 {
 }
 
 char **
 Perl_get_op_descs(pTHX)
 {
- return (char **)PL_op_desc;
+    PERL_UNUSED_CONTEXT;
+    return (char **)PL_op_desc;
 }
 
 const char *
 Perl_get_no_modify(pTHX)
 {
 }
 
 const char *
 Perl_get_no_modify(pTHX)
 {
- return PL_no_modify;
+    PERL_UNUSED_CONTEXT;
+    return PL_no_modify;
 }
 
 U32 *
 Perl_get_opargs(pTHX)
 {
 }
 
 U32 *
 Perl_get_opargs(pTHX)
 {
- return (U32 *)PL_opargs;
+    PERL_UNUSED_CONTEXT;
+    return (U32 *)PL_opargs;
 }
 
 PPADDR_t*
 Perl_get_ppaddr(pTHX)
 {
 }
 
 PPADDR_t*
 Perl_get_ppaddr(pTHX)
 {
- dVAR;
- return (PPADDR_t*)PL_ppaddr;
+    dVAR;
+    PERL_UNUSED_CONTEXT;
+    return (PPADDR_t*)PL_ppaddr;
 }
 
 #ifndef HAS_GETENV_LEN
 }
 
 #ifndef HAS_GETENV_LEN
@@ -3235,6 +3412,8 @@ char *
 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
 {
     char * const env_trans = PerlEnv_getenv(env_elem);
 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
 {
     char * const env_trans = PerlEnv_getenv(env_elem);
+    PERL_UNUSED_CONTEXT;
+    PERL_ARGS_ASSERT_GETENV_LEN;
     if (env_trans)
        *len = strlen(env_trans);
     return env_trans;
     if (env_trans)
        *len = strlen(env_trans);
     return env_trans;
@@ -3246,6 +3425,7 @@ MGVTBL*
 Perl_get_vtbl(pTHX_ int vtbl_id)
 {
     const MGVTBL* result;
 Perl_get_vtbl(pTHX_ int vtbl_id)
 {
     const MGVTBL* result;
+    PERL_UNUSED_CONTEXT;
 
     switch(vtbl_id) {
     case want_vtbl_sv:
 
     switch(vtbl_id) {
     case want_vtbl_sv:
@@ -3281,9 +3461,6 @@ Perl_get_vtbl(pTHX_ int vtbl_id)
     case want_vtbl_arylen:
        result = &PL_vtbl_arylen;
        break;
     case want_vtbl_arylen:
        result = &PL_vtbl_arylen;
        break;
-    case want_vtbl_glob:
-       result = &PL_vtbl_glob;
-       break;
     case want_vtbl_mglob:
        result = &PL_vtbl_mglob;
        break;
     case want_vtbl_mglob:
        result = &PL_vtbl_mglob;
        break;
@@ -3400,19 +3577,12 @@ Perl_my_fflush_all(pTHX)
 void
 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
 {
 void
 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
 {
-    const char * const func =
-       op == OP_READLINE   ? "readline"  :     /* "<HANDLE>" not nice */
-       op == OP_LEAVEWRITE ? "write" :         /* "write exit" not nice */
-       PL_op_desc[op];
-    const char * const pars = OP_IS_FILETEST(op) ? "" : "()";
-    const char * const type = OP_IS_SOCKET(op)
-           || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
-               ?  "socket" : "filehandle";
     const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
 
     if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
        if (ckWARN(WARN_IO)) {
     const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
 
     if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
        if (ckWARN(WARN_IO)) {
-           const char * const direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
+           const char * const direction =
+               (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
            if (name && *name)
                Perl_warner(aTHX_ packWARN(WARN_IO),
                            "Filehandle %s opened only for %sput",
            if (name && *name)
                Perl_warner(aTHX_ packWARN(WARN_IO),
                            "Filehandle %s opened only for %sput",
@@ -3436,6 +3606,19 @@ Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
        }
 
        if (ckWARN(warn_type)) {
        }
 
        if (ckWARN(warn_type)) {
+           const char * const pars =
+               (const char *)(OP_IS_FILETEST(op) ? "" : "()");
+           const char * const func =
+               (const char *)
+               (op == OP_READLINE   ? "readline"  :    /* "<HANDLE>" not nice */
+                op == OP_LEAVEWRITE ? "write" :                /* "write exit" not nice */
+                op < 0              ? "" :              /* handle phoney cases */
+                PL_op_desc[op]);
+           const char * const type =
+               (const char *)
+               (OP_IS_SOCKET(op) ||
+                (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
+                "socket" : "filehandle");
            if (name && *name) {
                Perl_warner(aTHX_ packWARN(warn_type),
                            "%s%s on %s %s %s", func, pars, vile, type, name);
            if (name && *name) {
                Perl_warner(aTHX_ packWARN(warn_type),
                            "%s%s on %s %s %s", func, pars, vile, type, name);
@@ -3528,11 +3711,13 @@ Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
 #ifdef HAS_TM_TM_ZONE
     Time_t now;
     const struct tm* my_tm;
 #ifdef HAS_TM_TM_ZONE
     Time_t now;
     const struct tm* my_tm;
+    PERL_ARGS_ASSERT_INIT_TM;
     (void)time(&now);
     my_tm = localtime(&now);
     if (my_tm)
         Copy(my_tm, ptm, 1, struct tm);
 #else
     (void)time(&now);
     my_tm = localtime(&now);
     if (my_tm)
         Copy(my_tm, ptm, 1, struct tm);
 #else
+    PERL_ARGS_ASSERT_INIT_TM;
     PERL_UNUSED_ARG(ptm);
 #endif
 }
     PERL_UNUSED_ARG(ptm);
 #endif
 }
@@ -3548,6 +3733,9 @@ Perl_mini_mktime(pTHX_ struct tm *ptm)
     int secs;
     int month, mday, year, jday;
     int odd_cent, odd_year;
     int secs;
     int month, mday, year, jday;
     int odd_cent, odd_year;
+    PERL_UNUSED_CONTEXT;
+
+    PERL_ARGS_ASSERT_MINI_MKTIME;
 
 #define        DAYS_PER_YEAR   365
 #define        DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
 
 #define        DAYS_PER_YEAR   365
 #define        DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
@@ -3743,6 +3931,8 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in
   struct tm mytm;
   int len;
 
   struct tm mytm;
   int len;
 
+  PERL_ARGS_ASSERT_MY_STRFTIME;
+
   init_tm(&mytm);      /* XXX workaround - see init_tm() above */
   mytm.tm_sec = sec;
   mytm.tm_min = min;
   init_tm(&mytm);      /* XXX workaround - see init_tm() above */
   mytm.tm_sec = sec;
   mytm.tm_min = min;
@@ -3790,7 +3980,7 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in
   else {
     /* Possibly buf overflowed - try again with a bigger buf */
     const int fmtlen = strlen(fmt);
   else {
     /* Possibly buf overflowed - try again with a bigger buf */
     const int fmtlen = strlen(fmt);
-    const int bufsize = fmtlen + buflen;
+    int bufsize = fmtlen + buflen;
 
     Newx(buf, bufsize, char);
     while (buf) {
 
     Newx(buf, bufsize, char);
     while (buf) {
@@ -3803,7 +3993,8 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in
        buf = NULL;
        break;
       }
        buf = NULL;
        break;
       }
-      Renew(buf, bufsize*2, char);
+      bufsize *= 2;
+      Renew(buf, bufsize, char);
     }
     return buf;
   }
     }
     return buf;
   }
@@ -3849,6 +4040,8 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
     SvTAINTED_on(sv);
 #endif
 
     SvTAINTED_on(sv);
 #endif
 
+    PERL_ARGS_ASSERT_GETCWD_SV;
+
 #ifdef HAS_GETCWD
     {
        char buf[MAXPATHLEN];
 #ifdef HAS_GETCWD
     {
        char buf[MAXPATHLEN];
@@ -3886,6 +4079,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 
     for (;;) {
        DIR *dir;
 
     for (;;) {
        DIR *dir;
+       int namelen;
        odev = cdev;
        oino = cino;
 
        odev = cdev;
        oino = cino;
 
@@ -3908,9 +4102,9 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 
        while ((dp = PerlDir_read(dir)) != NULL) {
 #ifdef DIRNAMLEN
 
        while ((dp = PerlDir_read(dir)) != NULL) {
 #ifdef DIRNAMLEN
-           const int namelen = dp->d_namlen;
+           namelen = dp->d_namlen;
 #else
 #else
-           const int namelen = strlen(dp->d_name);
+           namelen = strlen(dp->d_name);
 #endif
            /* skip . and .. */
            if (SV_CWD_ISDOT(dp)) {
 #endif
            /* skip . and .. */
            if (SV_CWD_ISDOT(dp)) {
@@ -3986,6 +4180,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 #endif
 }
 
 #endif
 }
 
+#define VERSION_MAX 0x7FFFFFFF
 /*
 =for apidoc scan_version
 
 /*
 =for apidoc scan_version
 
@@ -3996,12 +4191,12 @@ an RV.
 Function must be called with an already existing SV like
 
     sv = newSV(0);
 Function must be called with an already existing SV like
 
     sv = newSV(0);
-    s = scan_version(s,SV *sv, bool qv);
+    s = scan_version(s, SV *sv, bool qv);
 
 Performs some preprocessing to the string to ensure that
 it has the correct characteristics of a version.  Flags the
 object if it contains an underscore (which denotes this
 
 Performs some preprocessing to the string to ensure that
 it has the correct characteristics of a version.  Flags the
 object if it contains an underscore (which denotes this
-is a alpha version).  The boolean qv denotes that the version
+is an alpha version).  The boolean qv denotes that the version
 should be interpreted as if it had multiple decimals, even if
 it doesn't.
 
 should be interpreted as if it had multiple decimals, even if
 it doesn't.
 
@@ -4017,26 +4212,28 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     int saw_period = 0;
     int alpha = 0;
     int width = 3;
     int saw_period = 0;
     int alpha = 0;
     int width = 3;
+    bool vinf = FALSE;
     AV * const av = newAV();
     SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
     AV * const av = newAV();
     SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
-    (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
 
 
-#ifndef NODEFAULT_SHAREKEYS
-    HvSHAREKEYS_on(hv);         /* key-sharing on by default */
-#endif
+    PERL_ARGS_ASSERT_SCAN_VERSION;
+
+    (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
 
     while (isSPACE(*s)) /* leading whitespace is OK */
        s++;
 
 
     while (isSPACE(*s)) /* leading whitespace is OK */
        s++;
 
+    start = last = s;
+
     if (*s == 'v') {
        s++;  /* get past 'v' */
        qv = 1; /* force quoted version processing */
     }
 
     if (*s == 'v') {
        s++;  /* get past 'v' */
        qv = 1; /* force quoted version processing */
     }
 
-    start = last = pos = s;
+    pos = s;
 
     /* pre-scan the input string to check for decimals/underbars */
 
     /* pre-scan the input string to check for decimals/underbars */
-    while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
+    while ( *pos == '.' || *pos == '_' || *pos == ',' || isDIGIT(*pos) )
     {
        if ( *pos == '.' )
        {
     {
        if ( *pos == '.' )
        {
@@ -4052,23 +4249,33 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
            alpha = 1;
            width = pos - last - 1; /* natural width of sub-version */
        }
            alpha = 1;
            width = pos - last - 1; /* natural width of sub-version */
        }
+       else if ( *pos == ',' && isDIGIT(pos[1]) )
+       {
+           saw_period++ ;
+           last = pos;
+       }
+
        pos++;
     }
 
     if ( alpha && !saw_period )
        Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
 
        pos++;
     }
 
     if ( alpha && !saw_period )
        Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
 
+    if ( alpha && saw_period && width == 0 )
+       Perl_croak(aTHX_ "Invalid version format (misplaced _ in number)");
+
     if ( saw_period > 1 )
        qv = 1; /* force quoted version processing */
 
     if ( saw_period > 1 )
        qv = 1; /* force quoted version processing */
 
+    last = pos;
     pos = s;
 
     if ( qv )
     pos = s;
 
     if ( qv )
-       hv_store((HV *)hv, "qv", 2, newSViv(qv), 0);
+       (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
     if ( alpha )
     if ( alpha )
-       hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0);
+       (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
     if ( !qv && width < 3 )
     if ( !qv && width < 3 )
-       hv_store((HV *)hv, "width", 5, newSViv(width), 0);
+       (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
     
     while (isDIGIT(*pos))
        pos++;
     
     while (isDIGIT(*pos))
        pos++;
@@ -4081,7 +4288,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
                /* this is atoi() that delimits on underscores */
                const char *end = pos;
                I32 mult = 1;
                /* this is atoi() that delimits on underscores */
                const char *end = pos;
                I32 mult = 1;
-               I32 orev;
+               I32 orev;
 
                /* the following if() will only be true after the decimal
                 * point of a version originally created with a bare
 
                /* the following if() will only be true after the decimal
                 * point of a version originally created with a bare
@@ -4090,11 +4297,17 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
                if ( !qv && s > start && saw_period == 1 ) {
                    mult *= 100;
                    while ( s < end ) {
                if ( !qv && s > start && saw_period == 1 ) {
                    mult *= 100;
                    while ( s < end ) {
-                       orev = rev;
+                       orev = rev;
                        rev += (*s - '0') * mult;
                        mult /= 10;
                        rev += (*s - '0') * mult;
                        mult /= 10;
-                       if ( PERL_ABS(orev) > PERL_ABS(rev) )
-                           Perl_croak(aTHX_ "Integer overflow in version");
+                       if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
+                           || (PERL_ABS(rev) > VERSION_MAX )) {
+                           Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
+                                          "Integer overflow in version %d",VERSION_MAX);
+                           s = end - 1;
+                           rev = VERSION_MAX;
+                           vinf = 1;
+                       }
                        s++;
                        if ( *s == '_' )
                            s++;
                        s++;
                        if ( *s == '_' )
                            s++;
@@ -4102,21 +4315,33 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
                }
                else {
                    while (--end >= s) {
                }
                else {
                    while (--end >= s) {
-                       orev = rev;
+                       orev = rev;
                        rev += (*end - '0') * mult;
                        mult *= 10;
                        rev += (*end - '0') * mult;
                        mult *= 10;
-                       if ( PERL_ABS(orev) > PERL_ABS(rev) )
-                           Perl_croak(aTHX_ "Integer overflow in version");
+                       if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
+                           || (PERL_ABS(rev) > VERSION_MAX )) {
+                           Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
+                                          "Integer overflow in version");
+                           end = s - 1;
+                           rev = VERSION_MAX;
+                           vinf = 1;
+                       }
                    }
                } 
            }
 
            /* Append revision */
            av_push(av, newSViv(rev));
                    }
                } 
            }
 
            /* Append revision */
            av_push(av, newSViv(rev));
-           if ( *pos == '.' && isDIGIT(pos[1]) )
+           if ( vinf ) {
+               s = last;
+               break;
+           }
+           else if ( *pos == '.' )
                s = ++pos;
            else if ( *pos == '_' && isDIGIT(pos[1]) )
                s = ++pos;
                s = ++pos;
            else if ( *pos == '_' && isDIGIT(pos[1]) )
                s = ++pos;
+           else if ( *pos == ',' && isDIGIT(pos[1]) )
+               s = ++pos;
            else if ( isDIGIT(*pos) )
                s = pos;
            else {
            else if ( isDIGIT(*pos) )
                s = pos;
            else {
@@ -4144,18 +4369,40 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
           Compiler in question is:
           gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
           for ( len = 2 - len; len > 0; len-- )
           Compiler in question is:
           gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
           for ( len = 2 - len; len > 0; len-- )
-          av_push((AV *)sv, newSViv(0));
+          av_push(MUTABLE_AV(sv), newSViv(0));
        */
        len = 2 - len;
        while (len-- > 0)
            av_push(av, newSViv(0));
     }
 
        */
        len = 2 - len;
        while (len-- > 0)
            av_push(av, newSViv(0));
     }
 
-    if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
+    /* need to save off the current version string for later */
+    if ( vinf ) {
+       SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
+       (void)hv_stores(MUTABLE_HV(hv), "original", orig);
+       (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
+    }
+    else if ( s > start ) {
+       SV * orig = newSVpvn(start,s-start);
+       if ( qv && saw_period == 1 && *start != 'v' ) {
+           /* need to insert a v to be consistent */
+           sv_insert(orig, 0, 0, "v", 1);
+       }
+       (void)hv_stores(MUTABLE_HV(hv), "original", orig);
+    }
+    else {
+       (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
        av_push(av, newSViv(0));
        av_push(av, newSViv(0));
+    }
 
     /* And finally, store the AV in the hash */
 
     /* And finally, store the AV in the hash */
-    hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
+    (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
+
+    /* fix RT#19517 - special case 'undef' as string */
+    if ( *s == 'u' && strEQ(s,"undef") ) {
+       s += 5;
+    }
+
     return s;
 }
 
     return s;
 }
 
@@ -4177,6 +4424,7 @@ Perl_new_version(pTHX_ SV *ver)
 {
     dVAR;
     SV * const rv = newSV(0);
 {
     dVAR;
     SV * const rv = newSV(0);
+    PERL_ARGS_ASSERT_NEW_VERSION;
     if ( sv_derived_from(ver,"version") ) /* can just copy directly */
     {
        I32 key;
     if ( sv_derived_from(ver,"version") ) /* can just copy directly */
     {
        I32 key;
@@ -4185,27 +4433,30 @@ Perl_new_version(pTHX_ SV *ver)
        /* This will get reblessed later if a derived class*/
        SV * const hv = newSVrv(rv, "version"); 
        (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
        /* This will get reblessed later if a derived class*/
        SV * const hv = newSVrv(rv, "version"); 
        (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
-#ifndef NODEFAULT_SHAREKEYS
-       HvSHAREKEYS_on(hv);         /* key-sharing on by default */
-#endif
 
        if ( SvROK(ver) )
            ver = SvRV(ver);
 
        /* Begin copying all of the elements */
 
        if ( SvROK(ver) )
            ver = SvRV(ver);
 
        /* Begin copying all of the elements */
-       if ( hv_exists((HV *)ver, "qv", 2) )
-           hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
+       if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
+           (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
 
 
-       if ( hv_exists((HV *)ver, "alpha", 5) )
-           hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
+       if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
+           (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
        
        
-       if ( hv_exists((HV*)ver, "width", 5 ) )
+       if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
+       {
+           const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
+           (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
+       }
+
+       if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
        {
        {
-           const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE));
-           hv_store((HV *)hv, "width", 5, newSViv(width), 0);
+           SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
+           (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
        }
 
        }
 
-       sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE));
+       sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
        /* This will get reblessed later if a derived class*/
        for ( key = 0; key <= av_len(sav); key++ )
        {
        /* This will get reblessed later if a derived class*/
        for ( key = 0; key <= av_len(sav); key++ )
        {
@@ -4213,16 +4464,19 @@ Perl_new_version(pTHX_ SV *ver)
            av_push(av, newSViv(rev));
        }
 
            av_push(av, newSViv(rev));
        }
 
-       hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
+       (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
        return rv;
     }
 #ifdef SvVOK
     {
        return rv;
     }
 #ifdef SvVOK
     {
-       const MAGIC* const mg = SvVOK(ver);
+       const MAGIC* const mg = SvVSTRING_mg(ver);
        if ( mg ) { /* already a v-string */
            const STRLEN len = mg->mg_len;
            char * const version = savepvn( (const char*)mg->mg_ptr, len);
            sv_setpvn(rv,version,len);
        if ( mg ) { /* already a v-string */
            const STRLEN len = mg->mg_len;
            char * const version = savepvn( (const char*)mg->mg_ptr, len);
            sv_setpvn(rv,version,len);
+           /* this is for consistency with the pure Perl class */
+           if ( *version != 'v' ) 
+               sv_insert(rv, 0, 0, "v", 1);
            Safefree(version);
        }
        else {
            Safefree(version);
        }
        else {
@@ -4232,7 +4486,7 @@ Perl_new_version(pTHX_ SV *ver)
        }
     }
 #endif
        }
     }
 #endif
-    return upg_version(rv);
+    return upg_version(rv, FALSE);
 }
 
 /*
 }
 
 /*
@@ -4240,44 +4494,84 @@ Perl_new_version(pTHX_ SV *ver)
 
 In-place upgrade of the supplied SV to a version object.
 
 
 In-place upgrade of the supplied SV to a version object.
 
-    SV *sv = upg_version(SV *sv);
+    SV *sv = upg_version(SV *sv, bool qv);
 
 
-Returns a pointer to the upgraded SV.
+Returns a pointer to the upgraded SV.  Set the boolean qv if you want
+to force this SV to be interpreted as an "extended" version.
 
 =cut
 */
 
 SV *
 
 =cut
 */
 
 SV *
-Perl_upg_version(pTHX_ SV *ver)
+Perl_upg_version(pTHX_ SV *ver, bool qv)
 {
     const char *version, *s;
 {
     const char *version, *s;
-    bool qv = 0;
 #ifdef SvVOK
     const MAGIC *mg;
 #endif
 
 #ifdef SvVOK
     const MAGIC *mg;
 #endif
 
-    if ( SvNOK(ver) ) /* may get too much accuracy */ 
+    PERL_ARGS_ASSERT_UPG_VERSION;
+
+    if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
     {
     {
+       /* may get too much accuracy */ 
        char tbuf[64];
        char tbuf[64];
-       const STRLEN len = my_sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
+#ifdef USE_LOCALE_NUMERIC
+       char *loc = setlocale(LC_NUMERIC, "C");
+#endif
+       STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
+#ifdef USE_LOCALE_NUMERIC
+       setlocale(LC_NUMERIC, loc);
+#endif
+       while (tbuf[len-1] == '0' && len > 0) len--;
+       if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
        version = savepvn(tbuf, len);
     }
 #ifdef SvVOK
        version = savepvn(tbuf, len);
     }
 #ifdef SvVOK
-    else if ( (mg = SvVOK(ver)) ) { /* already a v-string */
+    else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
        version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
        qv = 1;
     }
 #endif
     else /* must be a string or something like a string */
     {
        version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
        qv = 1;
     }
 #endif
     else /* must be a string or something like a string */
     {
-       version = savepv(SvPV_nolen(ver));
+       STRLEN len;
+       version = savepv(SvPV(ver,len));
+#ifndef SvVOK
+#  if PERL_VERSION > 5
+       /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
+       if ( len == 3 && !instr(version,".") && !instr(version,"_") ) {
+           /* may be a v-string */
+           SV * const nsv = sv_newmortal();
+           const char *nver;
+           const char *pos;
+           int saw_period = 0;
+           sv_setpvf(nsv,"v%vd",ver);
+           pos = nver = savepv(SvPV_nolen(nsv));
+
+           /* scan the resulting formatted string */
+           pos++; /* skip the leading 'v' */
+           while ( *pos == '.' || isDIGIT(*pos) ) {
+               if ( *pos == '.' )
+                   saw_period++ ;
+               pos++;
+           }
+
+           /* is definitely a v-string */
+           if ( saw_period == 2 ) {    
+               Safefree(version);
+               version = nver;
+           }
+       }
+#  endif
+#endif
     }
     }
+
     s = scan_version(version, ver, qv);
     if ( *s != '\0' ) 
     s = scan_version(version, ver, qv);
     if ( *s != '\0' ) 
-        if(ckWARN(WARN_MISC))
-           Perl_warner(aTHX_ packWARN(WARN_MISC), 
-                "Version string '%s' contains invalid data; "
-               "ignoring: '%s'", version, s);
+       Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 
+                      "Version string '%s' contains invalid data; "
+                      "ignoring: '%s'", version, s);
     Safefree(version);
     return ver;
 }
     Safefree(version);
     return ver;
 }
@@ -4309,13 +4603,16 @@ bool
 Perl_vverify(pTHX_ SV *vs)
 {
     SV *sv;
 Perl_vverify(pTHX_ SV *vs)
 {
     SV *sv;
+
+    PERL_ARGS_ASSERT_VVERIFY;
+
     if ( SvROK(vs) )
        vs = SvRV(vs);
 
     /* see if the appropriate elements exist */
     if ( SvTYPE(vs) == SVt_PVHV
     if ( SvROK(vs) )
        vs = SvRV(vs);
 
     /* see if the appropriate elements exist */
     if ( SvTYPE(vs) == SVt_PVHV
-        && hv_exists((HV*)vs, "version", 7)
-        && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE)))
+        && hv_exists(MUTABLE_HV(vs), "version", 7)
+        && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
         && SvTYPE(sv) == SVt_PVAV )
        return TRUE;
     else
         && SvTYPE(sv) == SVt_PVAV )
        return TRUE;
     else
@@ -4344,6 +4641,9 @@ Perl_vnumify(pTHX_ SV *vs)
     bool alpha = FALSE;
     SV * const sv = newSV(0);
     AV *av;
     bool alpha = FALSE;
     SV * const sv = newSV(0);
     AV *av;
+
+    PERL_ARGS_ASSERT_VNUMIFY;
+
     if ( SvROK(vs) )
        vs = SvRV(vs);
 
     if ( SvROK(vs) )
        vs = SvRV(vs);
 
@@ -4351,16 +4651,16 @@ Perl_vnumify(pTHX_ SV *vs)
        Perl_croak(aTHX_ "Invalid version object");
 
     /* see if various flags exist */
        Perl_croak(aTHX_ "Invalid version object");
 
     /* see if various flags exist */
-    if ( hv_exists((HV*)vs, "alpha", 5 ) )
+    if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
        alpha = TRUE;
        alpha = TRUE;
-    if ( hv_exists((HV*)vs, "width", 5 ) )
-       width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE));
+    if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
+       width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
     else
        width = 3;
 
 
     /* attempt to retrieve the version array */
     else
        width = 3;
 
 
     /* attempt to retrieve the version array */
-    if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) {
+    if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
        sv_catpvs(sv,"0");
        return sv;
     }
        sv_catpvs(sv,"0");
        return sv;
     }
@@ -4422,15 +4722,18 @@ Perl_vnormal(pTHX_ SV *vs)
     bool alpha = FALSE;
     SV * const sv = newSV(0);
     AV *av;
     bool alpha = FALSE;
     SV * const sv = newSV(0);
     AV *av;
+
+    PERL_ARGS_ASSERT_VNORMAL;
+
     if ( SvROK(vs) )
        vs = SvRV(vs);
 
     if ( !vverify(vs) )
        Perl_croak(aTHX_ "Invalid version object");
 
     if ( SvROK(vs) )
        vs = SvRV(vs);
 
     if ( !vverify(vs) )
        Perl_croak(aTHX_ "Invalid version object");
 
-    if ( hv_exists((HV*)vs, "alpha", 5 ) )
+    if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
        alpha = TRUE;
        alpha = TRUE;
-    av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE));
+    av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
 
     len = av_len(av);
     if ( len == -1 )
 
     len = av_len(av);
     if ( len == -1 )
@@ -4476,16 +4779,28 @@ the original version contained 1 or more dots, respectively
 SV *
 Perl_vstringify(pTHX_ SV *vs)
 {
 SV *
 Perl_vstringify(pTHX_ SV *vs)
 {
+    PERL_ARGS_ASSERT_VSTRINGIFY;
+
     if ( SvROK(vs) )
        vs = SvRV(vs);
     if ( SvROK(vs) )
        vs = SvRV(vs);
-    
+
     if ( !vverify(vs) )
        Perl_croak(aTHX_ "Invalid version object");
 
     if ( !vverify(vs) )
        Perl_croak(aTHX_ "Invalid version object");
 
-    if ( hv_exists((HV *)vs, "qv", 2) )
-       return vnormal(vs);
-    else
-       return vnumify(vs);
+    if (hv_exists(MUTABLE_HV(vs), "original",  sizeof("original") - 1)) {
+       SV *pv;
+       pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
+       if ( SvPOK(pv) )
+           return newSVsv(pv);
+       else
+           return &PL_sv_undef;
+    }
+    else {
+       if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
+           return vnormal(vs);
+       else
+           return vnumify(vs);
+    }
 }
 
 /*
 }
 
 /*
@@ -4506,6 +4821,9 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
     I32 left = 0;
     I32 right = 0;
     AV *lav, *rav;
     I32 left = 0;
     I32 right = 0;
     AV *lav, *rav;
+
+    PERL_ARGS_ASSERT_VCMP;
+
     if ( SvROK(lhv) )
        lhv = SvRV(lhv);
     if ( SvROK(rhv) )
     if ( SvROK(lhv) )
        lhv = SvRV(lhv);
     if ( SvROK(rhv) )
@@ -4518,13 +4836,13 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
        Perl_croak(aTHX_ "Invalid version object");
 
     /* get the left hand term */
        Perl_croak(aTHX_ "Invalid version object");
 
     /* get the left hand term */
-    lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE));
-    if ( hv_exists((HV*)lhv, "alpha", 5 ) )
+    lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
+    if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
        lalpha = TRUE;
 
     /* and the right hand term */
        lalpha = TRUE;
 
     /* and the right hand term */
-    rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE));
-    if ( hv_exists((HV*)rhv, "alpha", 5 ) )
+    rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
+    if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
        ralpha = TRUE;
 
     l = av_len(lav);
        ralpha = TRUE;
 
     l = av_len(lav);
@@ -4714,12 +5032,12 @@ S_socketpair_udp (int fd[2]) {
     errno = ECONNABORTED;
   tidy_up_and_fail:
     {
     errno = ECONNABORTED;
   tidy_up_and_fail:
     {
-       const int save_errno = errno;
+       dSAVE_ERRNO;
        if (sockets[0] != -1)
            PerlLIO_close(sockets[0]);
        if (sockets[1] != -1)
            PerlLIO_close(sockets[1]);
        if (sockets[0] != -1)
            PerlLIO_close(sockets[0]);
        if (sockets[1] != -1)
            PerlLIO_close(sockets[1]);
-       errno = save_errno;
+       RESTORE_ERRNO;
        return -1;
     }
 }
        return -1;
     }
 }
@@ -4818,14 +5136,14 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
 #endif
   tidy_up_and_fail:
     {
 #endif
   tidy_up_and_fail:
     {
-       const int save_errno = errno;
+       dSAVE_ERRNO;
        if (listener != -1)
            PerlLIO_close(listener);
        if (connector != -1)
            PerlLIO_close(connector);
        if (acceptor != -1)
            PerlLIO_close(acceptor);
        if (listener != -1)
            PerlLIO_close(listener);
        if (connector != -1)
            PerlLIO_close(connector);
        if (acceptor != -1)
            PerlLIO_close(acceptor);
-       errno = save_errno;
+       RESTORE_ERRNO;
        return -1;
     }
 }
        return -1;
     }
 }
@@ -4857,7 +5175,28 @@ potentially warn under some level of strict-ness.
 void
 Perl_sv_nosharing(pTHX_ SV *sv)
 {
 void
 Perl_sv_nosharing(pTHX_ SV *sv)
 {
+    PERL_UNUSED_CONTEXT;
+    PERL_UNUSED_ARG(sv);
+}
+
+/*
+
+=for apidoc sv_destroyable
+
+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
+could potentially warn under some level of strict-ness.
+
+=cut
+*/
+
+bool
+Perl_sv_destroyable(pTHX_ SV *sv)
+{
+    PERL_UNUSED_CONTEXT;
     PERL_UNUSED_ARG(sv);
     PERL_UNUSED_ARG(sv);
+    return TRUE;
 }
 
 U32
 }
 
 U32
@@ -4866,10 +5205,13 @@ Perl_parse_unicode_opts(pTHX_ const char **popt)
   const char *p = *popt;
   U32 opt = 0;
 
   const char *p = *popt;
   U32 opt = 0;
 
+  PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
+
   if (*p) {
        if (isDIGIT(*p)) {
            opt = (U32) atoi(p);
   if (*p) {
        if (isDIGIT(*p)) {
            opt = (U32) atoi(p);
-           while (isDIGIT(*p)) p++;
+           while (isDIGIT(*p))
+               p++;
            if (*p && *p != '\n' && *p != '\r')
                 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
        }
            if (*p && *p != '\n' && *p != '\r')
                 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
        }
@@ -4894,6 +5236,8 @@ Perl_parse_unicode_opts(pTHX_ const char **popt)
                      opt |= PERL_UNICODE_LOCALE_FLAG;  break;
                 case PERL_UNICODE_ARGV:
                      opt |= PERL_UNICODE_ARGV_FLAG;    break;
                      opt |= PERL_UNICODE_LOCALE_FLAG;  break;
                 case PERL_UNICODE_ARGV:
                      opt |= PERL_UNICODE_ARGV_FLAG;    break;
+                case PERL_UNICODE_UTF8CACHEASSERT:
+                     opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
                 default:
                      if (*p != '\n' && *p != '\r')
                          Perl_croak(aTHX_
                 default:
                      if (*p != '\n' && *p != '\r')
                          Perl_croak(aTHX_
@@ -5004,7 +5348,8 @@ Perl_get_hash_seed(pTHX)
      UV myseed = 0;
 
      if (s)
      UV myseed = 0;
 
      if (s)
-         while (isSPACE(*s)) s++;
+       while (isSPACE(*s))
+           s++;
      if (s && isDIGIT(*s))
          myseed = (UV)Atoul(s);
      else
      if (s && isDIGIT(*s))
          myseed = (UV)Atoul(s);
      else
@@ -5021,7 +5366,7 @@ Perl_get_hash_seed(pTHX)
           * help.  Sum in another random number that will
           * fill in the low bits. */
          myseed +=
           * help.  Sum in another random number that will
           * fill in the low bits. */
          myseed +=
-              (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
+              (UV)(Drand01() * (NV)((((UV)1) << ((UVSIZE * 8 - RANDBITS))) - 1));
 #endif /* RANDBITS < (UVSIZE * 8) */
          if (myseed == 0) { /* Superparanoia. */
              myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
 #endif /* RANDBITS < (UVSIZE * 8) */
          if (myseed == 0) { /* Superparanoia. */
              myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
@@ -5040,6 +5385,8 @@ Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
 {
     const char * const stashpv = CopSTASHPV(c);
     const char * const name = HvNAME_get(hv);
 {
     const char * const stashpv = CopSTASHPV(c);
     const char * const name = HvNAME_get(hv);
+    PERL_UNUSED_CONTEXT;
+    PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH;
 
     if (stashpv == name)
        return TRUE;
 
     if (stashpv == name)
        return TRUE;
@@ -5053,13 +5400,14 @@ Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
 
 #ifdef PERL_GLOBAL_STRUCT
 
 
 #ifdef PERL_GLOBAL_STRUCT
 
+#define PERL_GLOBAL_STRUCT_INIT
+#include "opcode.h" /* the ppaddr and check */
+
 struct perl_vars *
 Perl_init_global_struct(pTHX)
 {
     struct perl_vars *plvarsp = NULL;
 struct perl_vars *
 Perl_init_global_struct(pTHX)
 {
     struct perl_vars *plvarsp = NULL;
-#ifdef PERL_GLOBAL_STRUCT
-#  define PERL_GLOBAL_STRUCT_INIT
-#  include "opcode.h" /* the ppaddr and check */
+# ifdef PERL_GLOBAL_STRUCT
     const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
     const IV ncheck  = sizeof(Gcheck) /sizeof(Perl_check_t);
 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
     const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
     const IV ncheck  = sizeof(Gcheck) /sizeof(Perl_check_t);
 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
@@ -5087,10 +5435,14 @@ Perl_init_global_struct(pTHX)
 #  undef PERLVARIC
 #  undef PERLVARISC
 #  ifdef PERL_GLOBAL_STRUCT
 #  undef PERLVARIC
 #  undef PERLVARISC
 #  ifdef PERL_GLOBAL_STRUCT
-    plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
+    plvarsp->Gppaddr =
+       (Perl_ppaddr_t*)
+       PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
     if (!plvarsp->Gppaddr)
         exit(1);
     if (!plvarsp->Gppaddr)
         exit(1);
-    plvarsp->Gcheck  = PerlMem_malloc(ncheck  * sizeof(Perl_check_t));
+    plvarsp->Gcheck  =
+       (Perl_check_t*)
+       PerlMem_malloc(ncheck  * sizeof(Perl_check_t));
     if (!plvarsp->Gcheck)
         exit(1);
     Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t); 
     if (!plvarsp->Gcheck)
         exit(1);
     Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t); 
@@ -5099,8 +5451,8 @@ Perl_init_global_struct(pTHX)
 #  ifdef PERL_SET_VARS
     PERL_SET_VARS(plvarsp);
 #  endif
 #  ifdef PERL_SET_VARS
     PERL_SET_VARS(plvarsp);
 #  endif
-#  undef PERL_GLOBAL_STRUCT_INIT
-#endif
+# undef PERL_GLOBAL_STRUCT_INIT
+# endif
     return plvarsp;
 }
 
     return plvarsp;
 }
 
@@ -5111,70 +5463,211 @@ Perl_init_global_struct(pTHX)
 void
 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
 {
 void
 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
 {
-#ifdef PERL_GLOBAL_STRUCT
+    PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
+# ifdef PERL_GLOBAL_STRUCT
 #  ifdef PERL_UNSET_VARS
     PERL_UNSET_VARS(plvarsp);
 #  endif
     free(plvarsp->Gppaddr);
     free(plvarsp->Gcheck);
 #  ifdef PERL_UNSET_VARS
     PERL_UNSET_VARS(plvarsp);
 #  endif
     free(plvarsp->Gppaddr);
     free(plvarsp->Gcheck);
-#    ifdef PERL_GLOBAL_STRUCT_PRIVATE
+#  ifdef PERL_GLOBAL_STRUCT_PRIVATE
     free(plvarsp);
     free(plvarsp);
-#    endif
-#endif
+#  endif
+# endif
 }
 
 #endif /* PERL_GLOBAL_STRUCT */
 
 #ifdef PERL_MEM_LOG
 
 }
 
 #endif /* PERL_GLOBAL_STRUCT */
 
 #ifdef PERL_MEM_LOG
 
+/* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
+ * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
+ * given, and you supply your own implementation.
+ *
+ * The default implementation reads a single env var, PERL_MEM_LOG,
+ * expecting one or more of the following:
+ *
+ *    \d+ - fd         fd to write to          : must be 1st (atoi)
+ *    'm' - memlog     was PERL_MEM_LOG=1
+ *    's' - svlog      was PERL_SV_LOG=1
+ *    't' - timestamp  was PERL_MEM_LOG_TIMESTAMP=1
+ *
+ * This makes the logger controllable enough that it can reasonably be
+ * added to the system perl.
+ */
+
+/* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
+ * the Perl_mem_log_...() will use (either via sprintf or snprintf).
+ */
 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
 
 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
 
-Malloc_t
-Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
-{
-#ifdef PERL_MEM_LOG_STDERR
-    /* We can't use PerlIO for obvious reasons. */
-    char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
-    const STRLEN len = my_sprintf(buf,
-                                 "alloc: %s:%d:%s: %"IVdf" %"UVuf
-                                 " %s = %"IVdf": %"UVxf"\n",
-                                 filename, linenumber, funcname, n, typesize,
-                                 typename, n * typesize, PTR2UV(newalloc));
-    PerlLIO_write(2,  buf, len);
+/* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
+ * writes to.  In the default logger, this is settable at runtime.
+ */
+#ifndef PERL_MEM_LOG_FD
+#  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
+#endif
+
+#ifndef PERL_MEM_LOG_NOIMPL
+
+# ifdef DEBUG_LEAKING_SCALARS
+#   define SV_LOG_SERIAL_FMT       " [%lu]"
+#   define _SV_LOG_SERIAL_ARG(sv)   , (unsigned long) (sv)->sv_debug_serial
+# else
+#   define SV_LOG_SERIAL_FMT
+#   define _SV_LOG_SERIAL_ARG(sv)
+# endif
+
+static void
+S_mem_log_common(enum mem_log_type mlt, const UV n, 
+                const UV typesize, const char *type_name, const SV *sv,
+                Malloc_t oldalloc, Malloc_t newalloc,
+                const char *filename, const int linenumber,
+                const char *funcname)
+{
+    const char *pmlenv;
+
+    PERL_ARGS_ASSERT_MEM_LOG_COMMON;
+
+    pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
+    if (!pmlenv)
+       return;
+    if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
+    {
+       /* We can't use SVs or PerlIO for obvious reasons,
+        * so we'll use stdio and low-level IO instead. */
+       char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
+
+#   ifdef HAS_GETTIMEOFDAY
+#     define MEM_LOG_TIME_FMT  "%10d.%06d: "
+#     define MEM_LOG_TIME_ARG  (int)tv.tv_sec, (int)tv.tv_usec
+       struct timeval tv;
+       gettimeofday(&tv, 0);
+#   else
+#     define MEM_LOG_TIME_FMT  "%10d: "
+#     define MEM_LOG_TIME_ARG  (int)when
+        Time_t when;
+        (void)time(&when);
+#   endif
+       /* If there are other OS specific ways of hires time than
+        * gettimeofday() (see ext/Time-HiRes), the easiest way is
+        * probably that they would be used to fill in the struct
+        * timeval. */
+       {
+           STRLEN len;
+           int fd = atoi(pmlenv);
+           if (!fd)
+               fd = PERL_MEM_LOG_FD;
+
+           if (strchr(pmlenv, 't')) {
+               len = my_snprintf(buf, sizeof(buf),
+                               MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
+               PerlLIO_write(fd, buf, len);
+           }
+           switch (mlt) {
+           case MLT_ALLOC:
+               len = my_snprintf(buf, sizeof(buf),
+                       "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),
+                       "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),
+                       "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),
+                       "%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));
+               break;
+           default:
+               len = 0;
+           }
+           PerlLIO_write(fd, buf, len);
+       }
+    }
+}
+#endif /* !PERL_MEM_LOG_NOIMPL */
+
+#ifndef PERL_MEM_LOG_NOIMPL
+# define \
+    mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
+    mem_log_common   (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
+#else
+/* this is suboptimal, but bug compatible.  User is providing their
+   own implemenation, but is getting these functions anyway, and they
+   do nothing. But _NOIMPL users should be able to cope or fix */
+# define \
+    mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
+    /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
 #endif
 #endif
+
+Malloc_t
+Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
+                  Malloc_t newalloc, 
+                  const char *filename, const int linenumber,
+                  const char *funcname)
+{
+    mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
+                     NULL, NULL, newalloc,
+                     filename, linenumber, funcname);
     return newalloc;
 }
 
 Malloc_t
     return newalloc;
 }
 
 Malloc_t
-Perl_mem_log_realloc(const UV n, const UV typesize, const char *typename, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
-{
-#ifdef PERL_MEM_LOG_STDERR
-    /* We can't use PerlIO for obvious reasons. */
-    char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
-    const STRLEN len = my_sprintf(buf, "realloc: %s:%d:%s: %"IVdf" %"UVuf
-                                 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
-                                 filename, linenumber, funcname, n, typesize,
-                                 typename, n * typesize, PTR2UV(oldalloc),
-                                 PTR2UV(newalloc));
-    PerlLIO_write(2,  buf, len);
-#endif
+Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
+                    Malloc_t oldalloc, Malloc_t newalloc, 
+                    const char *filename, const int linenumber, 
+                    const char *funcname)
+{
+    mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
+                     NULL, oldalloc, newalloc, 
+                     filename, linenumber, funcname);
     return newalloc;
 }
 
 Malloc_t
     return newalloc;
 }
 
 Malloc_t
-Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
+Perl_mem_log_free(Malloc_t oldalloc, 
+                 const char *filename, const int linenumber, 
+                 const char *funcname)
 {
 {
-#ifdef PERL_MEM_LOG_STDERR
-    /* We can't use PerlIO for obvious reasons. */
-    char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
-    const STRLEN len = my_sprintf(buf, "free: %s:%d:%s: %"UVxf"\n",
-                                 filename, linenumber, funcname,
-                                 PTR2UV(oldalloc));
-    PerlLIO_write(2,  buf, len);
-#endif
+    mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, 
+                     filename, linenumber, funcname);
     return oldalloc;
 }
 
     return oldalloc;
 }
 
+void
+Perl_mem_log_new_sv(const SV *sv, 
+                   const char *filename, const int linenumber,
+                   const char *funcname)
+{
+    mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
+                     filename, linenumber, funcname);
+}
+
+void
+Perl_mem_log_del_sv(const SV *sv,
+                   const char *filename, const int linenumber, 
+                   const char *funcname)
+{
+    mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL, 
+                     filename, linenumber, funcname);
+}
+
 #endif /* PERL_MEM_LOG */
 
 /*
 #endif /* PERL_MEM_LOG */
 
 /*
@@ -5191,6 +5684,7 @@ int
 Perl_my_sprintf(char *buffer, const char* pat, ...)
 {
     va_list args;
 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);
     va_start(args, pat);
     vsprintf(buffer, pat, args);
     va_end(args);
@@ -5198,6 +5692,78 @@ Perl_my_sprintf(char *buffer, const char* pat, ...)
 }
 #endif
 
 }
 #endif
 
+/*
+=for apidoc my_snprintf
+
+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
+*/
+int
+Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
+{
+    dTHX;
+    int retval;
+    va_list ap;
+    PERL_ARGS_ASSERT_MY_SNPRINTF;
+    va_start(ap, format);
+#ifdef HAS_VSNPRINTF
+    retval = vsnprintf(buffer, len, format, ap);
+#else
+    retval = vsprintf(buffer, format, ap);
+#endif
+    va_end(ap);
+    /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
+    if (retval < 0 || (len > 0 && (Size_t)retval >= len))
+       Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
+    return retval;
+}
+
+/*
+=for apidoc my_vsnprintf
+
+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
+*/
+int
+Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
+{
+    dTHX;
+    int retval;
+#ifdef NEED_VA_COPY
+    va_list apc;
+
+    PERL_ARGS_ASSERT_MY_VSNPRINTF;
+
+    Perl_va_copy(ap, apc);
+# ifdef HAS_VSNPRINTF
+    retval = vsnprintf(buffer, len, format, apc);
+# else
+    retval = vsprintf(buffer, format, apc);
+# endif
+#else
+# ifdef HAS_VSNPRINTF
+    retval = vsnprintf(buffer, len, format, ap);
+# else
+    retval = vsprintf(buffer, format, ap);
+# endif
+#endif /* #ifdef NEED_VA_COPY */
+    /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
+    if (retval < 0 || (len > 0 && (Size_t)retval >= len))
+       Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
+    return retval;
+}
+
 void
 Perl_my_clearenv(pTHX)
 {
 void
 Perl_my_clearenv(pTHX)
 {
@@ -5227,17 +5793,18 @@ Perl_my_clearenv(pTHX)
     (void)clearenv();
 #        elif defined(HAS_UNSETENV)
     int bsiz = 80; /* Most envvar names will be shorter than this. */
     (void)clearenv();
 #        elif defined(HAS_UNSETENV)
     int bsiz = 80; /* Most envvar names will be shorter than this. */
-    char *buf = (char*)safesysmalloc(bsiz * sizeof(char));
+    int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
+    char *buf = (char*)safesysmalloc(bufsiz);
     while (*environ != NULL) {
       char *e = strchr(*environ, '=');
     while (*environ != NULL) {
       char *e = strchr(*environ, '=');
-      int l = e ? e - *environ : strlen(*environ);
+      int l = e ? e - *environ : (int)strlen(*environ);
       if (bsiz < l + 1) {
         (void)safesysfree(buf);
       if (bsiz < l + 1) {
         (void)safesysfree(buf);
-        bsiz = l + 1;
-        buf = (char*)safesysmalloc(bsiz * sizeof(char));
+        bsiz = l + 1; /* + 1 for the \0. */
+        buf = (char*)safesysmalloc(bufsiz);
       } 
       } 
-      strncpy(buf, *environ, l);
-      *(buf + l) = '\0';
+      memcpy(buf, *environ, l);
+      buf[l] = '\0';
       (void)unsetenv(buf);
     }
     (void)safesysfree(buf);
       (void)unsetenv(buf);
     }
     (void)safesysfree(buf);
@@ -5254,18 +5821,20 @@ Perl_my_clearenv(pTHX)
 
 #ifdef PERL_IMPLICIT_CONTEXT
 
 
 #ifdef PERL_IMPLICIT_CONTEXT
 
-/* implements the MY_CXT_INIT macro. The first time a module is loaded,
+/* Implements the MY_CXT_INIT macro. The first time a module is loaded,
 the global PL_my_cxt_index is incremented, and that value is assigned to
 that module's static my_cxt_index (who's address is passed as an arg).
 Then, for each interpreter this function is called for, it makes sure a
 void* slot is available to hang the static data off, by allocating or
 extending the interpreter's PL_my_cxt_list array */
 
 the global PL_my_cxt_index is incremented, and that value is assigned to
 that module's static my_cxt_index (who's address is passed as an arg).
 Then, for each interpreter this function is called for, it makes sure a
 void* slot is available to hang the static data off, by allocating or
 extending the interpreter's PL_my_cxt_list array */
 
+#ifndef PERL_GLOBAL_STRUCT_PRIVATE
 void *
 Perl_my_cxt_init(pTHX_ int *index, size_t size)
 {
     dVAR;
     void *p;
 void *
 Perl_my_cxt_init(pTHX_ int *index, size_t size)
 {
     dVAR;
     void *p;
+    PERL_ARGS_ASSERT_MY_CXT_INIT;
     if (*index == -1) {
        /* this module hasn't been allocated an index yet */
        MUTEX_LOCK(&PL_my_ctx_mutex);
     if (*index == -1) {
        /* this module hasn't been allocated an index yet */
        MUTEX_LOCK(&PL_my_ctx_mutex);
@@ -5291,8 +5860,185 @@ Perl_my_cxt_init(pTHX_ int *index, size_t size)
     Zero(p, size, char);
     return p;
 }
     Zero(p, size, char);
     return p;
 }
+
+#else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
+
+int
+Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
+{
+    dVAR;
+    int index;
+
+    PERL_ARGS_ASSERT_MY_CXT_INDEX;
+
+    for (index = 0; index < PL_my_cxt_index; index++) {
+       const char *key = PL_my_cxt_keys[index];
+       /* try direct pointer compare first - there are chances to success,
+        * and it's much faster.
+        */
+       if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
+           return index;
+    }
+    return -1;
+}
+
+void *
+Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
+{
+    dVAR;
+    void *p;
+    int index;
+
+    PERL_ARGS_ASSERT_MY_CXT_INIT;
+
+    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++;
+       MUTEX_UNLOCK(&PL_my_ctx_mutex);
+    }
+
+    /* make sure the array is big enough */
+    if (PL_my_cxt_size <= index) {
+       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 *);
+       }
+       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;
+    Zero(p, size, char);
+    return p;
+}
+#endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
+#endif /* PERL_IMPLICIT_CONTEXT */
+
+#ifndef HAS_STRLCAT
+Size_t
+Perl_my_strlcat(char *dst, const char *src, Size_t size)
+{
+    Size_t used, length, copy;
+
+    used = strlen(dst);
+    length = strlen(src);
+    if (size > 0 && used < size - 1) {
+        copy = (length >= size - used) ? size - used - 1 : length;
+        memcpy(dst + used, src, copy);
+        dst[used + copy] = '\0';
+    }
+    return used + length;
+}
+#endif
+
+#ifndef HAS_STRLCPY
+Size_t
+Perl_my_strlcpy(char *dst, const char *src, Size_t size)
+{
+    Size_t length, copy;
+
+    length = strlen(src);
+    if (size > 0) {
+        copy = (length >= size) ? size - 1 : length;
+        memcpy(dst, src, copy);
+        dst[copy] = '\0';
+    }
+    return length;
+}
+#endif
+
+#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. */
+long _ftol2( double dblSource ) { return _ftol( dblSource ); }
 #endif
 
 #endif
 
+void
+Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
+{
+    dVAR;
+    SV * const dbsv = GvSVn(PL_DBsub);
+    /* We do not care about using sv to call CV;
+     * it's for informational purposes only.
+     */
+
+    PERL_ARGS_ASSERT_GET_DB_SUB;
+
+    save_item(dbsv);
+    if (!PERLDB_SUB_NN) {
+       GV * const gv = CvGV(cv);
+
+       if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
+            || strEQ(GvNAME(gv), "END")
+            || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
+                !( (SvTYPE(*svp) == SVt_PVGV)
+                   && (GvCV((const GV *)*svp) == cv) )))) {
+           /* Use GV from the stack as a fallback. */
+           /* GV is potentially non-unique, or contain different CV. */
+           SV * const tmp = newRV(MUTABLE_SV(cv));
+           sv_setsv(dbsv, tmp);
+           SvREFCNT_dec(tmp);
+       }
+       else {
+           gv_efullname3(dbsv, gv, NULL);
+       }
+    }
+    else {
+       const int type = SvTYPE(dbsv);
+       if (type < SVt_PVIV && type != SVt_IV)
+           sv_upgrade(dbsv, SVt_PVIV);
+       (void)SvIOK_on(dbsv);
+       SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
+    }
+}
+
+int
+Perl_my_dirfd(pTHX_ DIR * dir) {
+
+    /* Most dirfd implementations have problems when passed NULL. */
+    if(!dir)
+        return -1;
+#ifdef HAS_DIRFD
+    return dirfd(dir);
+#elif defined(HAS_DIR_DD_FD)
+    return dir->dd_fd;
+#else
+    Perl_die(aTHX_ PL_no_func, "dirfd");
+   /* NOT REACHED */
+    return 0;
+#endif 
+}
+
+REGEXP *
+Perl_get_re_arg(pTHX_ SV *sv) {
+
+    if (sv) {
+        if (SvMAGICAL(sv))
+            mg_get(sv);
+        if (SvROK(sv))
+           sv = MUTABLE_SV(SvRV(sv));
+        if (SvTYPE(sv) == SVt_REGEXP)
+            return (REGEXP*) sv;
+    }
+ 
+    return NULL;
+}
+
 /*
  * Local variables:
  * c-indentation-style: bsd
 /*
  * Local variables:
  * c-indentation-style: bsd
Unnamed repository; edit this file 'description' to name the repository.