This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Give DBM_Filter its own Maintainers.pl entry
[perl5.git] / util.c
diff --git a/util.c b/util.c
index 7e26322..0ea39c6 100644 (file)
--- a/util.c
+++ b/util.c
@@ -1,7 +1,7 @@
 /*    util.c
  *
 /*    util.c
  *
- *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- *    2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
+ *    2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -9,8 +9,10 @@
  */
 
 /*
  */
 
 /*
- * "Very useful, no doubt, that was to Saruman; yet it seems that he was
- * not content."  --Gandalf
+ * 'Very useful, no doubt, that was to Saruman; yet it seems that he was
+ *  not content.'                                    --Gandalf to Pippin
+ *
+ *     [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"]
  */
 
 /* This file contains assorted utility routines.
  */
 
 /* This file contains assorted utility routines.
 #define PERL_IN_UTIL_C
 #include "perl.h"
 
 #define PERL_IN_UTIL_C
 #include "perl.h"
 
+#ifdef USE_PERLIO
+#include "perliol.h" /* For PerlIOUnix_refcnt */
+#endif
+
 #ifndef PERL_MICRO
 #include <signal.h>
 #ifndef SIG_ERR
 #ifndef PERL_MICRO
 #include <signal.h>
 #ifndef SIG_ERR
@@ -68,12 +74,18 @@ S_write_no_mem(pTHX)
     NORETURN_FUNCTION_END;
 }
 
     NORETURN_FUNCTION_END;
 }
 
+#if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
+#  define ALWAYS_NEED_THX
+#endif
+
 /* paranoid version of system's malloc() */
 
 Malloc_t
 Perl_safesysmalloc(MEM_SIZE size)
 {
 /* paranoid version of system's malloc() */
 
 Malloc_t
 Perl_safesysmalloc(MEM_SIZE size)
 {
+#ifdef ALWAYS_NEED_THX
     dTHX;
     dTHX;
+#endif
     Malloc_t ptr;
 #ifdef HAS_64K_LIMIT
        if (size > 0xffff) {
     Malloc_t ptr;
 #ifdef HAS_64K_LIMIT
        if (size > 0xffff) {
@@ -91,7 +103,6 @@ Perl_safesysmalloc(MEM_SIZE size)
 #endif
     ptr = (Malloc_t)PerlMem_malloc(size?size:1);       /* malloc(0) is NASTY on our system */
     PERL_ALLOC_CHECK(ptr);
 #endif
     ptr = (Malloc_t)PerlMem_malloc(size?size:1);       /* malloc(0) is NASTY on our system */
     PERL_ALLOC_CHECK(ptr);
-    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
     if (ptr != NULL) {
 #ifdef PERL_TRACK_MEMPOOL
        struct perl_memory_debug_header *const header
     if (ptr != NULL) {
 #ifdef PERL_TRACK_MEMPOOL
        struct perl_memory_debug_header *const header
@@ -114,12 +125,18 @@ Perl_safesysmalloc(MEM_SIZE size)
 #  endif
         ptr = (Malloc_t)((char*)ptr+sTHX);
 #endif
 #  endif
         ptr = (Malloc_t)((char*)ptr+sTHX);
 #endif
+       DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
        return ptr;
 }
        return ptr;
 }
-    else if (PL_nomemok)
-       return NULL;
     else {
     else {
-       return write_no_mem();
+#ifndef ALWAYS_NEED_THX
+       dTHX;
+#endif
+       if (PL_nomemok)
+           return NULL;
+       else {
+           return write_no_mem();
+       }
     }
     /*NOTREACHED*/
 }
     }
     /*NOTREACHED*/
 }
@@ -129,7 +146,9 @@ Perl_safesysmalloc(MEM_SIZE size)
 Malloc_t
 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 {
 Malloc_t
 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 {
+#ifdef ALWAYS_NEED_THX
     dTHX;
     dTHX;
+#endif
     Malloc_t ptr;
 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
     Malloc_t PerlMem_realloc();
     Malloc_t ptr;
 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
     Malloc_t PerlMem_realloc();
@@ -178,11 +197,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,13 +217,28 @@ 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;
     }
        return ptr;
     }
-    else if (PL_nomemok)
-       return NULL;
     else {
     else {
-       return write_no_mem();
+#ifndef ALWAYS_NEED_THX
+       dTHX;
+#endif
+       if (PL_nomemok)
+           return NULL;
+       else {
+           return write_no_mem();
+       }
     }
     /*NOTREACHED*/
 }
     }
     /*NOTREACHED*/
 }
@@ -214,7 +248,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 Free_t
 Perl_safesysfree(Malloc_t where)
 {
 Free_t
 Perl_safesysfree(Malloc_t where)
 {
-#if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL)
+#ifdef ALWAYS_NEED_THX
     dTHX;
 #else
     dVAR;
     dTHX;
 #else
     dVAR;
@@ -256,13 +290,27 @@ Perl_safesysfree(Malloc_t where)
 Malloc_t
 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 {
 Malloc_t
 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 {
+#ifdef ALWAYS_NEED_THX
     dTHX;
     dTHX;
+#endif
     Malloc_t ptr;
     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 +318,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,16 +347,21 @@ 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
        return ptr;
     }
 #  endif
            ptr = (Malloc_t)((char*)ptr+sTHX);
        }
 #endif
        return ptr;
     }
-    else if (PL_nomemok)
-       return NULL;
-    return write_no_mem();
+    else {
+#ifndef ALWAYS_NEED_THX
+       dTHX;
+#endif
+       if (PL_nomemok)
+           return NULL;
+       return write_no_mem();
+    }
 }
 
 /* These must be defined when not using Perl's malloc for binary
 }
 
 /* These must be defined when not using Perl's malloc for binary
@@ -337,10 +398,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 +428,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 +462,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 +488,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;
@@ -454,8 +518,6 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit
     return NULL;
 }
 
     return NULL;
 }
 
-#define FBM_TABLE_OFFSET 2     /* Number of bytes between EOS and table*/
-
 /* As a space optimization, we do not compile tables for strings of length
    0 and 1, and for strings of length 2 unless FBMcf_TAIL.  These are
    special-cased in fbm_instr().
 /* As a space optimization, we do not compile tables for strings of length
    0 and 1, and for strings of length 2 unless FBMcf_TAIL.  These are
    special-cased in fbm_instr().
@@ -480,9 +542,11 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
     register const U8 *s;
     register U32 i;
     STRLEN len;
     register const U8 *s;
     register U32 i;
     STRLEN len;
-    I32 rarest = 0;
+    U32 rarest = 0;
     U32 frequency = 256;
 
     U32 frequency = 256;
 
+    PERL_ARGS_ASSERT_FBM_COMPILE;
+
     if (flags & FBMcf_TAIL) {
        MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
        sv_catpvs(sv, "\n");            /* Taken into account in fbm_instr() */
     if (flags & FBMcf_TAIL) {
        MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
        sv_catpvs(sv, "\n");            /* Taken into account in fbm_instr() */
@@ -490,19 +554,22 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
            mg->mg_len++;
     }
     s = (U8*)SvPV_force_mutable(sv, len);
            mg->mg_len++;
     }
     s = (U8*)SvPV_force_mutable(sv, len);
-    SvUPGRADE(sv, SVt_PVBM);
     if (len == 0)              /* TAIL might be on a zero-length string. */
        return;
     if (len == 0)              /* TAIL might be on a zero-length string. */
        return;
+    SvUPGRADE(sv, SVt_PVGV);
+    SvIOK_off(sv);
+    SvNOK_off(sv);
+    SvVALID_on(sv);
     if (len > 2) {
        const unsigned char *sb;
        const U8 mlen = (len>255) ? 255 : (U8)len;
        register U8 *table;
 
     if (len > 2) {
        const unsigned char *sb;
        const U8 mlen = (len>255) ? 255 : (U8)len;
        register U8 *table;
 
-       Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
-       table = (unsigned char*)(SvPVX_mutable(sv) + len + FBM_TABLE_OFFSET);
-       s = table - 1 - FBM_TABLE_OFFSET;       /* last char */
+       Sv_Grow(sv, len + 256 + PERL_FBM_TABLE_OFFSET);
+       table
+           = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
+       s = table - 1 - PERL_FBM_TABLE_OFFSET;  /* last char */
        memset((void*)table, mlen, 256);
        memset((void*)table, mlen, 256);
-       table[-1] = (U8)flags;
        i = 0;
        sb = s - mlen + 1;                      /* first char (maybe) */
        while (s >= sb) {
        i = 0;
        sb = s - mlen + 1;                      /* first char (maybe) */
        while (s >= sb) {
@@ -510,9 +577,10 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
                table[*s] = (U8)i;
            s--, i++;
        }
                table[*s] = (U8)i;
            s--, i++;
        }
+    } else {
+       Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET);
     }
     sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0);        /* deep magic */
     }
     sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0);        /* deep magic */
-    SvVALID_on(sv);
 
     s = (const unsigned char*)(SvPVX_const(sv));       /* deeper magic */
     for (i = 0; i < len; i++) {
 
     s = (const unsigned char*)(SvPVX_const(sv));       /* deeper magic */
     for (i = 0; i < len; i++) {
@@ -521,13 +589,14 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
            frequency = PL_freq[s[i]];
        }
     }
            frequency = PL_freq[s[i]];
        }
     }
+    BmFLAGS(sv) = (U8)flags;
     BmRARE(sv) = s[rarest];
     BmRARE(sv) = s[rarest];
-    BmPREVIOUS(sv) = (U16)rarest;
+    BmPREVIOUS(sv) = rarest;
     BmUSEFUL(sv) = 100;                        /* Initial value */
     if (flags & FBMcf_TAIL)
        SvTAIL_on(sv);
     BmUSEFUL(sv) = 100;                        /* Initial value */
     if (flags & FBMcf_TAIL)
        SvTAIL_on(sv);
-    DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
-                         BmRARE(sv),BmPREVIOUS(sv)));
+    DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n",
+                         BmRARE(sv),(unsigned long)BmPREVIOUS(sv)));
 }
 
 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
 }
 
 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
@@ -555,6 +624,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)
@@ -663,7 +734,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
        }
        return NULL;
     }
        }
        return NULL;
     }
-    if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
+    if (!SvVALID(littlestr)) {
        char * const b = ninstr((char*)big,(char*)bigend,
                         (char*)little, (char*)little + littlelen);
 
        char * const b = ninstr((char*)big,(char*)bigend,
                         (char*)little, (char*)little + littlelen);
 
@@ -680,12 +751,15 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
        return b;
     }
 
        return b;
     }
 
-    {  /* Do actual FBM.  */
-       register const unsigned char * const table = little + littlelen + FBM_TABLE_OFFSET;
+    /* Do actual FBM.  */
+    if (littlelen > (STRLEN)(bigend - big))
+       return NULL;
+
+    {
+       register const unsigned char * const table
+           = little + littlelen + PERL_FBM_TABLE_OFFSET;
        register const unsigned char *oldlittle;
 
        register const unsigned char *oldlittle;
 
-       if (littlelen > (STRLEN)(bigend - big))
-           return NULL;
        --littlelen;                    /* Last char found by table lookup */
 
        s = big + littlelen;
        --littlelen;                    /* Last char found by table lookup */
 
        s = big + littlelen;
@@ -718,7 +792,8 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
            }
        }
       check_end:
            }
        }
       check_end:
-       if ( s == bigend && (table[-1] & FBMcf_TAIL)
+       if ( s == bigend
+            && (BmFLAGS(littlestr) & FBMcf_TAIL)
             && memEQ((char *)(bigend - littlelen),
                      (char *)(oldlittle - littlelen), littlelen) )
            return (char*)bigend - littlelen;
             && memEQ((char *)(bigend - littlelen),
                      (char *)(oldlittle - littlelen), littlelen) )
            return (char*)bigend - littlelen;
@@ -754,6 +829,11 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
     register const unsigned char *littleend;
     I32 found = 0;
 
     register const unsigned char *littleend;
     I32 found = 0;
 
+    PERL_ARGS_ASSERT_SCREAMINSTR;
+
+    assert(SvTYPE(littlestr) == SVt_PVGV);
+    assert(SvVALID(littlestr));
+
     if (*old_posp == -1
        ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
        : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
     if (*old_posp == -1
        ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
        : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
@@ -827,35 +907,79 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
     return NULL;
 }
 
     return NULL;
 }
 
+/*
+=for apidoc foldEQ
+
+Returns true if the leading len bytes of the strings s1 and s2 are the same
+case-insensitively; false otherwise.  Uppercase and lowercase ASCII range bytes
+match themselves and their opposite case counterparts.  Non-cased and non-ASCII
+range bytes match only themselves.
+
+=cut
+*/
+
+
 I32
 I32
-Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
+Perl_foldEQ(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_FOLDEQ;
 
     while (len--) {
        if (*a != *b && *a != PL_fold[*b])
 
     while (len--) {
        if (*a != *b && *a != PL_fold[*b])
-           return 1;
+           return 0;
        a++,b++;
     }
        a++,b++;
     }
-    return 0;
+    return 1;
+}
+I32
+Perl_foldEQ_latin1(const char *s1, const char *s2, register I32 len)
+{
+    /* Compare non-utf8 using Unicode (Latin1) semantics.  Does not work on
+     * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
+     * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these.  Nor
+     * does it check that the strings each have at least 'len' characters */
+
+    register const U8 *a = (const U8 *)s1;
+    register const U8 *b = (const U8 *)s2;
+
+    PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
+
+    while (len--) {
+       if (*a != *b && *a != PL_fold_latin1[*b]) {
+           return 0;
+       }
+       a++, b++;
+    }
+    return 1;
 }
 
 }
 
+/*
+=for apidoc foldEQ_locale
+
+Returns true if the leading len bytes of the strings s1 and s2 are the same
+case-insensitively in the current locale; false otherwise.
+
+=cut
+*/
+
 I32
 I32
-Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
+Perl_foldEQ_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_FOLDEQ_LOCALE;
 
     while (len--) {
        if (*a != *b && *a != PL_fold_locale[*b])
 
     while (len--) {
        if (*a != *b && *a != PL_fold_locale[*b])
-           return 1;
+           return 0;
        a++,b++;
     }
        a++,b++;
     }
-    return 0;
+    return 1;
 }
 
 /* copy a string to a safe spot */
 }
 
 /* copy a string to a safe spot */
@@ -943,6 +1067,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
@@ -958,11 +1105,32 @@ 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);
 }
 
+/*
+=for apidoc savesharedsvpv
+
+A version of C<savesharedpv()> which allocates the duplicate string in
+memory which is shared between threads.
+
+=cut
+*/
+
+char *
+Perl_savesharedsvpv(pTHX_ SV *sv)
+{
+    STRLEN len;
+    const char * const pv = SvPV_const(sv, len);
+
+    PERL_ARGS_ASSERT_SAVESHAREDSVPV;
+
+    return savesharedpvn(pv, len);
+}
 
 /* the SV for Perl_form() and mess() is not kept in an arena */
 
 
 /* the SV for Perl_form() and mess() is not kept in an arena */
 
@@ -973,8 +1141,8 @@ S_mess_alloc(pTHX)
     SV *sv;
     XPVMG *any;
 
     SV *sv;
     XPVMG *any;
 
-    if (!PL_dirty)
-       return sv_2mortal(newSVpvs(""));
+    if (PL_phase != PERL_PHASE_DESTRUCT)
+       return newSVpvs_flags("", SVs_TEMP);
 
     if (PL_mess_sv)
        return PL_mess_sv;
 
     if (PL_mess_sv)
        return PL_mess_sv;
@@ -997,6 +1165,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);
@@ -1029,6 +1198,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);
@@ -1039,10 +1209,26 @@ 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);
 }
 
+/*
+=for apidoc Am|SV *|mess|const char *pat|...
+
+Take a sprintf-style format pattern and argument list.  These are used to
+generate a string message.  If the message does not end with a newline,
+then it will be extended with some indication of the current location
+in the code, as described for L</mess_sv>.
+
+Normally, the resulting message is returned in a new mortal SV.
+During global destruction a single SV may be shared between uses of
+this function.
+
+=cut
+*/
+
 #if defined(PERL_IMPLICIT_CONTEXT)
 SV *
 Perl_mess_nocontext(const char *pat, ...)
 #if defined(PERL_IMPLICIT_CONTEXT)
 SV *
 Perl_mess_nocontext(const char *pat, ...)
@@ -1050,6 +1236,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);
@@ -1062,6 +1249,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);
@@ -1074,6 +1262,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;
 
@@ -1101,13 +1291,57 @@ S_closest_cop(pTHX_ const COP *cop, const OP *o)
     return NULL;
 }
 
     return NULL;
 }
 
+/*
+=for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
+
+Expands a message, intended for the user, to include an indication of
+the current location in the code, if the message does not already appear
+to be complete.
+
+C<basemsg> is the initial message or object.  If it is a reference, it
+will be used as-is and will be the result of this function.  Otherwise it
+is used as a string, and if it already ends with a newline, it is taken
+to be complete, and the result of this function will be the same string.
+If the message does not end with a newline, then a segment such as C<at
+foo.pl line 37> will be appended, and possibly other clauses indicating
+the current state of execution.  The resulting message will end with a
+dot and a newline.
+
+Normally, the resulting message is returned in a new mortal SV.
+During global destruction a single SV may be shared between uses of this
+function.  If C<consume> is true, then the function is permitted (but not
+required) to modify and return C<basemsg> instead of allocating a new SV.
+
+=cut
+*/
+
 SV *
 SV *
-Perl_vmess(pTHX_ const char *pat, va_list *args)
+Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
 {
     dVAR;
 {
     dVAR;
-    SV * const sv = mess_alloc();
+    SV *sv;
+
+    PERL_ARGS_ASSERT_MESS_SV;
+
+    if (SvROK(basemsg)) {
+       if (consume) {
+           sv = basemsg;
+       }
+       else {
+           sv = mess_alloc();
+           sv_setsv(sv, basemsg);
+       }
+       return sv;
+    }
+
+    if (SvPOK(basemsg) && consume) {
+       sv = basemsg;
+    }
+    else {
+       sv = mess_alloc();
+       sv_copypv(sv, basemsg);
+    }
 
 
-    sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
        /*
         * Try and find the file and line for PL_op.  This will usually be
     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
        /*
         * Try and find the file and line for PL_op.  This will usually be
@@ -1123,7 +1357,10 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
        if (CopLINE(cop))
            Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
            OutCopFILE(cop), (IV)CopLINE(cop));
        if (CopLINE(cop))
            Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
            OutCopFILE(cop), (IV)CopLINE(cop));
-       if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
+       /* Seems that GvIO() can be untrustworthy during global destruction. */
+       if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
+               && IoLINES(GvIOp(PL_last_in_gv)))
+       {
            const bool line_mode = (RsSIMPLE(PL_rs) &&
                              SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
            Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
            const bool line_mode = (RsSIMPLE(PL_rs) &&
                              SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
            Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
@@ -1131,64 +1368,90 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
                           line_mode ? "line" : "chunk",
                           (IV)IoLINES(GvIOp(PL_last_in_gv)));
        }
                           line_mode ? "line" : "chunk",
                           (IV)IoLINES(GvIOp(PL_last_in_gv)));
        }
-       if (PL_dirty)
+       if (PL_phase == PERL_PHASE_DESTRUCT)
            sv_catpvs(sv, " during global destruction");
        sv_catpvs(sv, ".\n");
     }
     return sv;
 }
 
            sv_catpvs(sv, " during global destruction");
        sv_catpvs(sv, ".\n");
     }
     return sv;
 }
 
+/*
+=for apidoc Am|SV *|vmess|const char *pat|va_list *args
+
+C<pat> and C<args> are a sprintf-style format pattern and encapsulated
+argument list.  These are used to generate a string message.  If the
+message does not end with a newline, then it will be extended with
+some indication of the current location in the code, as described for
+L</mess_sv>.
+
+Normally, the resulting message is returned in a new mortal SV.
+During global destruction a single SV may be shared between uses of
+this function.
+
+=cut
+*/
+
+SV *
+Perl_vmess(pTHX_ const char *pat, va_list *args)
+{
+    dVAR;
+    SV * const sv = mess_alloc();
+
+    PERL_ARGS_ASSERT_VMESS;
+
+    sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
+    return mess_sv(sv, 1);
+}
+
 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))) 
-    {
-       dSP;
-       ENTER;
-       SAVETMPS;
-
-       save_re_context();
-       SAVESPTR(PL_stderrgv);
-       PL_stderrgv = NULL;
-
-       PUSHSTACKi(PERLSI_MAGIC);
-
-       PUSHMARK(SP);
-       EXTEND(SP,2);
-       PUSHs(SvTIED_obj((SV*)io, mg));
-       PUSHs(sv_2mortal(newSVpvn(message, msglen)));
-       PUTBACK;
-       call_method("PRINT", G_SCALAR);
-
-       POPSTACK;
-       FREETMPS;
-       LEAVE;
-    }
+       && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) 
+       Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, "PRINT",
+                           G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
     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;
 
-       PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
+       do_print(msv, serr);
        (void)PerlIO_flush(serr);
 #ifdef USE_SFIO
        (void)PerlIO_flush(serr);
 #ifdef USE_SFIO
-       errno = e;
+       RESTORE_ERRNO;
 #endif
     }
 }
 
 #endif
     }
 }
 
-/* Common code used by vcroak, vdie, vwarn and vwarner  */
+/*
+=head1 Warning and Dieing
+*/
+
+/* Common code used in dieing and warning */
+
+STATIC SV *
+S_with_queued_errors(pTHX_ SV *ex)
+{
+    PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
+    if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
+       sv_catsv(PL_errors, ex);
+       ex = sv_mortalcopy(PL_errors);
+       SvCUR_set(PL_errors, 0);
+    }
+    return ex;
+}
 
 STATIC bool
 
 STATIC bool
-S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
+S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
 {
     dVAR;
     HV *stash;
 {
     dVAR;
     HV *stash;
@@ -1198,7 +1461,8 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
     /* sv_2cv might call Perl_croak() or Perl_warner() */
     SV * const oldhook = *hook;
 
     /* sv_2cv might call Perl_croak() or Perl_warner() */
     SV * const oldhook = *hook;
 
-    assert(oldhook);
+    if (!oldhook)
+       return FALSE;
 
     ENTER;
     SAVESPTR(*hook);
 
     ENTER;
     SAVESPTR(*hook);
@@ -1207,7 +1471,7 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
     LEAVE;
     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
        dSP;
     LEAVE;
     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
        dSP;
-       SV *msg;
+       SV *exarg;
 
        ENTER;
        save_re_context();
 
        ENTER;
        save_re_context();
@@ -1215,21 +1479,15 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
            SAVESPTR(*hook);
            *hook = NULL;
        }
            SAVESPTR(*hook);
            *hook = NULL;
        }
-       if (warn || message) {
-           msg = newSVpvn(message, msglen);
-           SvFLAGS(msg) |= utf8;
-           SvREADONLY_on(msg);
-           SAVEFREESV(msg);
-       }
-       else {
-           msg = ERRSV;
-       }
+       exarg = newSVsv(ex);
+       SvREADONLY_on(exarg);
+       SAVEFREESV(exarg);
 
        PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
        PUSHMARK(SP);
 
        PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
        PUSHMARK(SP);
-       XPUSHs(msg);
+       XPUSHs(exarg);
        PUTBACK;
        PUTBACK;
-       call_sv((SV*)cv, G_DISCARD);
+       call_sv(MUTABLE_SV(cv), G_DISCARD);
        POPSTACK;
        LEAVE;
        return TRUE;
        POPSTACK;
        LEAVE;
        return TRUE;
@@ -1237,194 +1495,278 @@ 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)
-{
-    dVAR;
-    const char *message;
+/*
+=for apidoc Am|OP *|die_sv|SV *baseex
 
 
-    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);
-           SvCUR_set(PL_errors, 0);
-       }
-       else
-           message = SvPV_const(msv,*msglen);
-       *utf8 = SvUTF8(msv);
-    }
-    else {
-       message = NULL;
-    }
+Behaves the same as L</croak_sv>, except for the return type.
+It should be used only where the C<OP *> return type is required.
+The function never actually returns.
 
 
-    DEBUG_S(PerlIO_printf(Perl_debug_log,
-                         "%p: die/croak: message = %s\ndiehook = %p\n",
-                         thr, message, PL_diehook));
-    if (PL_diehook) {
-       S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
-    }
-    return message;
-}
+=cut
+*/
 
 OP *
 
 OP *
-Perl_vdie(pTHX_ const char* pat, va_list *args)
+Perl_die_sv(pTHX_ SV *baseex)
 {
 {
-    dVAR;
-    const char *message;
-    const int was_in_eval = PL_in_eval;
-    STRLEN msglen;
-    I32 utf8 = 0;
+    PERL_ARGS_ASSERT_DIE_SV;
+    croak_sv(baseex);
+    /* NOTREACHED */
+    return NULL;
+}
 
 
-    DEBUG_S(PerlIO_printf(Perl_debug_log,
-                         "%p: die: curstack = %p, mainstack = %p\n",
-                         thr, PL_curstack, PL_mainstack));
+/*
+=for apidoc Am|OP *|die|const char *pat|...
 
 
-    message = vdie_croak_common(pat, args, &msglen, &utf8);
+Behaves the same as L</croak>, except for the return type.
+It should be used only where the C<OP *> return type is required.
+The function never actually returns.
 
 
-    PL_restartop = die_where(message, msglen);
-    SvFLAGS(ERRSV) |= utf8;
-    DEBUG_S(PerlIO_printf(Perl_debug_log,
-         "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
-         thr, PL_restartop, was_in_eval, PL_top_env));
-    if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
-       JMPENV_JUMP(3);
-    return PL_restartop;
-}
+=cut
+*/
 
 #if defined(PERL_IMPLICIT_CONTEXT)
 OP *
 Perl_die_nocontext(const char* pat, ...)
 {
     dTHX;
 
 #if defined(PERL_IMPLICIT_CONTEXT)
 OP *
 Perl_die_nocontext(const char* pat, ...)
 {
     dTHX;
-    OP *o;
     va_list args;
     va_start(args, pat);
     va_list args;
     va_start(args, pat);
-    o = vdie(pat, &args);
+    vcroak(pat, &args);
+    /* NOTREACHED */
     va_end(args);
     va_end(args);
-    return o;
+    return NULL;
 }
 #endif /* PERL_IMPLICIT_CONTEXT */
 
 OP *
 Perl_die(pTHX_ const char* pat, ...)
 {
 }
 #endif /* PERL_IMPLICIT_CONTEXT */
 
 OP *
 Perl_die(pTHX_ const char* pat, ...)
 {
-    OP *o;
     va_list args;
     va_start(args, pat);
     va_list args;
     va_start(args, pat);
-    o = vdie(pat, &args);
+    vcroak(pat, &args);
+    /* NOTREACHED */
     va_end(args);
     va_end(args);
-    return o;
+    return NULL;
 }
 
 }
 
-void
-Perl_vcroak(pTHX_ const char* pat, va_list *args)
-{
-    dVAR;
-    const char *message;
-    STRLEN msglen;
-    I32 utf8 = 0;
+/*
+=for apidoc Am|void|croak_sv|SV *baseex
 
 
-    message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
+This is an XS interface to Perl's C<die> function.
 
 
-    if (PL_in_eval) {
-       PL_restartop = die_where(message, msglen);
-       SvFLAGS(ERRSV) |= utf8;
-       JMPENV_JUMP(3);
-    }
-    else if (!message)
-       message = SvPVx_const(ERRSV, msglen);
+C<baseex> is the error message or object.  If it is a reference, it
+will be used as-is.  Otherwise it is used as a string, and if it does
+not end with a newline then it will be extended with some indication of
+the current location in the code, as described for L</mess_sv>.
 
 
-    write_to_stderr(message, msglen);
-    my_failure_exit();
-}
+The error message or object will be used as an exception, by default
+returning control to the nearest enclosing C<eval>, but subject to
+modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak_sv>
+function never returns normally.
+
+To die with a simple string message, the L</croak> function may be
+more convenient.
+
+=cut
+*/
 
 
-#if defined(PERL_IMPLICIT_CONTEXT)
 void
 void
-Perl_croak_nocontext(const char *pat, ...)
+Perl_croak_sv(pTHX_ SV *baseex)
 {
 {
-    dTHX;
-    va_list args;
-    va_start(args, pat);
-    vcroak(pat, &args);
-    /* NOTREACHED */
-    va_end(args);
+    SV *ex = with_queued_errors(mess_sv(baseex, 0));
+    PERL_ARGS_ASSERT_CROAK_SV;
+    invoke_exception_hook(ex, FALSE);
+    die_unwind(ex);
 }
 }
-#endif /* PERL_IMPLICIT_CONTEXT */
 
 /*
 
 /*
-=head1 Warning and Dieing
+=for apidoc Am|void|vcroak|const char *pat|va_list *args
 
 
-=for apidoc croak
+This is an XS interface to Perl's C<die> function.
 
 
-This is the XSUB-writer's interface to Perl's C<die> function.
-Normally call this function the same way you call the C C<printf>
-function.  Calling C<croak> returns control directly to Perl,
-sidestepping the normal C order of execution. See C<warn>.
+C<pat> and C<args> are a sprintf-style format pattern and encapsulated
+argument list.  These are used to generate a string message.  If the
+message does not end with a newline, then it will be extended with
+some indication of the current location in the code, as described for
+L</mess_sv>.
 
 
-If you want to throw an exception object, assign the object to
-C<$@> and then pass C<NULL> to croak():
+The error message will be used as an exception, by default
+returning control to the nearest enclosing C<eval>, but subject to
+modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak>
+function never returns normally.
 
 
-   errsv = get_sv("@", TRUE);
-   sv_setsv(errsv, exception_object);
-   croak(NULL);
+For historical reasons, if C<pat> is null then the contents of C<ERRSV>
+(C<$@>) will be used as an error message or object instead of building an
+error message from arguments.  If you want to throw a non-string object,
+or build an error message in an SV yourself, it is preferable to use
+the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
 
 =cut
 */
 
 void
 
 =cut
 */
 
 void
-Perl_croak(pTHX_ const char *pat, ...)
+Perl_vcroak(pTHX_ const char* pat, va_list *args)
 {
 {
-    va_list args;
-    va_start(args, pat);
-    vcroak(pat, &args);
-    /* NOTREACHED */
-    va_end(args);
+    SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
+    invoke_exception_hook(ex, FALSE);
+    die_unwind(ex);
 }
 
 }
 
-void
-Perl_vwarn(pTHX_ const char* pat, va_list *args)
-{
-    dVAR;
-    STRLEN msglen;
-    SV * const msv = vmess(pat, args);
-    const I32 utf8 = SvUTF8(msv);
-    const char * const message = SvPV_const(msv, msglen);
+/*
+=for apidoc Am|void|croak|const char *pat|...
 
 
-    if (PL_warnhook) {
-       if (vdie_common(message, msglen, utf8, TRUE))
-           return;
-    }
+This is an XS interface to Perl's C<die> function.
 
 
-    write_to_stderr(message, msglen);
-}
+Take a sprintf-style format pattern and argument list.  These are used to
+generate a string message.  If the message does not end with a newline,
+then it will be extended with some indication of the current location
+in the code, as described for L</mess_sv>.
+
+The error message will be used as an exception, by default
+returning control to the nearest enclosing C<eval>, but subject to
+modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak>
+function never returns normally.
+
+For historical reasons, if C<pat> is null then the contents of C<ERRSV>
+(C<$@>) will be used as an error message or object instead of building an
+error message from arguments.  If you want to throw a non-string object,
+or build an error message in an SV yourself, it is preferable to use
+the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
+
+=cut
+*/
 
 #if defined(PERL_IMPLICIT_CONTEXT)
 void
 
 #if defined(PERL_IMPLICIT_CONTEXT)
 void
-Perl_warn_nocontext(const char *pat, ...)
+Perl_croak_nocontext(const char *pat, ...)
 {
     dTHX;
     va_list args;
     va_start(args, pat);
 {
     dTHX;
     va_list args;
     va_start(args, pat);
-    vwarn(pat, &args);
+    vcroak(pat, &args);
+    /* NOTREACHED */
     va_end(args);
 }
 #endif /* PERL_IMPLICIT_CONTEXT */
 
     va_end(args);
 }
 #endif /* PERL_IMPLICIT_CONTEXT */
 
+void
+Perl_croak(pTHX_ const char *pat, ...)
+{
+    va_list args;
+    va_start(args, pat);
+    vcroak(pat, &args);
+    /* NOTREACHED */
+    va_end(args);
+}
+
+/*
+=for apidoc Am|void|croak_no_modify
+
+Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
+terser object code than using C<Perl_croak>. Less code used on exception code
+paths reduces CPU cache pressure.
+
+=cut
+*/
+
+void
+Perl_croak_no_modify(pTHX)
+{
+    Perl_croak(aTHX_ "%s", PL_no_modify);
+}
+
 /*
 /*
-=for apidoc warn
+=for apidoc Am|void|warn_sv|SV *baseex
 
 
-This is the XSUB-writer's interface to Perl's C<warn> function.  Call this
-function the same way you call the C C<printf> function.  See C<croak>.
+This is an XS interface to Perl's C<warn> function.
+
+C<baseex> is the error message or object.  If it is a reference, it
+will be used as-is.  Otherwise it is used as a string, and if it does
+not end with a newline then it will be extended with some indication of
+the current location in the code, as described for L</mess_sv>.
+
+The error message or object will by default be written to standard error,
+but this is subject to modification by a C<$SIG{__WARN__}> handler.
+
+To warn with a simple string message, the L</warn> function may be
+more convenient.
+
+=cut
+*/
+
+void
+Perl_warn_sv(pTHX_ SV *baseex)
+{
+    SV *ex = mess_sv(baseex, 0);
+    PERL_ARGS_ASSERT_WARN_SV;
+    if (!invoke_exception_hook(ex, TRUE))
+       write_to_stderr(ex);
+}
+
+/*
+=for apidoc Am|void|vwarn|const char *pat|va_list *args
+
+This is an XS interface to Perl's C<warn> function.
+
+C<pat> and C<args> are a sprintf-style format pattern and encapsulated
+argument list.  These are used to generate a string message.  If the
+message does not end with a newline, then it will be extended with
+some indication of the current location in the code, as described for
+L</mess_sv>.
+
+The error message or object will by default be written to standard error,
+but this is subject to modification by a C<$SIG{__WARN__}> handler.
+
+Unlike with L</vcroak>, C<pat> is not permitted to be null.
 
 =cut
 */
 
 void
 
 =cut
 */
 
 void
+Perl_vwarn(pTHX_ const char* pat, va_list *args)
+{
+    SV *ex = vmess(pat, args);
+    PERL_ARGS_ASSERT_VWARN;
+    if (!invoke_exception_hook(ex, TRUE))
+       write_to_stderr(ex);
+}
+
+/*
+=for apidoc Am|void|warn|const char *pat|...
+
+This is an XS interface to Perl's C<warn> function.
+
+Take a sprintf-style format pattern and argument list.  These are used to
+generate a string message.  If the message does not end with a newline,
+then it will be extended with some indication of the current location
+in the code, as described for L</mess_sv>.
+
+The error message or object will by default be written to standard error,
+but this is subject to modification by a C<$SIG{__WARN__}> handler.
+
+Unlike with L</croak>, C<pat> is not permitted to be null.
+
+=cut
+*/
+
+#if defined(PERL_IMPLICIT_CONTEXT)
+void
+Perl_warn_nocontext(const char *pat, ...)
+{
+    dTHX;
+    va_list args;
+    PERL_ARGS_ASSERT_WARN_NOCONTEXT;
+    va_start(args, pat);
+    vwarn(pat, &args);
+    va_end(args);
+}
+#endif /* PERL_IMPLICIT_CONTEXT */
+
+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);
@@ -1436,6 +1778,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);
@@ -1443,9 +1786,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);
@@ -1455,23 +1825,12 @@ 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) {
-           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);
-       }
-       write_to_stderr(message, msglen);
-       my_failure_exit();
+       invoke_exception_hook(msv, FALSE);
+       die_unwind(msv);
     }
     else {
        Perl_vwarn(aTHX_ pat, args);
     }
     else {
        Perl_vwarn(aTHX_ pat, args);
@@ -1484,26 +1843,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 */
@@ -1512,22 +1856,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.  */
@@ -1536,6 +1900,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) ?
@@ -1571,9 +1936,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;
@@ -1677,28 +2049,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
@@ -1707,6 +2057,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;
@@ -1720,6 +2072,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++;
@@ -1741,6 +2095,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;
@@ -1754,6 +2110,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;
@@ -1769,6 +2127,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;
@@ -1778,24 +2138,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
@@ -1828,7 +2215,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;
@@ -2122,6 +2512,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;
@@ -2130,9 +2522,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;
@@ -2141,6 +2533,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;
@@ -2163,6 +2557,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) {
@@ -2220,9 +2615,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;
@@ -2258,13 +2651,17 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
         PerlLIO_close(pp[0]);
     return PerlIO_fdopen(p[This], mode);
 #else
         PerlLIO_close(pp[0]);
     return PerlIO_fdopen(p[This], mode);
 #else
+#  ifdef OS2   /* Same, without fork()ing and all extra overhead... */
+    return my_syspopen4(aTHX_ NULL, mode, n, args);
+#  else
     Perl_croak(aTHX_ "List form of piped open not implemented");
     return (PerlIO *) NULL;
     Perl_croak(aTHX_ "List form of piped open not implemented");
     return (PerlIO *) NULL;
+#  endif
 #endif
 }
 
     /* VMS' my_popen() is in VMS.c, same with OS/2. */
 #endif
 }
 
     /* VMS' my_popen() is in VMS.c, same with OS/2. */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
 PerlIO *
 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 {
 PerlIO *
 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 {
@@ -2277,6 +2674,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) {
@@ -2302,9 +2701,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) {
@@ -2347,6 +2747,14 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
            PerlProc__exit(1);
        }
 #endif /* defined OS2 */
            PerlProc__exit(1);
        }
 #endif /* defined OS2 */
+
+#ifdef PERLIO_USING_CRLF
+   /* Since we circumvent IO layers when we manipulate low-level
+      filedescriptors directly, need to manually switch to the
+      default, binary, low-level mode; see PerlIOBuf_open(). */
+   PerlLIO_setmode((*mode == 'r'), O_BINARY);
+#endif 
+
        if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
            SvREADONLY_off(GvSV(tmpgv));
            sv_setiv(GvSV(tmpgv), PerlProc_getpid());
        if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
            SvREADONLY_off(GvSV(tmpgv));
            sv_setiv(GvSV(tmpgv), PerlProc_getpid());
@@ -2374,9 +2782,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;
@@ -2415,8 +2821,9 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 #if defined(atarist) || defined(EPOC)
 FILE *popen();
 PerlIO *
 #if defined(atarist) || defined(EPOC)
 FILE *popen();
 PerlIO *
-Perl_my_popen(pTHX_ char *cmd, char *mode)
+Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 {
 {
+    PERL_ARGS_ASSERT_MY_POPEN;
     PERL_FLUSHALL_FOR_CHILD;
     /* Call system's popen() to get a FILE *, then import it.
        used 0 for 2nd parameter to PerlIO_importFILE;
     PERL_FLUSHALL_FOR_CHILD;
     /* Call system's popen() to get a FILE *, then import it.
        used 0 for 2nd parameter to PerlIO_importFILE;
@@ -2428,7 +2835,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
 #if defined(DJGPP)
 FILE *djgpp_popen();
 PerlIO *
 #if defined(DJGPP)
 FILE *djgpp_popen();
 PerlIO *
-Perl_my_popen(pTHX_ char *cmd, char *mode)
+Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 {
     PERL_FLUSHALL_FOR_CHILD;
     /* Call system's popen() to get a FILE *, then import it.
 {
     PERL_FLUSHALL_FOR_CHILD;
     /* Call system's popen() to get a FILE *, then import it.
@@ -2437,6 +2844,14 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
     */
     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
 }
     */
     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
 }
+#else
+#if defined(__LIBCATAMOUNT__)
+PerlIO *
+Perl_my_popen(pTHX_ const char *cmd, const char *mode)
+{
+    return NULL;
+}
+#endif
 #endif
 #endif
 
 #endif
 #endif
 
@@ -2494,11 +2909,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)
@@ -2546,11 +2963,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)
 {
@@ -2598,6 +3010,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)
@@ -2699,7 +3113,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)
 {
@@ -2708,16 +3122,20 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
     int status;
     SV **svp;
     Pid_t pid;
     int status;
     SV **svp;
     Pid_t pid;
-    Pid_t pid2;
+    Pid_t pid2 = 0;
     bool close_failed;
     bool close_failed;
-    int saved_errno = 0;
-#ifdef WIN32
-    int saved_win32_errno;
+    dSAVEDERRNO;
+    const int fd = PerlIO_fileno(ptr);
+
+#ifdef USE_PERLIO
+    /* Find out whether the refcount is low enough for us to wait for the
+       child proc without blocking. */
+    const bool should_wait = PerlIOUnix_refcnt(fd) == 1;
+#else
+    const bool should_wait = 1;
 #endif
 
 #endif
 
-    LOCK_FDPID_MUTEX;
-    svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
-    UNLOCK_FDPID_MUTEX;
+    svp = av_fetch(PL_fdpid,fd,TRUE);
     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;
@@ -2726,12 +3144,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
@@ -2740,7 +3154,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
     rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &istat);
     rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
 #endif
     rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &istat);
     rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
 #endif
-    do {
+    if (should_wait) do {
        pid2 = wait4pid(pid, &status, 0);
     } while (pid2 == -1 && errno == EINTR);
 #ifndef PERL_MICRO
        pid2 = wait4pid(pid, &status, 0);
     } while (pid2 == -1 && errno == EINTR);
 #ifndef PERL_MICRO
@@ -2749,19 +3163,32 @@ 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 -1;
     }
-    return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
+    return(
+      should_wait
+       ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
+       : 0
+    );
+}
+#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
@@ -2834,6 +3261,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;
 }
@@ -2841,7 +3269,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;
 
@@ -2885,24 +3313,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);
     }
 }
 
     }
 }
 
@@ -2916,6 +3356,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
@@ -2927,13 +3369,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)
@@ -2954,6 +3396,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
@@ -2977,6 +3420,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.
@@ -3065,26 +3510,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
@@ -3097,21 +3532,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
@@ -3119,7 +3549,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 */
 
@@ -3144,7 +3573,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
                )
@@ -3205,6 +3634,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);
@@ -3269,6 +3699,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;
@@ -3430,113 +3861,76 @@ Perl_my_fflush_all(pTHX)
 }
 
 void
 }
 
 void
-Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
-{
-    const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
-
-    if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
-       if (ckWARN(WARN_IO)) {
-           const char * const direction =
-               (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
-           if (name && *name)
-               Perl_warner(aTHX_ packWARN(WARN_IO),
-                           "Filehandle %s opened only for %sput",
-                           name, direction);
-           else
-               Perl_warner(aTHX_ packWARN(WARN_IO),
-                           "Filehandle opened only for %sput", direction);
-       }
-    }
-    else {
-        const char *vile;
-       I32   warn_type;
-
-       if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
-           vile = "closed";
-           warn_type = WARN_CLOSED;
-       }
-       else {
-           vile = "unopened";
-           warn_type = WARN_UNOPENED;
-       }
+Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
+{
+    if (ckWARN(WARN_IO)) {
+       const char * const name
+           = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
+       const char * const direction = have == '>' ? "out" : "in";
 
 
-       if (ckWARN(warn_type)) {
-           const char * const pars =
-               (const char *)(OP_IS_FILETEST(op) ? "" : "()");
-           const char * const func =
-               (const char *)
-               (op == OP_READLINE   ? "readline"  :    /* "<HANDLE>" not nice */
-                op == OP_LEAVEWRITE ? "write" :                /* "write exit" not nice */
-                op < 0              ? "" :              /* handle phoney cases */
-                PL_op_desc[op]);
-           const char * const type =
-               (const char *)
-               (OP_IS_SOCKET(op) ||
-                (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
-                "socket" : "filehandle");
-           if (name && *name) {
-               Perl_warner(aTHX_ packWARN(warn_type),
-                           "%s%s on %s %s %s", func, pars, vile, type, name);
-               if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
-                   Perl_warner(
-                       aTHX_ packWARN(warn_type),
-                       "\t(Are you trying to call %s%s on dirhandle %s?)\n",
-                       func, pars, name
-                   );
-           }
-           else {
-               Perl_warner(aTHX_ packWARN(warn_type),
-                           "%s%s on %s %s", func, pars, vile, type);
-               if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
-                   Perl_warner(
-                       aTHX_ packWARN(warn_type),
-                       "\t(Are you trying to call %s%s on dirhandle?)\n",
-                       func, pars
-                   );
-           }
-       }
+       if (name && *name)
+           Perl_warner(aTHX_ packWARN(WARN_IO),
+                       "Filehandle %s opened only for %sput",
+                       name, direction);
+       else
+           Perl_warner(aTHX_ packWARN(WARN_IO),
+                       "Filehandle opened only for %sput", direction);
     }
 }
 
     }
 }
 
-#ifdef EBCDIC
-/* in ASCII order, not that it matters */
-static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
-
-int
-Perl_ebcdic_control(pTHX_ int ch)
+void
+Perl_report_evil_fh(pTHX_ const GV *gv)
 {
 {
-    if (ch > 'a') {
-       const char *ctlp;
-
-       if (islower(ch))
-           ch = toupper(ch);
+    const IO *io = gv ? GvIO(gv) : NULL;
+    const PERL_BITFIELD16 op = PL_op->op_type;
+    const char *vile;
+    I32 warn_type;
 
 
-       if ((ctlp = strchr(controllablechars, ch)) == 0) {
-           Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
+    if (io && IoTYPE(io) == IoTYPE_CLOSED) {
+       vile = "closed";
+       warn_type = WARN_CLOSED;
+    }
+    else {
+       vile = "unopened";
+       warn_type = WARN_UNOPENED;
+    }
+
+    if (ckWARN(warn_type)) {
+       const char * const name
+           = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
+       const char * const pars =
+           (const char *)(OP_IS_FILETEST(op) ? "" : "()");
+       const char * const func =
+           (const char *)
+           (op == OP_READLINE   ? "readline"  :        /* "<HANDLE>" not nice */
+            op == OP_LEAVEWRITE ? "write" :            /* "write exit" not nice */
+            PL_op_desc[op]);
+       const char * const type =
+           (const char *)
+           (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
+            ? "socket" : "filehandle");
+       if (name && *name) {
+           Perl_warner(aTHX_ packWARN(warn_type),
+                       "%s%s on %s %s %s", func, pars, vile, type, name);
+           if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+               Perl_warner(
+                           aTHX_ packWARN(warn_type),
+                           "\t(Are you trying to call %s%s on dirhandle %s?)\n",
+                           func, pars, name
+                           );
+       }
+       else {
+           Perl_warner(aTHX_ packWARN(warn_type),
+                       "%s%s on %s %s", func, pars, vile, type);
+           if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+               Perl_warner(
+                           aTHX_ packWARN(warn_type),
+                           "\t(Are you trying to call %s%s on dirhandle?)\n",
+                           func, pars
+                           );
        }
        }
-
-       if (ctlp == controllablechars)
-           return('\177'); /* DEL */
-       else
-           return((unsigned char)(ctlp - controllablechars - 1));
-    } else { /* Want uncontrol */
-       if (ch == '\177' || ch == -1)
-           return('?');
-       else if (ch == '\157')
-           return('\177');
-       else if (ch == '\174')
-           return('\000');
-       else if (ch == '^')    /* '\137' in 1047, '\260' in 819 */
-           return('\036');
-       else if (ch == '\155')
-           return('\037');
-       else if (0 < ch && ch < (sizeof(controllablechars) - 1))
-           return(controllablechars[ch+1]);
-       else
-           Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
     }
 }
     }
 }
-#endif
 
 /* To workaround core dumps from the uninitialised tm_zone we get the
  * system to give us a reasonable struct to copy.  This fix means that
 
 /* To workaround core dumps from the uninitialised tm_zone we get the
  * system to give us a reasonable struct to copy.  This fix means that
@@ -3566,11 +3960,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
 }
@@ -3588,6 +3984,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)
@@ -3654,7 +4052,7 @@ Perl_mini_mktime(pTHX_ struct tm *ptm)
  * outside the scope for this routine.  Since we convert back based on the
  * same rules we used to build the yearday, you'll only get strange results
  * for input which needed normalising, or for the 'odd' century years which
  * outside the scope for this routine.  Since we convert back based on the
  * same rules we used to build the yearday, you'll only get strange results
  * for input which needed normalising, or for the 'odd' century years which
- * were leap years in the Julian calander but not in the Gregorian one.
+ * were leap years in the Julian calendar but not in the Gregorian one.
  * I can live with that.
  *
  * This algorithm also fails to handle years before A.D. 1 gracefully, but
  * I can live with that.
  *
  * This algorithm also fails to handle years before A.D. 1 gracefully, but
@@ -3782,6 +4180,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;
@@ -3829,9 +4229,9 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in
   else {
     /* Possibly buf overflowed - try again with a bigger buf */
     const int fmtlen = strlen(fmt);
   else {
     /* Possibly buf overflowed - try again with a bigger buf */
     const int fmtlen = strlen(fmt);
-    const int bufsize = fmtlen + buflen;
+    int bufsize = fmtlen + buflen;
 
 
-    Newx(buf, bufsize, char);
+    Renew(buf, bufsize, char);
     while (buf) {
       buflen = strftime(buf, bufsize, fmt, &mytm);
       if (buflen > 0 && buflen < bufsize)
     while (buf) {
       buflen = strftime(buf, bufsize, fmt, &mytm);
       if (buflen > 0 && buflen < bufsize)
@@ -3842,7 +4242,8 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in
        buf = NULL;
        break;
       }
        buf = NULL;
        break;
       }
-      Renew(buf, bufsize*2, char);
+      bufsize *= 2;
+      Renew(buf, bufsize, char);
     }
     return buf;
   }
     }
     return buf;
   }
@@ -3888,6 +4289,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];
@@ -3925,6 +4328,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 
     for (;;) {
        DIR *dir;
 
     for (;;) {
        DIR *dir;
+       int namelen;
        odev = cdev;
        oino = cino;
 
        odev = cdev;
        oino = cino;
 
@@ -3947,9 +4351,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)) {
@@ -4025,89 +4429,282 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 #endif
 }
 
 #endif
 }
 
-/*
-=for apidoc scan_version
-
-Returns a pointer to the next character after the parsed
-version string, as well as upgrading the passed in SV to
-an RV.
-
-Function must be called with an already existing SV like
+#define VERSION_MAX 0x7FFFFFFF
 
 
-    sv = newSV(0);
-    s = scan_version(s,SV *sv, bool qv);
+/*
+=for apidoc prescan_version
 
 
-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
-should be interpreted as if it had multiple decimals, even if
-it doesn't.
+Validate that a given string can be parsed as a version object, but doesn't
+actually perform the parsing.  Can use either strict or lax validation rules.
+Can optionally set a number of hint variables to save the parsing code
+some time when tokenizing.
 
 =cut
 */
 
 =cut
 */
-
 const char *
 const char *
-Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
-{
-    const char *start;
-    const char *pos;
-    const char *last;
-    int saw_period = 0;
-    int alpha = 0;
+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 width = 3;
-    AV * const av = newAV();
-    SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
-    (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
+    int saw_decimal = 0;
+    bool alpha = FALSE;
+    const char *d = s;
 
 
-#ifndef NODEFAULT_SHAREKEYS
-    HvSHAREKEYS_on(hv);         /* key-sharing on by default */
-#endif
+    PERL_ARGS_ASSERT_PRESCAN_VERSION;
 
 
-    while (isSPACE(*s)) /* leading whitespace is OK */
-       s++;
+    if (qv && isDIGIT(*d))
+       goto dotted_decimal_version;
 
 
-    if (*s == 'v') {
-       s++;  /* get past 'v' */
-       qv = 1; /* force quoted version processing */
-    }
+    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)");
+       }
 
 
-    start = last = pos = s;
+dotted_decimal_version:
+       if (strict && d[0] == '0' && isDIGIT(d[1])) {
+           /* no leading zeros allowed */
+           BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
+       }
 
 
-    /* pre-scan the input string to check for decimals/underbars */
-    while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
-    {
-       if ( *pos == '.' )
+       while (isDIGIT(*d))     /* integer part */
+           d++;
+
+       if (*d == '.')
        {
        {
-           if ( alpha )
-               Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
-           saw_period++ ;
-           last = pos;
+           saw_decimal++;
+           d++;                /* decimal point */
        }
        }
-       else if ( *pos == '_' )
+       else
        {
        {
-           if ( alpha )
-               Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
-           alpha = 1;
-           width = pos - last - 1; /* natural width of sub-version */
+           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;
+           }
        }
        }
-       pos++;
-    }
-
-    if ( alpha && !saw_period )
-       Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
 
 
-    if ( saw_period > 1 )
-       qv = 1; /* force quoted version processing */
+       {
+           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 == '{' || *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 == '{' || *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 == '{' || *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
+
+Returns a pointer to the next character after the parsed
+version string, as well as upgrading the passed in SV to
+an RV.
+
+Function must be called with an already existing SV like
+
+    sv = newSV(0);
+    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
+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.
+
+=cut
+*/
+
+const char *
+Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
+{
+    const char *start;
+    const char *pos;
+    const char *last;
+    const char *errstr = NULL;
+    int saw_decimal = 0;
+    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 */
+
+    PERL_ARGS_ASSERT_SCAN_VERSION;
+
+    (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
+
+#ifndef NODEFAULT_SHAREKEYS
+    HvSHAREKEYS_on(hv);         /* key-sharing on by default */
+#endif
+
+    while (isSPACE(*s)) /* leading whitespace is OK */
+       s++;
 
 
+    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);
+       }
+    }
+
+    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++;
@@ -4120,20 +4717,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++;
@@ -4141,21 +4744,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 {
@@ -4183,23 +4798,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;
 }
 
@@ -4221,6 +4853,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;
@@ -4237,19 +4870,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((HV*)ver, "width", FALSE));
-           hv_store((HV *)hv, "width", 5, newSViv(width), 0);
+           const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
+           (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
        }
 
        }
 
-       sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE));
+       if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
+       {
+           SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
+           (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
+       }
+
+       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++ )
        {
@@ -4257,7 +4896,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
@@ -4267,6 +4906,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 {
@@ -4276,7 +4918,7 @@ Perl_new_version(pTHX_ SV *ver)
        }
     }
 #endif
        }
     }
 #endif
-    return upg_version(rv);
+    return upg_version(rv, FALSE);
 }
 
 /*
 }
 
 /*
@@ -4284,24 +4926,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");
@@ -4311,25 +4956,62 @@ 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,"_")) {
+           /* may be a v-string */
+           char *testv = (char *)version;
+           STRLEN tlen = len;
+           for (tlen=0; tlen < len; tlen++, testv++) {
+               /* if one of the characters is non-text assume v-string */
+               if (testv[0] < ' ') {
+                   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;
+                   }
+                   break;
+               }
+           }
+       }
+#  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;
 }
@@ -4337,41 +5019,47 @@ Perl_upg_version(pTHX_ SV *ver)
 /*
 =for apidoc vverify
 
 /*
 =for apidoc vverify
 
-Validates that the SV contains a valid version object.
+Validates that the SV contains valid internal structure for a version object.
+It may be passed either the version object (RV) or the hash itself (HV).  If
+the structure is valid, it returns the HV.  If the structure is invalid,
+it returns NULL.
 
 
-    bool vverify(SV *vobj);
+    SV *hv = vverify(sv);
 
 Note that it only confirms the bare minimum structure (so as not to get
 confused by derived classes which may contain additional hash entries):
 
 =over 4
 
 
 Note that it only confirms the bare minimum structure (so as not to get
 confused by derived classes which may contain additional hash entries):
 
 =over 4
 
-=item * The SV contains a [reference to a] hash
+=item * The SV is an HV or a reference to an HV
 
 =item * The hash contains a "version" key
 
 
 =item * The hash contains a "version" key
 
-=item * The "version" key has [a reference to] an AV as its value
+=item * The "version" key has a reference to an AV as its value
 
 =back
 
 =cut
 */
 
 
 =back
 
 =cut
 */
 
-bool
+SV *
 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 )
         && SvTYPE(sv) == SVt_PVAV )
-       return TRUE;
+       return vs;
     else
     else
-       return FALSE;
+       return NULL;
 }
 
 /*
 }
 
 /*
@@ -4385,6 +5073,8 @@ point representation.  Call like:
 NOTE: you can pass either the object directly or the SV
 contained within the RV.
 
 NOTE: you can pass either the object directly or the SV
 contained within the RV.
 
+The SV returned has a refcount of 1.
+
 =cut
 */
 
 =cut
 */
 
@@ -4394,38 +5084,38 @@ 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;
-    if ( SvROK(vs) )
-       vs = SvRV(vs);
 
 
-    if ( !vverify(vs) )
+    PERL_ARGS_ASSERT_VNUMIFY;
+
+    /* extract the HV from the object */
+    vs = vverify(vs);
+    if ( ! 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));
@@ -4464,6 +5154,8 @@ representation.  Call like:
 NOTE: you can pass either the object directly or the SV
 contained within the RV.
 
 NOTE: you can pass either the object directly or the SV
 contained within the RV.
 
+The SV returned has a refcount of 1.
+
 =cut
 */
 
 =cut
 */
 
@@ -4472,26 +5164,27 @@ 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;
-    if ( SvROK(vs) )
-       vs = SvRV(vs);
 
 
-    if ( !vverify(vs) )
+    PERL_ARGS_ASSERT_VNORMAL;
+
+    /* extract the HV from the object */
+    vs = vverify(vs);
+    if ( ! vs )
        Perl_croak(aTHX_ "Invalid version object");
 
        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);
@@ -4520,7 +5213,9 @@ Perl_vnormal(pTHX_ SV *vs)
 In order to maintain maximum compatibility with earlier versions
 of Perl, this function will return either the floating point
 notation or the multiple dotted notation, depending on whether
 In order to maintain maximum compatibility with earlier versions
 of Perl, this function will return either the floating point
 notation or the multiple dotted notation, depending on whether
-the original version contained 1 or more dots, respectively
+the original version contained 1 or more dots, respectively.
+
+The SV returned has a refcount of 1.
 
 =cut
 */
 
 =cut
 */
@@ -4528,16 +5223,27 @@ the original version contained 1 or more dots, respectively
 SV *
 Perl_vstringify(pTHX_ SV *vs)
 {
 SV *
 Perl_vstringify(pTHX_ SV *vs)
 {
-    if ( SvROK(vs) )
-       vs = SvRV(vs);
-    
-    if ( !vverify(vs) )
+    PERL_ARGS_ASSERT_VSTRINGIFY;
+
+    /* extract the HV from the object */
+    vs = vverify(vs);
+    if ( ! vs )
        Perl_croak(aTHX_ "Invalid version object");
 
        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);
+    }
 }
 
 /*
 }
 
 /*
@@ -4558,25 +5264,23 @@ 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;
-    if ( SvROK(lhv) )
-       lhv = SvRV(lhv);
-    if ( SvROK(rhv) )
-       rhv = SvRV(rhv);
 
 
-    if ( !vverify(lhv) )
-       Perl_croak(aTHX_ "Invalid version object");
+    PERL_ARGS_ASSERT_VCMP;
 
 
-    if ( !vverify(rhv) )
+    /* extract the HVs from the objects */
+    lhv = vverify(lhv);
+    rhv = vverify(rhv);
+    if ( ! ( lhv && 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);
@@ -4766,12 +5470,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;
     }
 }
@@ -4870,14 +5574,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;
     }
 }
@@ -4913,19 +5617,44 @@ 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);
            while (isDIGIT(*p))
                p++;
   if (*p) {
        if (isDIGIT(*p)) {
            opt = (U32) atoi(p);
            while (isDIGIT(*p))
                p++;
-           if (*p && *p != '\n' && *p != '\r')
+           if (*p && *p != '\n' && *p != '\r') {
+            if(isSPACE(*p)) goto the_end_of_the_opts_parser;
+            else
                 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
                 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
+           }
        }
        else {
            for (; *p; p++) {
        }
        else {
            for (; *p; p++) {
@@ -4951,9 +5680,12 @@ Perl_parse_unicode_opts(pTHX_ const char **popt)
                 case PERL_UNICODE_UTF8CACHEASSERT:
                      opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
                 default:
                 case PERL_UNICODE_UTF8CACHEASSERT:
                      opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
                 default:
-                     if (*p != '\n' && *p != '\r')
+                     if (*p != '\n' && *p != '\r') {
+                       if(isSPACE(*p)) goto the_end_of_the_opts_parser;
+                       else
                          Perl_croak(aTHX_
                                     "Unknown Unicode option letter '%c'", *p);
                          Perl_croak(aTHX_
                                     "Unknown Unicode option letter '%c'", *p);
+                     }
                 }
            }
        }
                 }
            }
        }
@@ -4961,6 +5693,8 @@ Perl_parse_unicode_opts(pTHX_ const char **popt)
   else
        opt = PERL_UNICODE_DEFAULT_FLAGS;
 
   else
        opt = PERL_UNICODE_DEFAULT_FLAGS;
 
+  the_end_of_the_opts_parser:
+
   if (opt & ~PERL_UNICODE_ALL_FLAGS)
        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
                  (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
   if (opt & ~PERL_UNICODE_ALL_FLAGS)
        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
                  (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
@@ -5078,7 +5812,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. */
@@ -5098,6 +5832,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;
@@ -5111,13 +5846,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
@@ -5145,10 +5881,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); 
@@ -5157,8 +5897,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;
 }
 
@@ -5169,188 +5909,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.
  *
  *
- * 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.)
+ * The default implementation reads a single env var, PERL_MEM_LOG,
+ * expecting one or more of the following:
+ *
+ *    \d+ - fd         fd to write to          : must be 1st (atoi)
+ *    'm' - memlog     was PERL_MEM_LOG=1
+ *    's' - svlog      was PERL_SV_LOG=1
+ *    't' - timestamp  was PERL_MEM_LOG_TIMESTAMP=1
+ *
+ * This makes the logger controllable enough that it can reasonably be
+ * added to the system perl.
  */
 
  */
 
-/*
- * 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 implementation, 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 */
 
 /*
@@ -5367,6 +6130,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);
@@ -5392,6 +6156,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);
@@ -5399,8 +6164,14 @@ Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
     retval = vsprintf(buffer, format, ap);
 #endif
     va_end(ap);
     retval = vsprintf(buffer, format, ap);
 #endif
     va_end(ap);
-    /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
-    if (retval < 0 || (len > 0 && (Size_t)retval >= len))
+    /* vsprintf() shows failure with < 0 */
+    if (retval < 0
+#ifdef HAS_VSNPRINTF
+    /* vsnprintf() shows failure with >= len */
+        ||
+        (len > 0 && (Size_t)retval >= len) 
+#endif
+    )
        Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
     return retval;
 }
        Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
     return retval;
 }
@@ -5423,6 +6194,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);
@@ -5436,8 +6210,14 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap
     retval = vsprintf(buffer, format, ap);
 # endif
 #endif /* #ifdef NEED_VA_COPY */
     retval = vsprintf(buffer, format, ap);
 # endif
 #endif /* #ifdef NEED_VA_COPY */
-    /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
-    if (retval < 0 || (len > 0 && (Size_t)retval >= len))
+    /* vsprintf() shows failure with < 0 */
+    if (retval < 0
+#ifdef HAS_VSNPRINTF
+    /* vsnprintf() shows failure with >= len */
+        ||
+        (len > 0 && (Size_t)retval >= len) 
+#endif
+    )
        Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
     return retval;
 }
        Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
     return retval;
 }
@@ -5475,13 +6255,14 @@ Perl_my_clearenv(pTHX)
     char *buf = (char*)safesysmalloc(bufsiz);
     while (*environ != NULL) {
       char *e = strchr(*environ, '=');
     char *buf = (char*)safesysmalloc(bufsiz);
     while (*environ != NULL) {
       char *e = strchr(*environ, '=');
-      int l = e ? e - *environ : strlen(*environ);
+      int l = e ? e - *environ : (int)strlen(*environ);
       if (bsiz < l + 1) {
         (void)safesysfree(buf);
         bsiz = l + 1; /* + 1 for the \0. */
         buf = (char*)safesysmalloc(bufsiz);
       } 
       if (bsiz < l + 1) {
         (void)safesysfree(buf);
         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);
@@ -5498,23 +6279,29 @@ Perl_my_clearenv(pTHX)
 
 #ifdef PERL_IMPLICIT_CONTEXT
 
 
 #ifdef PERL_IMPLICIT_CONTEXT
 
-/* implements the MY_CXT_INIT macro. The first time a module is loaded,
+/* Implements the MY_CXT_INIT macro. The first time a module is loaded,
 the global PL_my_cxt_index is incremented, and that value is assigned to
 that module's static my_cxt_index (who's address is passed as an arg).
 Then, for each interpreter this function is called for, it makes sure a
 void* slot is available to hang the static data off, by allocating or
 extending the interpreter's PL_my_cxt_list array */
 
 the global PL_my_cxt_index is incremented, and that value is assigned to
 that module's static my_cxt_index (who's address is passed as an arg).
 Then, for each interpreter this function is called for, it makes sure a
 void* slot is available to hang the static data off, by allocating or
 extending the interpreter's PL_my_cxt_list array */
 
+#ifndef PERL_GLOBAL_STRUCT_PRIVATE
 void *
 Perl_my_cxt_init(pTHX_ int *index, size_t size)
 {
     dVAR;
     void *p;
 void *
 Perl_my_cxt_init(pTHX_ int *index, size_t size)
 {
     dVAR;
     void *p;
+    PERL_ARGS_ASSERT_MY_CXT_INIT;
     if (*index == -1) {
        /* this module hasn't been allocated an index yet */
     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 */
@@ -5535,7 +6322,156 @@ Perl_my_cxt_init(pTHX_ int *index, size_t size)
     Zero(p, size, char);
     return p;
 }
     Zero(p, size, char);
     return p;
 }
+
+#else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
+
+int
+Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
+{
+    dVAR;
+    int index;
+
+    PERL_ARGS_ASSERT_MY_CXT_INDEX;
+
+    for (index = 0; index < PL_my_cxt_index; index++) {
+       const char *key = PL_my_cxt_keys[index];
+       /* try direct pointer compare first - there are chances to success,
+        * and it's much faster.
+        */
+       if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
+           return index;
+    }
+    return -1;
+}
+
+void *
+Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
+{
+    dVAR;
+    void *p;
+    int index;
+
+    PERL_ARGS_ASSERT_MY_CXT_INIT;
+
+    index = Perl_my_cxt_index(aTHX_ my_cxt_key);
+    if (index == -1) {
+       /* this module hasn't been allocated an index yet */
+#if defined(USE_ITHREADS)
+       MUTEX_LOCK(&PL_my_ctx_mutex);
 #endif
 #endif
+       index = PL_my_cxt_index++;
+#if defined(USE_ITHREADS)
+       MUTEX_UNLOCK(&PL_my_ctx_mutex);
+#endif
+    }
+
+    /* make sure the array is big enough */
+    if (PL_my_cxt_size <= index) {
+       int old_size = PL_my_cxt_size;
+       int i;
+       if (PL_my_cxt_size) {
+           while (PL_my_cxt_size <= index)
+               PL_my_cxt_size *= 2;
+           Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
+           Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
+       }
+       else {
+           PL_my_cxt_size = 16;
+           Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
+           Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
+       }
+       for (i = old_size; i < PL_my_cxt_size; i++) {
+           PL_my_cxt_keys[i] = 0;
+           PL_my_cxt_list[i] = 0;
+       }
+    }
+    PL_my_cxt_keys[index] = my_cxt_key;
+    /* newSV() allocates one more than needed */
+    p = (void*)SvPVX(newSV(size-1));
+    PL_my_cxt_list[index] = p;
+    Zero(p, size, char);
+    return p;
+}
+#endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
+#endif /* PERL_IMPLICIT_CONTEXT */
+
+void
+Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
+                         STRLEN xs_len)
+{
+    SV *sv;
+    const char *vn = NULL;
+    SV *const module = PL_stack_base[ax];
+
+    PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
+
+    if (items >= 2)     /* version supplied as bootstrap arg */
+       sv = PL_stack_base[ax + 1];
+    else {
+       /* XXX GV_ADDWARN */
+       vn = "XS_VERSION";
+       sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
+       if (!sv || !SvOK(sv)) {
+           vn = "VERSION";
+           sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
+       }
+    }
+    if (sv) {
+       SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
+       SV *pmsv = sv_derived_from(sv, "version")
+           ? sv : sv_2mortal(new_version(sv));
+       xssv = upg_version(xssv, 0);
+       if ( vcmp(pmsv,xssv) ) {
+           SV *string = vstringify(xssv);
+           SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
+                                   " does not match ", module, string);
+
+           SvREFCNT_dec(string);
+           string = vstringify(pmsv);
+
+           if (vn) {
+               Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn,
+                              string);
+           } else {
+               Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string);
+           }
+           SvREFCNT_dec(string);
+
+           Perl_sv_2mortal(aTHX_ xpt);
+           Perl_croak_sv(aTHX_ xpt);
+       }
+    }
+}
+
+void
+Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
+                            STRLEN api_len)
+{
+    SV *xpt = NULL;
+    SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
+    SV *runver;
+
+    PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
+
+    /* This might croak  */
+    compver = upg_version(compver, 0);
+    /* This should never croak */
+    runver = new_version(PL_apiversion);
+    if (vcmp(compver, runver)) {
+       SV *compver_string = vstringify(compver);
+       SV *runver_string = vstringify(runver);
+       xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
+                           " of %"SVf" does not match %"SVf,
+                           compver_string, module, runver_string);
+       Perl_sv_2mortal(aTHX_ xpt);
+
+       SvREFCNT_dec(compver_string);
+       SvREFCNT_dec(runver_string);
+    }
+    SvREFCNT_dec(runver);
+    if (xpt)
+       Perl_croak_sv(aTHX_ xpt);
+}
 
 #ifndef HAS_STRLCAT
 Size_t
 
 #ifndef HAS_STRLCAT
 Size_t
@@ -5570,6 +6506,91 @@ Perl_my_strlcpy(char *dst, const char *src, Size_t size)
 }
 #endif
 
 }
 #endif
 
+#if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
+/* VC7 or 7.1, building with pre-VC7 runtime libraries. */
+long _ftol( double ); /* Defined by VC6 C libs. */
+long _ftol2( double dblSource ) { return _ftol( dblSource ); }
+#endif
+
+void
+Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
+{
+    dVAR;
+    SV * const dbsv = GvSVn(PL_DBsub);
+    const bool save_taint = PL_tainted;
+
+    /* We do not care about using sv to call CV;
+     * it's for informational purposes only.
+     */
+
+    PERL_ARGS_ASSERT_GET_DB_SUB;
+
+    PL_tainted = FALSE;
+    save_item(dbsv);
+    if (!PERLDB_SUB_NN) {
+       GV *gv = CvGV(cv);
+
+       if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
+            || strEQ(GvNAME(gv), "END")
+            || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
+                !( (SvTYPE(*svp) == SVt_PVGV)
+                   && (GvCV((const GV *)*svp) == cv)
+                   && (gv = (GV *)*svp) 
+                 )
+               )
+       )) {
+           /* Use GV from the stack as a fallback. */
+           /* GV is potentially non-unique, or contain different CV. */
+           SV * const tmp = newRV(MUTABLE_SV(cv));
+           sv_setsv(dbsv, tmp);
+           SvREFCNT_dec(tmp);
+       }
+       else {
+           gv_efullname3(dbsv, gv, NULL);
+       }
+    }
+    else {
+       const int type = SvTYPE(dbsv);
+       if (type < SVt_PVIV && type != SVt_IV)
+           sv_upgrade(dbsv, SVt_PVIV);
+       (void)SvIOK_on(dbsv);
+       SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
+    }
+    TAINT_IF(save_taint);
+}
+
+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