This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix SV leaks in Perl_vnumify() and Perl_vnormal() for "Invalid version object"s
[perl5.git] / util.c
diff --git a/util.c b/util.c
index 360ec28..ef0970e 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, 2007, 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.
@@ -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;
 
@@ -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)
@@ -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,10 +369,11 @@ 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_UNUSED_CONTEXT;
+
+    PERL_ARGS_ASSERT_DELIMCPY;
 
     for (tolen = 0; from < fromend; from++, tolen++) {
        if (*from == '\\') {
 
     for (tolen = 0; from < fromend; from++, tolen++) {
        if (*from == '\\') {
@@ -366,10 +399,11 @@ 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_UNUSED_CONTEXT;
+
+    PERL_ARGS_ASSERT_INSTR;
 
     if (!little)
        return (char*)big;
 
     if (!little)
        return (char*)big;
@@ -399,24 +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_UNUSED_CONTEXT;
+    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;
@@ -425,12 +459,13 @@ 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_UNUSED_CONTEXT;
+
+    PERL_ARGS_ASSERT_RNINSTR;
 
     if (little >= littleend)
        return (char*)bigend;
 
     if (little >= littleend)
        return (char*)bigend;
@@ -481,6 +516,8 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
     U32 rarest = 0;
     U32 frequency = 256;
 
     U32 rarest = 0;
     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() */
@@ -504,7 +541,6 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
            = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
        s = table - 1 - PERL_FBM_TABLE_OFFSET;  /* last char */
        memset((void*)table, mlen, 256);
            = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
        s = table - 1 - PERL_FBM_TABLE_OFFSET;  /* last char */
        memset((void*)table, mlen, 256);
-       BmFLAGS(sv) = (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) {
@@ -524,6 +560,7 @@ 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];
     BmPREVIOUS(sv) = rarest;
     BmUSEFUL(sv) = 100;                        /* Initial value */
     BmRARE(sv) = s[rarest];
     BmPREVIOUS(sv) = rarest;
     BmUSEFUL(sv) = 100;                        /* Initial value */
@@ -558,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)
@@ -761,6 +800,8 @@ 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));
 
     assert(SvTYPE(littlestr) == SVt_PVGV);
     assert(SvVALID(littlestr));
 
@@ -769,7 +810,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
        : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
       cant_find:
        if ( BmRARE(littlestr) == '\n'
        : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
       cant_find:
        if ( BmRARE(littlestr) == '\n'
-            && BmPREVIOUS(littlestr) == (U8)SvCUR(littlestr) - 1) {
+            && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
            little = (const unsigned char *)(SvPVX_const(littlestr));
            littleend = little + SvCUR(littlestr);
            first = *little++;
            little = (const unsigned char *)(SvPVX_const(littlestr));
            littleend = little + SvCUR(littlestr);
            first = *little++;
@@ -838,11 +879,12 @@ 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_UNUSED_CONTEXT;
+
+    PERL_ARGS_ASSERT_IBCMP;
 
     while (len--) {
        if (*a != *b && *a != PL_fold[*b])
 
     while (len--) {
        if (*a != *b && *a != PL_fold[*b])
@@ -853,12 +895,13 @@ 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_UNUSED_CONTEXT;
+
+    PERL_ARGS_ASSERT_IBCMP_LOCALE;
 
     while (len--) {
        if (*a != *b && *a != PL_fold_locale[*b])
 
     while (len--) {
        if (*a != *b && *a != PL_fold_locale[*b])
@@ -953,6 +996,29 @@ Perl_savesharedpv(pTHX_ const char *pv)
 }
 
 /*
 }
 
 /*
+=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);
+}
+
+/*
 =for apidoc savesvpv
 
 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
 =for apidoc savesvpv
 
 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
@@ -968,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);
@@ -984,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;
@@ -1007,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);
@@ -1039,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);
@@ -1049,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);
 }
@@ -1060,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);
@@ -1072,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);
@@ -1084,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;
 
@@ -1117,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') {
        /*
@@ -1133,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,
@@ -1149,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;
@@ -1171,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);
 
@@ -1183,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
     }
 }
@@ -1198,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;
@@ -1226,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);
        }
@@ -1239,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;
@@ -1247,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",
-                         (void*)thr, message, (void*)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",
-                         (void*)thr, (void*)PL_curstack, (void*)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",
-         (void*)thr, (void*)PL_restartop, was_in_eval, (void*)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)
@@ -1332,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;
-
-    message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
+    SV *msv;
 
 
-    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)
@@ -1376,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);
 
@@ -1397,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)
@@ -1416,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);
@@ -1435,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);
@@ -1446,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);
@@ -1453,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);
@@ -1465,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;
+    PERL_ARGS_ASSERT_VWARNER;
     if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
        SV * const msv = vmess(pat, args);
     if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
        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);
@@ -1494,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 */
@@ -1522,22 +1583,42 @@ 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.  */
 }
 
 /* Set buffer=NULL to get a new one.  */
@@ -1546,6 +1627,7 @@ Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
                           STRLEN size) {
     const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
     PERL_UNUSED_CONTEXT;
                           STRLEN size) {
     const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
     PERL_UNUSED_CONTEXT;
+    PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
 
     buffer = (STRLEN*)
        (specialWARN(buffer) ?
 
     buffer = (STRLEN*)
        (specialWARN(buffer) ?
@@ -1581,9 +1663,16 @@ 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;
 
+    /* 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;
     if (environ == PL_origenviron) {   /* need we copy environment? */
        I32 j;
        I32 max;
@@ -1687,28 +1776,6 @@ 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);
-    PERL_UNUSED_CONTEXT;
-
-    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
 #endif /* !VMS && !EPOC*/
 
 #ifdef UNLINK_ALL_VERSIONS
@@ -1717,6 +1784,8 @@ Perl_unlnk(pTHX_ const char *f)   /* unlink all versions of a file */
 {
     I32 retries = 0;
 
 {
     I32 retries = 0;
 
+    PERL_ARGS_ASSERT_UNLNK;
+
     while (PerlLIO_unlink(f) >= 0)
        retries++;
     return retries ? 0 : -1;
     while (PerlLIO_unlink(f) >= 0)
        retries++;
     return retries ? 0 : -1;
@@ -1730,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++;
@@ -1751,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;
@@ -1764,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;
@@ -1779,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;
@@ -1788,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
@@ -1838,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;
@@ -2132,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;
@@ -2140,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;
@@ -2151,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;
@@ -2173,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) {
@@ -2230,9 +2342,7 @@ 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;
     SvUPGRADE(sv,SVt_IV);
     SvIV_set(sv, pid);
     PL_forkprocess = pid;
@@ -2269,7 +2379,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
     return PerlIO_fdopen(p[This], mode);
 #else
 #  ifdef OS2   /* Same, without fork()ing and all extra overhead... */
     return PerlIO_fdopen(p[This], mode);
 #else
 #  ifdef OS2   /* Same, without fork()ing and all extra overhead... */
-    return my_syspopen4(aTHX_ Nullch, mode, n, args);
+    return my_syspopen4(aTHX_ NULL, mode, n, args);
 #  else
     Perl_croak(aTHX_ "List form of piped open not implemented");
     return (PerlIO *) NULL;
 #  else
     Perl_croak(aTHX_ "List form of piped open not implemented");
     return (PerlIO *) NULL;
@@ -2278,7 +2388,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
 }
 
     /* VMS' my_popen() is in VMS.c, same with OS/2. */
 }
 
     /* 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)
 {
@@ -2291,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) {
@@ -2316,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) {
@@ -2396,9 +2509,7 @@ 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;
     SvUPGRADE(sv,SVt_IV);
     SvIV_set(sv, pid);
     PL_forkprocess = pid;
@@ -2437,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_ const char *cmd, const 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;
@@ -2450,7 +2562,7 @@ Perl_my_popen((pTHX_ const char *cmd, const char *mode)
 #if defined(DJGPP)
 FILE *djgpp_popen();
 PerlIO *
 #if defined(DJGPP)
 FILE *djgpp_popen();
 PerlIO *
-Perl_my_popen((pTHX_ const char *cmd, const 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.
@@ -2459,6 +2571,14 @@ Perl_my_popen((pTHX_ const char *cmd, const 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
 
@@ -2516,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)
@@ -2568,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)
 {
@@ -2620,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)
@@ -2721,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)
 {
@@ -2732,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;
@@ -2748,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
@@ -2771,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
@@ -2856,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;
 }
@@ -2863,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;
 
@@ -2907,24 +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)
-{
-    register I32 todo;
-    register const char * const frombase = from;
-    PERL_UNUSED_CONTEXT;
+Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
+{
+    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);
     }
 }
 
     }
 }
 
@@ -2938,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
@@ -2949,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)
@@ -2976,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
@@ -2999,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.
@@ -3087,26 +3224,16 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
     }
 #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
@@ -3119,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
@@ -3141,7 +3263,6 @@ 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
            (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
 #endif  /* !VMS */
 
            (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
 #endif  /* !VMS */
 
@@ -3166,7 +3287,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
                continue;
            if (S_ISREG(PL_statbuf.st_mode)
                && cando(S_IRUSR,TRUE,&PL_statbuf)
                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
                )
@@ -3227,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);
@@ -3291,6 +3413,7 @@ Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
 {
     char * const env_trans = PerlEnv_getenv(env_elem);
     PERL_UNUSED_CONTEXT;
 {
     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;
@@ -3588,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
 }
@@ -3610,6 +3735,8 @@ Perl_mini_mktime(pTHX_ struct tm *ptm)
     int odd_cent, odd_year;
     PERL_UNUSED_CONTEXT;
 
     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_CENT   (25*DAYS_PER_QYEAR-1)
 #define        DAYS_PER_YEAR   365
 #define        DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
 #define        DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
@@ -3804,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;
@@ -3911,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];
@@ -3948,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;
 
@@ -3970,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)) {
@@ -4048,6 +4180,206 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 #endif
 }
 
 #endif
 }
 
+#define VERSION_MAX 0x7FFFFFFF
+
+const char *
+Perl_prescan_version(pTHX_ const char *s, bool strict,
+                    const char **errstr,
+                    bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
+    bool qv = (sqv ? *sqv : FALSE);
+    int width = 3;
+    int saw_decimal = 0;
+    bool alpha = FALSE;
+    const char *d = s;
+
+    PERL_ARGS_ASSERT_PRESCAN_VERSION;
+
+    if (qv && isDIGIT(*d))
+       goto dotted_decimal_version;
+
+    if (*d == 'v') { /* explicit v-string */
+       d++;
+       if (isDIGIT(*d)) {
+           qv = TRUE;
+       }
+       else { /* degenerate v-string */
+           /* requires v1.2.3 */
+           BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+       }
+
+dotted_decimal_version:
+       if (strict && d[0] == '0' && isDIGIT(d[1])) {
+           /* no leading zeros allowed */
+           BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
+       }
+
+       while (isDIGIT(*d))     /* integer part */
+           d++;
+
+       if (*d == '.')
+       {
+           saw_decimal++;
+           d++;                /* decimal point */
+       }
+       else
+       {
+           if (strict) {
+               /* require v1.2.3 */
+               BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+           }
+           else {
+               goto version_prescan_finish;
+           }
+       }
+
+       {
+           int i = 0;
+           int j = 0;
+           while (isDIGIT(*d)) {       /* just keep reading */
+               i++;
+               while (isDIGIT(*d)) {
+                   d++; j++;
+                   /* maximum 3 digits between decimal */
+                   if (strict && j > 3) {
+                       BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
+                   }
+               }
+               if (*d == '_') {
+                   if (strict) {
+                       BADVERSION(s,errstr,"Invalid version format (no underscores)");
+                   }
+                   if ( alpha ) {
+                       BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
+                   }
+                   d++;
+                   alpha = TRUE;
+               }
+               else if (*d == '.') {
+                   if (alpha) {
+                       BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
+                   }
+                   saw_decimal++;
+                   d++;
+               }
+               else if (!isDIGIT(*d)) {
+                   break;
+               }
+               j = 0;
+           }
+
+           if (strict && i < 2) {
+               /* requires v1.2.3 */
+               BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+           }
+       }
+    }                                  /* end if dotted-decimal */
+    else
+    {                                  /* decimal versions */
+       /* special strict case for leading '.' or '0' */
+       if (strict) {
+           if (*d == '.') {
+               BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
+           }
+           if (*d == '0' && isDIGIT(d[1])) {
+               BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
+           }
+       }
+
+       /* consume all of the integer part */
+       while (isDIGIT(*d))
+           d++;
+
+       /* look for a fractional part */
+       if (*d == '.') {
+           /* we found it, so consume it */
+           saw_decimal++;
+           d++;
+       }
+       else if (!*d || *d == ';' || isSPACE(*d) || *d == '}') {
+           if ( d == s ) {
+               /* found nothing */
+               BADVERSION(s,errstr,"Invalid version format (version required)");
+           }
+           /* found just an integer */
+           goto version_prescan_finish;
+       }
+       else if ( d == s ) {
+           /* didn't find either integer or period */
+           BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+       }
+       else if (*d == '_') {
+           /* underscore can't come after integer part */
+           if (strict) {
+               BADVERSION(s,errstr,"Invalid version format (no underscores)");
+           }
+           else if (isDIGIT(d[1])) {
+               BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
+           }
+           else {
+               BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
+           }
+       }
+       else {
+           /* anything else after integer part is just invalid data */
+           BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+       }
+
+       /* scan the fractional part after the decimal point*/
+
+       if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '}') )) {
+               /* strict or lax-but-not-the-end */
+               BADVERSION(s,errstr,"Invalid version format (fractional part required)");
+       }
+
+       while (isDIGIT(*d)) {
+           d++;
+           if (*d == '.' && isDIGIT(d[-1])) {
+               if (alpha) {
+                   BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
+               }
+               if (strict) {
+                   BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
+               }
+               d = (char *)s;          /* start all over again */
+               qv = TRUE;
+               goto dotted_decimal_version;
+           }
+           if (*d == '_') {
+               if (strict) {
+                   BADVERSION(s,errstr,"Invalid version format (no underscores)");
+               }
+               if ( alpha ) {
+                   BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
+               }
+               if ( ! isDIGIT(d[1]) ) {
+                   BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
+               }
+               d++;
+               alpha = TRUE;
+           }
+       }
+    }
+
+version_prescan_finish:
+    while (isSPACE(*d))
+       d++;
+
+    if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '}') )) {
+       /* trailing non-numeric data */
+       BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+    }
+
+    if (sqv)
+       *sqv = qv;
+    if (swidth)
+       *swidth = width;
+    if (ssaw_decimal)
+       *ssaw_decimal = saw_decimal;
+    if (salpha)
+       *salpha = alpha;
+    return d;
+}
+
 /*
 =for apidoc scan_version
 
 /*
 =for apidoc scan_version
 
@@ -4058,12 +4390,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.
 
@@ -4076,11 +4408,16 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     const char *start;
     const char *pos;
     const char *last;
     const char *start;
     const char *pos;
     const char *last;
-    int saw_period = 0;
-    int alpha = 0;
+    const char *errstr = NULL;
+    int saw_decimal = 0;
     int width = 3;
     int width = 3;
+    bool alpha = FALSE;
+    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 */
+
+    PERL_ARGS_ASSERT_SCAN_VERSION;
+
     (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
 
 #ifndef NODEFAULT_SHAREKEYS
     (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
 
 #ifndef NODEFAULT_SHAREKEYS
@@ -4090,47 +4427,25 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     while (isSPACE(*s)) /* leading whitespace is OK */
        s++;
 
     while (isSPACE(*s)) /* leading whitespace is OK */
        s++;
 
-    if (*s == 'v') {
-       s++;  /* get past 'v' */
-       qv = 1; /* force quoted version processing */
-    }
-
-    start = last = pos = s;
-
-    /* pre-scan the input string to check for decimals/underbars */
-    while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
-    {
-       if ( *pos == '.' )
-       {
-           if ( alpha )
-               Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
-           saw_period++ ;
-           last = pos;
-       }
-       else if ( *pos == '_' )
-       {
-           if ( alpha )
-               Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
-           alpha = 1;
-           width = pos - last - 1; /* natural width of sub-version */
+    last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
+    if (errstr) {
+       /* "undef" is a special case and not an error */
+       if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
+           Perl_croak(aTHX_ "%s", errstr);
        }
        }
-       pos++;
     }
 
     }
 
-    if ( alpha && !saw_period )
-       Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
-
-    if ( saw_period > 1 )
-       qv = 1; /* force quoted version processing */
-
+    start = s;
+    if (*s == 'v')
+       s++;
     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++;
@@ -4143,20 +4458,26 @@ 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
                 * floating point number, i.e. not quoted in any way
                 */
 
                /* the following if() will only be true after the decimal
                 * point of a version originally created with a bare
                 * floating point number, i.e. not quoted in any way
                 */
-               if ( !qv && s > start && saw_period == 1 ) {
+               if ( !qv && s > start && saw_decimal == 1 ) {
                    mult *= 100;
                    while ( s < end ) {
                    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++;
@@ -4164,21 +4485,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 == '.' )
+           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 {
@@ -4206,23 +4539,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_decimal == 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 */
+    (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;
     }
 
 
     /* fix RT#19517 - special case 'undef' as string */
     if ( *s == 'u' && strEQ(s,"undef") ) {
        s += 5;
     }
 
-    /* And finally, store the AV in the hash */
-    hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
     return s;
 }
 
     return s;
 }
 
@@ -4244,6 +4594,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;
@@ -4260,19 +4611,25 @@ Perl_new_version(pTHX_ SV *ver)
            ver = SvRV(ver);
 
        /* Begin copying all of the elements */
            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++ )
        {
@@ -4280,7 +4637,7 @@ 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
@@ -4290,6 +4647,9 @@ Perl_new_version(pTHX_ SV *ver)
            const STRLEN len = mg->mg_len;
            char * const version = savepvn( (const char*)mg->mg_ptr, len);
            sv_setpvn(rv,version,len);
            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 ( isDIGIT(*version) )
+               sv_insert(rv, 0, 0, "v", 1);
            Safefree(version);
        }
        else {
            Safefree(version);
        }
        else {
@@ -4299,7 +4659,7 @@ Perl_new_version(pTHX_ SV *ver)
        }
     }
 #endif
        }
     }
 #endif
-    return upg_version(rv);
+    return upg_version(rv, FALSE);
 }
 
 /*
 }
 
 /*
@@ -4307,24 +4667,27 @@ 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];
 #ifdef USE_LOCALE_NUMERIC
        char *loc = setlocale(LC_NUMERIC, "C");
        char tbuf[64];
 #ifdef USE_LOCALE_NUMERIC
        char *loc = setlocale(LC_NUMERIC, "C");
@@ -4334,25 +4697,56 @@ Perl_upg_version(pTHX_ SV *ver)
        setlocale(LC_NUMERIC, loc);
 #endif
        while (tbuf[len-1] == '0' && len > 0) len--;
        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
     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
        version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
        version = savepvn(tbuf, len);
     }
 #ifdef SvVOK
     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
        version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
-       qv = 1;
+       qv = TRUE;
     }
 #endif
     else /* must be a string or something like a string */
     {
     }
 #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,"_")
+           && !(*version == 'u' && strEQ(version, "undef"))
+           && (*version < '0' || *version > '9') ) {
+           /* may be a v-string */
+           SV * const nsv = sv_newmortal();
+           const char *nver;
+           const char *pos;
+           int saw_decimal = 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_decimal++ ;
+               pos++;
+           }
+
+           /* is definitely a v-string */
+           if ( saw_decimal >= 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;
 }
@@ -4384,13 +4778,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
@@ -4417,8 +4814,11 @@ Perl_vnumify(pTHX_ SV *vs)
     I32 i, len, digit;
     int width;
     bool alpha = FALSE;
     I32 i, len, digit;
     int width;
     bool alpha = FALSE;
-    SV * const sv = newSV(0);
+    SV *sv;
     AV *av;
     AV *av;
+
+    PERL_ARGS_ASSERT_VNUMIFY;
+
     if ( SvROK(vs) )
        vs = SvRV(vs);
 
     if ( SvROK(vs) )
        vs = SvRV(vs);
 
@@ -4426,29 +4826,27 @@ 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)) ) ) {
-       sv_catpvs(sv,"0");
-       return sv;
+    if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
+       return newSVpvs("0");
     }
 
     len = av_len(av);
     if ( len == -1 )
     {
     }
 
     len = av_len(av);
     if ( len == -1 )
     {
-       sv_catpvs(sv,"0");
-       return sv;
+       return newSVpvs("0");
     }
 
     digit = SvIV(*av_fetch(av, 0, 0));
     }
 
     digit = SvIV(*av_fetch(av, 0, 0));
-    Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
+    sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
     for ( i = 1 ; i < len ; i++ )
     {
        digit = SvIV(*av_fetch(av, i, 0));
     for ( i = 1 ; i < len ; i++ )
     {
        digit = SvIV(*av_fetch(av, i, 0));
@@ -4495,26 +4893,28 @@ Perl_vnormal(pTHX_ SV *vs)
 {
     I32 i, len, digit;
     bool alpha = FALSE;
 {
     I32 i, len, digit;
     bool alpha = FALSE;
-    SV * const sv = newSV(0);
+    SV *sv;
     AV *av;
     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 )
     {
-       sv_catpvs(sv,"");
-       return sv;
+       return newSVpvs("");
     }
     digit = SvIV(*av_fetch(av, 0, 0));
     }
     digit = SvIV(*av_fetch(av, 0, 0));
-    Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
+    sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
     for ( i = 1 ; i < len ; i++ ) {
        digit = SvIV(*av_fetch(av, i, 0));
        Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
     for ( i = 1 ; i < len ; i++ ) {
        digit = SvIV(*av_fetch(av, i, 0));
        Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
@@ -4551,16 +4951,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);
+    }
 }
 
 /*
 }
 
 /*
@@ -4581,6 +4993,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) )
@@ -4593,13 +5008,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);
@@ -4789,12 +5204,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;
     }
 }
@@ -4893,14 +5308,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;
     }
 }
@@ -4936,12 +5351,34 @@ Perl_sv_nosharing(pTHX_ SV *sv)
     PERL_UNUSED_ARG(sv);
 }
 
     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);
+    return TRUE;
+}
+
 U32
 Perl_parse_unicode_opts(pTHX_ const char **popt)
 {
   const char *p = *popt;
   U32 opt = 0;
 
 U32
 Perl_parse_unicode_opts(pTHX_ const char **popt)
 {
   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);
@@ -5101,7 +5538,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. */
@@ -5121,6 +5558,7 @@ Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
     const char * const stashpv = CopSTASHPV(c);
     const char * const name = HvNAME_get(hv);
     PERL_UNUSED_CONTEXT;
     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;
@@ -5134,13 +5572,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
@@ -5168,10 +5607,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); 
@@ -5180,8 +5623,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;
 }
 
@@ -5192,188 +5635,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
 
-/*
- * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled.
+/* -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:
  *
  *
- * PERL_MEM_LOG_ENV: if defined, during run time the environment
- * variable PERL_MEM_LOG will be consulted, and if the integer value
- * of that is true, the logging will happen.  (The default is to
- * always log if the PERL_MEM_LOG define was in effect.)
+ *    \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.
  */
 
  */
 
-/*
- * PERL_MEM_LOG_SPRINTF_BUF_SIZE: size of a (stack-allocated) buffer
+/* -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
 
  * the Perl_mem_log_...() will use (either via sprintf or snprintf).
  */
 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
 
-/*
- * PERL_MEM_LOG_FD: the file descriptor the Perl_mem_log_...() will
- * log to.  You can also define in compile time PERL_MEM_LOG_ENV_FD,
- * in which case the environment variable PERL_MEM_LOG_FD will be
- * consulted for the file descriptor number to use.
+/* -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_FD
 #  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
 #endif
 
-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
-# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
-    char *s;
-# endif
-# ifdef PERL_MEM_LOG_ENV
-    s = getenv("PERL_MEM_LOG");
-    if (s ? atoi(s) : 0)
+#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
 # 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];
     {
        /* 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 PERL_MEM_LOG_TIMESTAMP
-       struct timeval tv;
+
 #   ifdef HAS_GETTIMEOFDAY
 #   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);
        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
 #   endif
        /* If there are other OS specific ways of hires time than
-        * gettimeofday() (see ext/Time/HiRes), the easiest way is
+        * gettimeofday() (see ext/Time-HiRes), the easiest way is
         * probably that they would be used to fill in the struct
         * timeval. */
         * probably that they would be used to fill in the struct
         * timeval. */
-# endif
        {
        {
-           const STRLEN len =
-               my_snprintf(buf,
-                           sizeof(buf),
-#  ifdef PERL_MEM_LOG_TIMESTAMP
-                           "%10d.%06d: "
-# endif
-                           "alloc: %s:%d:%s: %"IVdf" %"UVuf
-                           " %s = %"IVdf": %"UVxf"\n",
-#  ifdef PERL_MEM_LOG_TIMESTAMP
-                           (int)tv.tv_sec, (int)tv.tv_usec,
-# endif
-                           filename, linenumber, funcname, n, typesize,
-                           typename, n * typesize, PTR2UV(newalloc));
-# ifdef PERL_MEM_LOG_ENV_FD
-           s = PerlEnv_getenv("PERL_MEM_LOG_FD");
-           PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
-# else
-           PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
-#endif
+           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
-# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
-    char *s;
-# endif
-# ifdef PERL_MEM_LOG_ENV
-    s = PerlEnv_getenv("PERL_MEM_LOG");
-    if (s ? atoi(s) : 0)
-# endif
-    {
-       /* 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 PERL_MEM_LOG_TIMESTAMP
-       struct timeval tv;
-       gettimeofday(&tv, 0);
-# endif
-       {
-           const STRLEN len =
-               my_snprintf(buf,
-                           sizeof(buf),
-#  ifdef PERL_MEM_LOG_TIMESTAMP
-                           "%10d.%06d: "
-# endif
-                           "realloc: %s:%d:%s: %"IVdf" %"UVuf
-                           " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
-#  ifdef PERL_MEM_LOG_TIMESTAMP
-                           (int)tv.tv_sec, (int)tv.tv_usec,
-# endif
-                           filename, linenumber, funcname, n, typesize,
-                           typename, n * typesize, PTR2UV(oldalloc),
-                           PTR2UV(newalloc));
-# ifdef PERL_MEM_LOG_ENV_FD
-           s = PerlEnv_getenv("PERL_MEM_LOG_FD");
-           PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
-# else
-           PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
-# endif
-       }
-    }
-#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
-# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
-    char *s;
-# endif
-# ifdef PERL_MEM_LOG_ENV
-    s = PerlEnv_getenv("PERL_MEM_LOG");
-    if (s ? atoi(s) : 0)
-# endif
-    {
-       /* 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 PERL_MEM_LOG_TIMESTAMP
-       struct timeval tv;
-       gettimeofday(&tv, 0);
-# endif
-       {
-           const STRLEN len =
-               my_snprintf(buf,
-                           sizeof(buf),
-#  ifdef PERL_MEM_LOG_TIMESTAMP
-                           "%10d.%06d: "
-# endif
-                           "free: %s:%d:%s: %"UVxf"\n",
-#  ifdef PERL_MEM_LOG_TIMESTAMP
-                           (int)tv.tv_sec, (int)tv.tv_usec,
-# endif
-                           filename, linenumber, funcname,
-                           PTR2UV(oldalloc));
-# ifdef PERL_MEM_LOG_ENV_FD
-           s = PerlEnv_getenv("PERL_MEM_LOG_FD");
-           PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
-# else
-           PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
-# endif
-       }
-    }
-#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 */
 
 /*
@@ -5390,6 +5856,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);
@@ -5415,6 +5882,7 @@ Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
     dTHX;
     int retval;
     va_list ap;
     dTHX;
     int retval;
     va_list ap;
+    PERL_ARGS_ASSERT_MY_SNPRINTF;
     va_start(ap, format);
 #ifdef HAS_VSNPRINTF
     retval = vsnprintf(buffer, len, format, ap);
     va_start(ap, format);
 #ifdef HAS_VSNPRINTF
     retval = vsnprintf(buffer, len, format, ap);
@@ -5446,6 +5914,9 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap
     int retval;
 #ifdef NEED_VA_COPY
     va_list apc;
     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);
     Perl_va_copy(ap, apc);
 # ifdef HAS_VSNPRINTF
     retval = vsnprintf(buffer, len, format, apc);
@@ -5504,7 +5975,8 @@ Perl_my_clearenv(pTHX)
         bsiz = l + 1; /* + 1 for the \0. */
         buf = (char*)safesysmalloc(bufsiz);
       } 
         bsiz = l + 1; /* + 1 for the \0. */
         buf = (char*)safesysmalloc(bufsiz);
       } 
-      my_strlcpy(buf, *environ, l + 1);
+      memcpy(buf, *environ, l);
+      buf[l] = '\0';
       (void)unsetenv(buf);
     }
     (void)safesysfree(buf);
       (void)unsetenv(buf);
     }
     (void)safesysfree(buf);
@@ -5534,11 +6006,16 @@ Perl_my_cxt_init(pTHX_ int *index, size_t size)
 {
     dVAR;
     void *p;
 {
     dVAR;
     void *p;
+    PERL_ARGS_ASSERT_MY_CXT_INIT;
     if (*index == -1) {
        /* this module hasn't been allocated an index yet */
     if (*index == -1) {
        /* this module hasn't been allocated an index yet */
+#if defined(USE_ITHREADS)
        MUTEX_LOCK(&PL_my_ctx_mutex);
        MUTEX_LOCK(&PL_my_ctx_mutex);
+#endif
        *index = PL_my_cxt_index++;
        *index = PL_my_cxt_index++;
+#if defined(USE_ITHREADS)
        MUTEX_UNLOCK(&PL_my_ctx_mutex);
        MUTEX_UNLOCK(&PL_my_ctx_mutex);
+#endif
     }
     
     /* make sure the array is big enough */
     }
     
     /* make sure the array is big enough */
@@ -5568,6 +6045,8 @@ Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
     dVAR;
     int index;
 
     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,
     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,
@@ -5586,12 +6065,18 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
     void *p;
     int index;
 
     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 */
     index = Perl_my_cxt_index(aTHX_ my_cxt_key);
     if (index == -1) {
        /* this module hasn't been allocated an index yet */
+#if defined(USE_ITHREADS)
        MUTEX_LOCK(&PL_my_ctx_mutex);
        MUTEX_LOCK(&PL_my_ctx_mutex);
+#endif
        index = PL_my_cxt_index++;
        index = PL_my_cxt_index++;
+#if defined(USE_ITHREADS)
        MUTEX_UNLOCK(&PL_my_ctx_mutex);
        MUTEX_UNLOCK(&PL_my_ctx_mutex);
+#endif
     }
 
     /* make sure the array is big enough */
     }
 
     /* make sure the array is big enough */
@@ -5672,6 +6157,8 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
      * it's for informational purposes only.
      */
 
      * it's for informational purposes only.
      */
 
+    PERL_ARGS_ASSERT_GET_DB_SUB;
+
     save_item(dbsv);
     if (!PERLDB_SUB_NN) {
        GV * const gv = CvGV(cv);
     save_item(dbsv);
     if (!PERLDB_SUB_NN) {
        GV * const gv = CvGV(cv);
@@ -5679,10 +6166,11 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
        if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
             || strEQ(GvNAME(gv), "END")
             || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
        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((GV*)*svp) == cv) )))) {
+                !( (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. */
            /* Use GV from the stack as a fallback. */
            /* GV is potentially non-unique, or contain different CV. */
-           SV * const tmp = newRV((SV*)cv);
+           SV * const tmp = newRV(MUTABLE_SV(cv));
            sv_setsv(dbsv, tmp);
            SvREFCNT_dec(tmp);
        }
            sv_setsv(dbsv, tmp);
            SvREFCNT_dec(tmp);
        }
@@ -5699,6 +6187,38 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
     }
 }
 
     }
 }
 
+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