This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Add some PERL_MEM* defines to the -V output that were missing.
[perl5.git] / util.c
diff --git a/util.c b/util.c
index 881287b..edd51b5 100644 (file)
--- a/util.c
+++ b/util.c
@@ -1,7 +1,7 @@
 /*    util.c
  *
  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
 /*    util.c
  *
  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- *    2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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.
@@ -92,19 +92,32 @@ Perl_safesysmalloc(MEM_SIZE size)
     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));
     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 != Nullch) {
+    if (ptr != NULL) {
 #ifdef PERL_TRACK_MEMPOOL
 #ifdef PERL_TRACK_MEMPOOL
-        ((struct perl_memory_debug_header *)ptr)->interpreter = aTHX;
+       struct perl_memory_debug_header *const header
+           = (struct perl_memory_debug_header *)ptr;
+#endif
+
+#ifdef PERL_POISON
+       PoisonNew(((char *)ptr), size, char);
+#endif
+
+#ifdef PERL_TRACK_MEMPOOL
+       header->interpreter = aTHX;
+       /* Link us into the list.  */
+       header->prev = &PL_memory_debug_header;
+       header->next = PL_memory_debug_header.next;
+       PL_memory_debug_header.next = header;
+       header->next->prev = header;
 #  ifdef PERL_POISON
 #  ifdef PERL_POISON
-        ((struct perl_memory_debug_header *)ptr)->size = size;
-        ((struct perl_memory_debug_header *)ptr)->in_use = PERL_POISON_INUSE;
+       header->size = size;
 #  endif
         ptr = (Malloc_t)((char*)ptr+sTHX);
 #endif
        return ptr;
 }
     else if (PL_nomemok)
 #  endif
         ptr = (Malloc_t)((char*)ptr+sTHX);
 #endif
        return ptr;
 }
     else if (PL_nomemok)
-       return Nullch;
+       return NULL;
     else {
        return write_no_mem();
     }
     else {
        return write_no_mem();
     }
@@ -139,18 +152,24 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 #ifdef PERL_TRACK_MEMPOOL
     where = (Malloc_t)((char*)where-sTHX);
     size += sTHX;
 #ifdef PERL_TRACK_MEMPOOL
     where = (Malloc_t)((char*)where-sTHX);
     size += sTHX;
-    if (((struct perl_memory_debug_header *)where)->interpreter != aTHX) {
-        Perl_croak_nocontext("panic: realloc from wrong pool");
-    }
+    {
+       struct perl_memory_debug_header *const header
+           = (struct perl_memory_debug_header *)where;
+
+       if (header->interpreter != aTHX) {
+           Perl_croak_nocontext("panic: realloc from wrong pool");
+       }
+       assert(header->next->prev == header);
+       assert(header->prev->next == header);
 #  ifdef PERL_POISON
 #  ifdef PERL_POISON
-    if (((struct perl_memory_debug_header *)where)->size > size) {
-       const MEM_SIZE freed_up =
-           ((struct perl_memory_debug_header *)where)->size - size;
-       char *start_of_freed = ((char *)where) + size;
-       Poison(start_of_freed, freed_up, char);
-    }
-    ((struct perl_memory_debug_header *)where)->size = size;
+       if (header->size > size) {
+           const MEM_SIZE freed_up = header->size - size;
+           char *start_of_freed = ((char *)where) + size;
+           PoisonFree(start_of_freed, freed_up, char);
+       }
+       header->size = size;
 #  endif
 #  endif
+    }
 #endif
 #ifdef DEBUGGING
     if ((long)size < 0)
 #endif
 #ifdef DEBUGGING
     if ((long)size < 0)
@@ -162,14 +181,28 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
 
     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 != Nullch) {
+    if (ptr != NULL) {
 #ifdef PERL_TRACK_MEMPOOL
 #ifdef PERL_TRACK_MEMPOOL
+       struct perl_memory_debug_header *const header
+           = (struct perl_memory_debug_header *)ptr;
+
+#  ifdef PERL_POISON
+       if (header->size < size) {
+           const MEM_SIZE fresh = size - header->size;
+           char *start_of_fresh = ((char *)ptr) + size;
+           PoisonNew(start_of_fresh, fresh, char);
+       }
+#  endif
+
+       header->next->prev = header;
+       header->prev->next = header;
+
         ptr = (Malloc_t)((char*)ptr+sTHX);
 #endif
        return ptr;
     }
     else if (PL_nomemok)
         ptr = (Malloc_t)((char*)ptr+sTHX);
 #endif
        return ptr;
     }
     else if (PL_nomemok)
-       return Nullch;
+       return NULL;
     else {
        return write_no_mem();
     }
     else {
        return write_no_mem();
     }
@@ -190,24 +223,29 @@ Perl_safesysfree(Malloc_t where)
     if (where) {
 #ifdef PERL_TRACK_MEMPOOL
         where = (Malloc_t)((char*)where-sTHX);
     if (where) {
 #ifdef PERL_TRACK_MEMPOOL
         where = (Malloc_t)((char*)where-sTHX);
-        if (((struct perl_memory_debug_header *)where)->interpreter != aTHX) {
-            Perl_croak_nocontext("panic: free from wrong pool");
-       }
-#  ifdef PERL_POISON
        {
        {
-           if (((struct perl_memory_debug_header *)where)->in_use
-               == PERL_POISON_FREE) {
+           struct perl_memory_debug_header *const header
+               = (struct perl_memory_debug_header *)where;
+
+           if (header->interpreter != aTHX) {
+               Perl_croak_nocontext("panic: free from wrong pool");
+           }
+           if (!header->prev) {
                Perl_croak_nocontext("panic: duplicate free");
            }
                Perl_croak_nocontext("panic: duplicate free");
            }
-           if (((struct perl_memory_debug_header *)where)->in_use
-               != PERL_POISON_INUSE) {
-               Perl_croak_nocontext("panic: bad free ");
+           if (!(header->next) || header->next->prev != header
+               || header->prev->next != header) {
+               Perl_croak_nocontext("panic: bad free");
            }
            }
-           ((struct perl_memory_debug_header *)where)->in_use
-               = PERL_POISON_FREE;
-       }
-       Poison(where, ((struct perl_memory_debug_header *)where)->size, char);
+           /* Unlink us from the chain.  */
+           header->next->prev = header->prev;
+           header->prev->next = header->next;
+#  ifdef PERL_POISON
+           PoisonNew(where, header->size, char);
 #  endif
 #  endif
+           /* Trigger the duplicate free warning.  */
+           header->next = NULL;
+       }
 #endif
        PerlMem_free(where);
     }
 #endif
        PerlMem_free(where);
     }
@@ -220,11 +258,18 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 {
     dTHX;
     Malloc_t ptr;
 {
     dTHX;
     Malloc_t ptr;
+#ifdef DEBUGGING
+    const MEM_SIZE total_size = size * count
+#ifdef   PERL_TRACK_MEMPOOL
+       + sTHX
+#endif
+       ;
+#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 */
@@ -232,27 +277,40 @@ 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.  */
+    ptr = (Malloc_t)PerlMem_malloc(total_size);
+#else
+    /* Use calloc() because it might save a memset() if the memory is fresh
+       and clean from the OS.  */
+    ptr = (Malloc_t)PerlMem_calloc(count, size);
 #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));
-    if (ptr != Nullch) {
-       memset((void*)ptr, 0, size);
+    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size));
+    if (ptr != NULL) {
 #ifdef PERL_TRACK_MEMPOOL
 #ifdef PERL_TRACK_MEMPOOL
-        ((struct perl_memory_debug_header *)ptr)->interpreter = aTHX;
+       {
+           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->next = PL_memory_debug_header.next;
+           PL_memory_debug_header.next = header;
+           header->next->prev = header;
 #  ifdef PERL_POISON
 #  ifdef PERL_POISON
-        ((struct perl_memory_debug_header *)ptr)->size = size;
-        ((struct perl_memory_debug_header *)ptr)->in_use = PERL_POISON_INUSE;
+           header->size = total_size;
 #  endif
 #  endif
-        ptr = (Malloc_t)((char*)ptr+sTHX);
+           ptr = (Malloc_t)((char*)ptr+sTHX);
+       }
 #endif
        return ptr;
     }
     else if (PL_nomemok)
 #endif
        return ptr;
     }
     else if (PL_nomemok)
-       return Nullch;
+       return NULL;
     return write_no_mem();
 }
 
     return write_no_mem();
 }
 
@@ -293,16 +351,16 @@ char *
 Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
 {
     register I32 tolen;
 Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
 {
     register I32 tolen;
+    PERL_UNUSED_CONTEXT;
+
     for (tolen = 0; from < fromend; from++, tolen++) {
        if (*from == '\\') {
     for (tolen = 0; from < fromend; from++, tolen++) {
        if (*from == '\\') {
-           if (from[1] == delim)
-               from++;
-           else {
+           if (from[1] != delim) {
                if (to < toend)
                    *to++ = *from;
                tolen++;
                if (to < toend)
                    *to++ = *from;
                tolen++;
-               from++;
            }
            }
+           from++;
        }
        else if (*from == delim)
            break;
        }
        else if (*from == delim)
            break;
@@ -322,6 +380,7 @@ char *
 Perl_instr(pTHX_ register const char *big, register const char *little)
 {
     register I32 first;
 Perl_instr(pTHX_ register const char *big, register const char *little)
 {
     register I32 first;
+    PERL_UNUSED_CONTEXT;
 
     if (!little)
        return (char*)big;
 
     if (!little)
        return (char*)big;
@@ -334,7 +393,7 @@ Perl_instr(pTHX_ register const char *big, register const char *little)
            continue;
        for (x=big,s=little; *s; /**/ ) {
            if (!*x)
            continue;
        for (x=big,s=little; *s; /**/ ) {
            if (!*x)
-               return Nullch;
+               return NULL;
            if (*s != *x)
                break;
            else {
            if (*s != *x)
                break;
            else {
@@ -345,7 +404,7 @@ Perl_instr(pTHX_ register const char *big, register const char *little)
        if (!*s)
            return (char*)(big-1);
     }
        if (!*s)
            return (char*)(big-1);
     }
-    return Nullch;
+    return NULL;
 }
 
 /* same as instr but allow embedded nulls */
 }
 
 /* same as instr but allow embedded nulls */
@@ -353,6 +412,7 @@ Perl_instr(pTHX_ register const char *big, register const char *little)
 char *
 Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend)
 {
 char *
 Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend)
 {
+    PERL_UNUSED_CONTEXT;
     if (little >= lend)
         return (char*)big;
     {
     if (little >= lend)
         return (char*)big;
     {
@@ -370,7 +430,7 @@ Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const
             return (char*)(big-1);
         }
     }
             return (char*)(big-1);
         }
     }
-    return Nullch;
+    return NULL;
 }
 
 /* reverse of the above--find last substring */
 }
 
 /* reverse of the above--find last substring */
@@ -381,6 +441,7 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit
     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;
 
     if (little >= littleend)
        return (char*)bigend;
 
     if (little >= littleend)
        return (char*)bigend;
@@ -401,11 +462,9 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit
        if (s >= littleend)
            return (char*)(big+1);
     }
        if (s >= littleend)
            return (char*)(big+1);
     }
-    return Nullch;
+    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().
@@ -430,7 +489,7 @@ 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;
 
     if (flags & FBMcf_TAIL) {
     U32 frequency = 256;
 
     if (flags & FBMcf_TAIL) {
@@ -440,19 +499,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) {
@@ -460,9 +522,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, Nullsv, PERL_MAGIC_bm, Nullch, 0);    /* deep magic */
-    SvVALID_on(sv);
+    sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0);        /* deep magic */
 
     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++) {
@@ -471,13 +534,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. */
@@ -488,7 +552,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
 =for apidoc fbm_instr
 
 Returns the location of the SV in the string delimited by C<str> and
 =for apidoc fbm_instr
 
 Returns the location of the SV in the string delimited by C<str> and
-C<strend>.  It returns C<Nullch> if the string can't be found.  The C<sv>
+C<strend>.  It returns C<NULL> if the string can't be found.  The C<sv>
 does not have to be fbm_compiled, but the search will not be as fast
 then.
 
 does not have to be fbm_compiled, but the search will not be as fast
 then.
 
@@ -512,7 +576,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
                 || (*big == *little &&
                     memEQ((char *)big, (char *)little, littlelen - 1))))
            return (char*)big;
                 || (*big == *little &&
                     memEQ((char *)big, (char *)little, littlelen - 1))))
            return (char*)big;
-       return Nullch;
+       return NULL;
     }
 
     if (littlelen <= 2) {              /* Special-cased */
     }
 
     if (littlelen <= 2) {              /* Special-cased */
@@ -532,7 +596,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
            }
            if (SvTAIL(littlestr))
                return (char *) bigend;
            }
            if (SvTAIL(littlestr))
                return (char *) bigend;
-           return Nullch;
+           return NULL;
        }
        if (!littlelen)
            return (char*)big;          /* Cannot be SvTAIL! */
        }
        if (!littlelen)
            return (char*)big;          /* Cannot be SvTAIL! */
@@ -543,7 +607,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
                return (char*)bigend - 2;
            if (bigend[-1] == *little)
                return (char*)bigend - 1;
                return (char*)bigend - 2;
            if (bigend[-1] == *little)
                return (char*)bigend - 1;
-           return Nullch;
+           return NULL;
        }
        {
            /* This should be better than FBM if c1 == c2, and almost
        }
        {
            /* This should be better than FBM if c1 == c2, and almost
@@ -596,7 +660,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
       check_1char_anchor:              /* One char and anchor! */
        if (SvTAIL(littlestr) && (*bigend == *little))
            return (char *)bigend;      /* bigend is already decremented. */
       check_1char_anchor:              /* One char and anchor! */
        if (SvTAIL(littlestr) && (*bigend == *little))
            return (char *)bigend;      /* bigend is already decremented. */
-       return Nullch;
+       return NULL;
     }
     if (SvTAIL(littlestr) && !multiline) {     /* tail anchored? */
        s = bigend - littlelen;
     }
     if (SvTAIL(littlestr) && !multiline) {     /* tail anchored? */
        s = bigend - littlelen;
@@ -611,9 +675,9 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
        {
            return (char*)s + 1;        /* how sweet it is */
        }
        {
            return (char*)s + 1;        /* how sweet it is */
        }
-       return Nullch;
+       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);
 
@@ -625,17 +689,20 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
            {
                return (char*)s;
            }
            {
                return (char*)s;
            }
-           return Nullch;
+           return NULL;
        }
        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 Nullch;
        --littlelen;                    /* Last char found by table lookup */
 
        s = big + littlelen;
        --littlelen;                    /* Last char found by table lookup */
 
        s = big + littlelen;
@@ -668,11 +735,12 @@ 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;
-       return Nullch;
+       return NULL;
     }
 }
 
     }
 }
 
@@ -704,6 +772,9 @@ 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;
 
+    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)) {
@@ -715,7 +786,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
            first = *little++;
            goto check_tail;
        }
            first = *little++;
            goto check_tail;
        }
-       return Nullch;
+       return NULL;
     }
 
     little = (const unsigned char *)(SvPVX_const(littlestr));
     }
 
     little = (const unsigned char *)(SvPVX_const(littlestr));
@@ -735,7 +806,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
        if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
            goto check_tail;
 #endif
        if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
            goto check_tail;
 #endif
-       return Nullch;
+       return NULL;
     }
     while (pos < previous + start_shift) {
        if (!(pos += PL_screamnext[pos]))
     }
     while (pos < previous + start_shift) {
        if (!(pos += PL_screamnext[pos]))
@@ -763,7 +834,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
        return (char *)(big+(*old_posp));
   check_tail:
     if (!SvTAIL(littlestr) || (end_shift > 0))
        return (char *)(big+(*old_posp));
   check_tail:
     if (!SvTAIL(littlestr) || (end_shift > 0))
-       return Nullch;
+       return NULL;
     /* Ignore the trailing "\n".  This code is not microoptimized */
     big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
     stop_pos = littleend - little;     /* Actual littlestr len */
     /* Ignore the trailing "\n".  This code is not microoptimized */
     big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
     stop_pos = littleend - little;     /* Actual littlestr len */
@@ -774,7 +845,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
        && ((stop_pos == 1) ||
            memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
        return (char*)big;
        && ((stop_pos == 1) ||
            memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
        return (char*)big;
-    return Nullch;
+    return NULL;
 }
 
 I32
 }
 
 I32
@@ -782,6 +853,8 @@ Perl_ibcmp(pTHX_ 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;
+
     while (len--) {
        if (*a != *b && *a != PL_fold[*b])
            return 1;
     while (len--) {
        if (*a != *b && *a != PL_fold[*b])
            return 1;
@@ -796,6 +869,8 @@ Perl_ibcmp_locale(pTHX_ 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;
+
     while (len--) {
        if (*a != *b && *a != PL_fold_locale[*b])
            return 1;
     while (len--) {
        if (*a != *b && *a != PL_fold_locale[*b])
            return 1;
@@ -822,15 +897,15 @@ be freed with the C<Safefree()> function.
 char *
 Perl_savepv(pTHX_ const char *pv)
 {
 char *
 Perl_savepv(pTHX_ const char *pv)
 {
+    PERL_UNUSED_CONTEXT;
     if (!pv)
     if (!pv)
-       return Nullch;
+       return NULL;
     else {
        char *newaddr;
        const STRLEN pvlen = strlen(pv)+1;
     else {
        char *newaddr;
        const STRLEN pvlen = strlen(pv)+1;
-       Newx(newaddr,pvlen,char);
-       return memcpy(newaddr,pv,pvlen);
+       Newx(newaddr, pvlen, char);
+       return (char*)memcpy(newaddr, pv, pvlen);
     }
     }
-
 }
 
 /* same thing but with a known length */
 }
 
 /* same thing but with a known length */
@@ -840,8 +915,8 @@ Perl_savepv(pTHX_ const char *pv)
 
 Perl's version of what C<strndup()> would be if it existed. Returns a
 pointer to a newly allocated string which is a duplicate of the first
 
 Perl's version of what C<strndup()> would be if it existed. Returns a
 pointer to a newly allocated string which is a duplicate of the first
-C<len> bytes from C<pv>. The memory allocated for the new string can be
-freed with the C<Safefree()> function.
+C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
+the new string can be freed with the C<Safefree()> function.
 
 =cut
 */
 
 =cut
 */
@@ -850,6 +925,7 @@ char *
 Perl_savepvn(pTHX_ const char *pv, register I32 len)
 {
     register char *newaddr;
 Perl_savepvn(pTHX_ const char *pv, register I32 len)
 {
     register char *newaddr;
+    PERL_UNUSED_CONTEXT;
 
     Newx(newaddr,len+1,char);
     /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
 
     Newx(newaddr,len+1,char);
     /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
@@ -877,14 +953,35 @@ Perl_savesharedpv(pTHX_ const char *pv)
     register char *newaddr;
     STRLEN pvlen;
     if (!pv)
     register char *newaddr;
     STRLEN pvlen;
     if (!pv)
-       return Nullch;
+       return NULL;
 
     pvlen = strlen(pv)+1;
     newaddr = (char*)PerlMemShared_malloc(pvlen);
     if (!newaddr) {
        return write_no_mem();
     }
 
     pvlen = strlen(pv)+1;
     newaddr = (char*)PerlMemShared_malloc(pvlen);
     if (!newaddr) {
        return write_no_mem();
     }
-    return memcpy(newaddr,pv,pvlen);
+    return (char*)memcpy(newaddr, pv, pvlen);
+}
+
+/*
+=for apidoc savesharedpvn
+
+A version of C<savepvn()> which allocates the duplicate string in memory
+which is shared between threads. (With the specific difference that a NULL
+pointer is not acceptable)
+
+=cut
+*/
+char *
+Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
+{
+    char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
+    assert(pv);
+    if (!newaddr) {
+       return write_no_mem();
+    }
+    newaddr[len] = '\0';
+    return (char*)memcpy(newaddr, pv, len);
 }
 
 /*
 }
 
 /*
@@ -929,7 +1026,7 @@ S_mess_alloc(pTHX)
     Newxz(any, 1, XPVMG);
     SvFLAGS(sv) = SVt_PVMG;
     SvANY(sv) = (void*)any;
     Newxz(any, 1, XPVMG);
     SvFLAGS(sv) = SVt_PVMG;
     SvANY(sv) = (void*)any;
-    SvPV_set(sv, 0);
+    SvPV_set(sv, NULL);
     SvREFCNT(sv) = 1 << 30; /* practically infinite */
     PL_mess_sv = sv;
     return sv;
     SvREFCNT(sv) = 1 << 30; /* practically infinite */
     PL_mess_sv = sv;
     return sv;
@@ -984,7 +1081,7 @@ char *
 Perl_vform(pTHX_ const char *pat, va_list *args)
 {
     SV * const sv = mess_alloc();
 Perl_vform(pTHX_ const char *pat, va_list *args)
 {
     SV * const sv = mess_alloc();
-    sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
+    sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
     return SvPVX(sv);
 }
 
     return SvPVX(sv);
 }
 
@@ -1013,8 +1110,8 @@ Perl_mess(pTHX_ const char *pat, ...)
     return retval;
 }
 
     return retval;
 }
 
-STATIC COP*
-S_closest_cop(pTHX_ COP *cop, const OP *o)
+STATIC const COP*
+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. */
@@ -1023,15 +1120,15 @@ S_closest_cop(pTHX_ COP *cop, const OP *o)
        return cop;
 
     if (o->op_flags & OPf_KIDS) {
        return cop;
 
     if (o->op_flags & OPf_KIDS) {
-       OP *kid;
+       const OP *kid;
        for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
        for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
-           COP *new_cop;
+           const COP *new_cop;
 
            /* If the OP_NEXTSTATE has been optimised away we can still use it
             * the get the file and line number. */
 
            if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
 
            /* If the OP_NEXTSTATE has been optimised away we can still use it
             * the get the file and line number. */
 
            if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
-               cop = (COP *)kid;
+               cop = (const COP *)kid;
 
            /* Keep searching, and return when we've found something. */
 
 
            /* Keep searching, and return when we've found something. */
 
@@ -1043,7 +1140,7 @@ S_closest_cop(pTHX_ COP *cop, const OP *o)
 
     /* Nothing found. */
 
 
     /* Nothing found. */
 
-    return Null(COP *);
+    return NULL;
 }
 
 SV *
 }
 
 SV *
@@ -1051,11 +1148,9 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
 {
     dVAR;
     SV * const sv = mess_alloc();
 {
     dVAR;
     SV * const sv = mess_alloc();
-    static const char dgd[] = " during global destruction.\n";
 
 
-    sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
+    sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
-
        /*
         * Try and find the file and line for PL_op.  This will usually be
         * PL_curcop, but it might be a cop that has been optimised away.  We
        /*
         * Try and find the file and line for PL_op.  This will usually be
         * PL_curcop, but it might be a cop that has been optimised away.  We
@@ -1064,21 +1159,26 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
         */
 
        const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
         */
 
        const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
-       if (!cop) cop = PL_curcop;
+       if (!cop)
+           cop = PL_curcop;
 
        if (CopLINE(cop))
            Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
            OutCopFILE(cop), (IV)CopLINE(cop));
 
        if (CopLINE(cop))
            Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
            OutCopFILE(cop), (IV)CopLINE(cop));
-       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,
-                          PL_last_in_gv == PL_argvgv ?
-                          "" : GvNAME(PL_last_in_gv),
+                          PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
                           line_mode ? "line" : "chunk",
                           (IV)IoLINES(GvIOp(PL_last_in_gv)));
        }
                           line_mode ? "line" : "chunk",
                           (IV)IoLINES(GvIOp(PL_last_in_gv)));
        }
-       sv_catpv(sv, PL_dirty ? dgd : ".\n");
+       if (PL_dirty)
+           sv_catpvs(sv, " during global destruction");
+       sv_catpvs(sv, ".\n");
     }
     return sv;
 }
     }
     return sv;
 }
@@ -1100,7 +1200,7 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
 
        save_re_context();
        SAVESPTR(PL_stderrgv);
 
        save_re_context();
        SAVESPTR(PL_stderrgv);
-       PL_stderrgv = Nullgv;
+       PL_stderrgv = NULL;
 
        PUSHSTACKi(PERLSI_MAGIC);
 
 
        PUSHSTACKi(PERLSI_MAGIC);
 
@@ -1130,23 +1230,25 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
     }
 }
 
     }
 }
 
-/* Common code used by vcroak, vdie and vwarner  */
+/* Common code used by vcroak, vdie, vwarn and vwarner  */
 
 
-STATIC void
-S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
+STATIC bool
+S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
 {
     dVAR;
     HV *stash;
     GV *gv;
     CV *cv;
 {
     dVAR;
     HV *stash;
     GV *gv;
     CV *cv;
-    /* sv_2cv might call Perl_croak() */
-    SV * const olddiehook = PL_diehook;
+    SV **const hook = warn ? &PL_warnhook : &PL_diehook;
+    /* sv_2cv might call Perl_croak() or Perl_warner() */
+    SV * const oldhook = *hook;
+
+    assert(oldhook);
 
 
-    assert(PL_diehook);
     ENTER;
     ENTER;
-    SAVESPTR(PL_diehook);
-    PL_diehook = Nullsv;
-    cv = sv_2cv(olddiehook, &stash, &gv, 0);
+    SAVESPTR(*hook);
+    *hook = NULL;
+    cv = sv_2cv(oldhook, &stash, &gv, 0);
     LEAVE;
     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
        dSP;
     LEAVE;
     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
        dSP;
@@ -1154,7 +1256,11 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
 
        ENTER;
        save_re_context();
 
        ENTER;
        save_re_context();
-       if (message) {
+       if (warn) {
+           SAVESPTR(*hook);
+           *hook = NULL;
+       }
+       if (warn || message) {
            msg = newSVpvn(message, msglen);
            SvFLAGS(msg) |= utf8;
            SvREADONLY_on(msg);
            msg = newSVpvn(message, msglen);
            SvFLAGS(msg) |= utf8;
            SvREADONLY_on(msg);
@@ -1164,14 +1270,16 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
            msg = ERRSV;
        }
 
            msg = ERRSV;
        }
 
-       PUSHSTACKi(PERLSI_DIEHOOK);
+       PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
        PUSHMARK(SP);
        XPUSHs(msg);
        PUTBACK;
        call_sv((SV*)cv, G_DISCARD);
        POPSTACK;
        LEAVE;
        PUSHMARK(SP);
        XPUSHs(msg);
        PUTBACK;
        call_sv((SV*)cv, G_DISCARD);
        POPSTACK;
        LEAVE;
+       return TRUE;
     }
     }
+    return FALSE;
 }
 
 STATIC const char *
 }
 
 STATIC const char *
@@ -1193,14 +1301,14 @@ S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
        *utf8 = SvUTF8(msv);
     }
     else {
        *utf8 = SvUTF8(msv);
     }
     else {
-       message = Nullch;
+       message = NULL;
     }
 
     DEBUG_S(PerlIO_printf(Perl_debug_log,
                          "%p: die/croak: message = %s\ndiehook = %p\n",
     }
 
     DEBUG_S(PerlIO_printf(Perl_debug_log,
                          "%p: die/croak: message = %s\ndiehook = %p\n",
-                         thr, message, PL_diehook));
+                         (void*)thr, message, (void*)PL_diehook));
     if (PL_diehook) {
     if (PL_diehook) {
-       S_vdie_common(aTHX_ message, *msglen, *utf8);
+       S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
     }
     return message;
 }
     }
     return message;
 }
@@ -1216,7 +1324,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args)
 
     DEBUG_S(PerlIO_printf(Perl_debug_log,
                          "%p: die: curstack = %p, mainstack = %p\n",
 
     DEBUG_S(PerlIO_printf(Perl_debug_log,
                          "%p: die: curstack = %p, mainstack = %p\n",
-                         thr, PL_curstack, PL_mainstack));
+                         (void*)thr, (void*)PL_curstack, (void*)PL_mainstack));
 
     message = vdie_croak_common(pat, args, &msglen, &utf8);
 
 
     message = vdie_croak_common(pat, args, &msglen, &utf8);
 
@@ -1224,7 +1332,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args)
     SvFLAGS(ERRSV) |= utf8;
     DEBUG_S(PerlIO_printf(Perl_debug_log,
          "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
     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));
+         (void*)thr, (void*)PL_restartop, was_in_eval, (void*)PL_top_env));
     if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
        JMPENV_JUMP(3);
     return PL_restartop;
     if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
        JMPENV_JUMP(3);
     return PL_restartop;
@@ -1301,11 +1409,11 @@ function.  Calling C<croak> returns control directly to Perl,
 sidestepping the normal C order of execution. See C<warn>.
 
 If you want to throw an exception object, assign the object to
 sidestepping the normal C order of execution. See C<warn>.
 
 If you want to throw an exception object, assign the object to
-C<$@> and then pass C<Nullch> to croak():
+C<$@> and then pass C<NULL> to croak():
 
    errsv = get_sv("@", TRUE);
    sv_setsv(errsv, exception_object);
 
    errsv = get_sv("@", TRUE);
    sv_setsv(errsv, exception_object);
-   croak(Nullch);
+   croak(NULL);
 
 =cut
 */
 
 =cut
 */
@@ -1330,39 +1438,8 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args)
     const char * const message = SvPV_const(msv, msglen);
 
     if (PL_warnhook) {
     const char * const message = SvPV_const(msv, msglen);
 
     if (PL_warnhook) {
-       /* sv_2cv might call Perl_warn() */
-       SV * const oldwarnhook = PL_warnhook;
-       CV * cv;
-       HV * stash;
-       GV * gv;
-
-       ENTER;
-       SAVESPTR(PL_warnhook);
-       PL_warnhook = Nullsv;
-       cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
-       LEAVE;
-       if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
-           dSP;
-           SV *msg;
-
-           ENTER;
-           SAVESPTR(PL_warnhook);
-           PL_warnhook = Nullsv;
-           save_re_context();
-           msg = newSVpvn(message, msglen);
-           SvFLAGS(msg) |= utf8;
-           SvREADONLY_on(msg);
-           SAVEFREESV(msg);
-
-           PUSHSTACKi(PERLSI_WARNHOOK);
-           PUSHMARK(SP);
-           XPUSHs(msg);
-           PUTBACK;
-           call_sv((SV*)cv, G_DISCARD);
-           POPSTACK;
-           LEAVE;
+       if (vdie_common(message, msglen, utf8, TRUE))
            return;
            return;
-       }
     }
 
     write_to_stderr(message, msglen);
     }
 
     write_to_stderr(message, msglen);
@@ -1423,7 +1500,7 @@ void
 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
 {
     dVAR;
 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
 {
     dVAR;
-    if (ckDEAD(err)) {
+    if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
        SV * const msv = vmess(pat, args);
        STRLEN msglen;
        const char * const message = SvPV_const(msv, msglen);
        SV * const msv = vmess(pat, args);
        STRLEN msglen;
        const char * const message = SvPV_const(msv, msglen);
@@ -1431,7 +1508,7 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
 
        if (PL_diehook) {
            assert(message);
 
        if (PL_diehook) {
            assert(message);
-           S_vdie_common(aTHX_ message, msglen, utf8);
+           S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
        }
        if (PL_in_eval) {
            PL_restartop = die_where(message, msglen);
        }
        if (PL_in_eval) {
            PL_restartop = die_where(message, msglen);
@@ -1498,7 +1575,21 @@ Perl_ckwarn_d(pTHX_ U32 w)
        ;
 }
 
        ;
 }
 
+/* Set buffer=NULL to get a new one.  */
+STRLEN *
+Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
+                          STRLEN size) {
+    const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
+    PERL_UNUSED_CONTEXT;
 
 
+    buffer = (STRLEN*)
+       (specialWARN(buffer) ?
+        PerlMemShared_malloc(len_wanted) :
+        PerlMemShared_realloc(buffer, len_wanted));
+    buffer[0] = size;
+    Copy(bits, (buffer + 1), size, char);
+    return buffer;
+}
 
 /* since we've already done strlen() for both nam and val
  * we can use that info to make things faster than
 
 /* since we've already done strlen() for both nam and val
  * we can use that info to make things faster than
@@ -1525,47 +1616,49 @@ 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=setenv_getix(nam);          /* where does it go? */
     int nlen, vlen;
 
     int nlen, vlen;
 
-    if (environ == PL_origenviron) {   /* need we copy environment? */
-       I32 j;
-       I32 max;
-       char **tmpenv;
-
-       for (max = i; environ[max]; max++) ;
-       tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
-       for (j=0; j<max; j++) {         /* copy environment */
-           const int len = strlen(environ[j]);
-           tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
-           Copy(environ[j], tmpenv[j], len+1, char);
-       }
-       tmpenv[max] = Nullch;
-       environ = tmpenv;               /* tell exec where it is now */
+    if (environ == PL_origenviron) {   /* need we copy environment? */
+       I32 j;
+       I32 max;
+       char **tmpenv;
+
+       max = i;
+       while (environ[max])
+           max++;
+       tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
+       for (j=0; j<max; j++) {         /* copy environment */
+           const int len = strlen(environ[j]);
+           tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
+           Copy(environ[j], tmpenv[j], len+1, char);
+       }
+       tmpenv[max] = NULL;
+       environ = tmpenv;               /* tell exec where it is now */
     }
     if (!val) {
     }
     if (!val) {
-       safesysfree(environ[i]);
-       while (environ[i]) {
-           environ[i] = environ[i+1];
-           i++;
+       safesysfree(environ[i]);
+       while (environ[i]) {
+           environ[i] = environ[i+1];
+           i++;
        }
        }
-       return;
+       return;
     }
     }
-    if (!environ[i]) {                 /* does not exist yet */
-       environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
-       environ[i+1] = Nullch;  /* make sure it's null terminated */
+    if (!environ[i]) {                 /* does not exist yet */
+       environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
+       environ[i+1] = NULL;    /* make sure it's null terminated */
     }
     else
     }
     else
-       safesysfree(environ[i]);
-    nlen = strlen(nam);
-    vlen = strlen(val);
+       safesysfree(environ[i]);
+       nlen = strlen(nam);
+       vlen = strlen(val);
 
 
-    environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
-    /* all that work just for this */
-    my_setenv_format(environ[i], nam, nlen, val, vlen);
+       environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
+       /* all that work just for this */
+       my_setenv_format(environ[i], nam, nlen, val, vlen);
     } else {
 # endif
     } else {
 # endif
-#   if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__)
+#   if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
 #       if defined(HAS_UNSETENV)
         if (val == NULL) {
             (void)unsetenv(nam);
 #       if defined(HAS_UNSETENV)
         if (val == NULL) {
             (void)unsetenv(nam);
@@ -1618,7 +1711,7 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
     int vlen;
 
     if (!val) {
     int vlen;
 
     if (!val) {
-       val = "";
+       val = "";
     }
     vlen = strlen(val);
     Newx(envstr, nlen+vlen+2, char);
     }
     vlen = strlen(val);
     Newx(envstr, nlen+vlen+2, char);
@@ -1635,6 +1728,7 @@ Perl_setenv_getix(pTHX_ const char *nam)
 {
     register I32 i;
     register const I32 len = strlen(nam);
 {
     register I32 i;
     register const I32 len = strlen(nam);
+    PERL_UNUSED_CONTEXT;
 
     for (i = 0; environ[i]; i++) {
        if (
 
     for (i = 0; environ[i]; i++) {
        if (
@@ -1656,10 +1750,11 @@ Perl_setenv_getix(pTHX_ const char *nam)
 I32
 Perl_unlnk(pTHX_ const char *f)        /* unlink all versions of a file */
 {
 I32
 Perl_unlnk(pTHX_ const char *f)        /* unlink all versions of a file */
 {
-    I32 i;
+    I32 retries = 0;
 
 
-    for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
-    return i ? 0 : -1;
+    while (PerlLIO_unlink(f) >= 0)
+       retries++;
+    return retries ? 0 : -1;
 }
 #endif
 
 }
 #endif
 
@@ -1849,8 +1944,8 @@ Perl_my_ntohl(pTHX_ long l)
                type value;                                     \
                char c[sizeof(type)];                           \
            } u;                                                \
                type value;                                     \
                char c[sizeof(type)];                           \
            } u;                                                \
-           register I32 i;                                     \
-           register I32 s = 0;                                 \
+           register U32 i;                                     \
+           register U32 s = 0;                                 \
            for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
                u.c[i] = (n >> s) & 0xFF;                       \
            }                                                   \
            for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
                u.c[i] = (n >> s) & 0xFF;                       \
            }                                                   \
@@ -1865,8 +1960,8 @@ Perl_my_ntohl(pTHX_ long l)
                type value;                                     \
                char c[sizeof(type)];                           \
            } u;                                                \
                type value;                                     \
                char c[sizeof(type)];                           \
            } u;                                                \
-           register I32 i;                                     \
-           register I32 s = 0;                                 \
+           register U32 i;                                     \
+           register U32 s = 0;                                 \
            u.value = n;                                        \
            n = 0;                                              \
            for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
            u.value = n;                                        \
            n = 0;                                              \
            for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
@@ -1887,8 +1982,8 @@ Perl_my_ntohl(pTHX_ long l)
                type value;                                     \
                char c[sizeof(type)];                           \
            } u;                                                \
                type value;                                     \
                char c[sizeof(type)];                           \
            } u;                                                \
-           register I32 i;                                     \
-           register I32 s = 8*(sizeof(u.c)-1);                 \
+           register U32 i;                                     \
+           register U32 s = 8*(sizeof(u.c)-1);                 \
            for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
                u.c[i] = (n >> s) & 0xFF;                       \
            }                                                   \
            for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
                u.c[i] = (n >> s) & 0xFF;                       \
            }                                                   \
@@ -1903,8 +1998,8 @@ Perl_my_ntohl(pTHX_ long l)
                type value;                                     \
                char c[sizeof(type)];                           \
            } u;                                                \
                type value;                                     \
                char c[sizeof(type)];                           \
            } u;                                                \
-           register I32 i;                                     \
-           register I32 s = 8*(sizeof(u.c)-1);                 \
+           register U32 i;                                     \
+           register U32 s = 8*(sizeof(u.c)-1);                 \
            u.value = n;                                        \
            n = 0;                                              \
            for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
            u.value = n;                                        \
            n = 0;                                              \
            for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
@@ -2099,7 +2194,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
        taint_proper("Insecure %s%s", "EXEC");
     }
     if (PerlProc_pipe(p) < 0)
        taint_proper("Insecure %s%s", "EXEC");
     }
     if (PerlProc_pipe(p) < 0)
-       return Nullfp;
+       return NULL;
     /* Try for another pipe pair for error return */
     if (PerlProc_pipe(pp) >= 0)
        did_pipes = 1;
     /* Try for another pipe pair for error return */
     if (PerlProc_pipe(pp) >= 0)
        did_pipes = 1;
@@ -2111,7 +2206,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
                PerlLIO_close(pp[0]);
                PerlLIO_close(pp[1]);
            }
                PerlLIO_close(pp[0]);
                PerlLIO_close(pp[1]);
            }
-           return Nullfp;
+           return NULL;
        }
        sleep(5);
     }
        }
        sleep(5);
     }
@@ -2152,7 +2247,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
            }
        }
 #endif
            }
        }
 #endif
-       do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
+       do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
        PerlProc__exit(1);
 #undef THIS
 #undef THAT
        PerlProc__exit(1);
 #undef THIS
 #undef THAT
@@ -2179,7 +2274,8 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
     /* If we managed to get status pipe check for exec fail */
     if (did_pipes && pid > 0) {
        int errkid;
     /* If we managed to get status pipe check for exec fail */
     if (did_pipes && pid > 0) {
        int errkid;
-       int n = 0, n1;
+       unsigned n = 0;
+       SSize_t n1;
 
        while (n < sizeof(int)) {
            n1 = PerlLIO_read(pp[0],
 
        while (n < sizeof(int)) {
            n1 = PerlLIO_read(pp[0],
@@ -2200,15 +2296,19 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
                pid2 = wait4pid(pid, &status, 0);
            } while (pid2 == -1 && errno == EINTR);
            errno = errkid;             /* Propagate errno from kid */
                pid2 = wait4pid(pid, &status, 0);
            } while (pid2 == -1 && errno == EINTR);
            errno = errkid;             /* Propagate errno from kid */
-           return Nullfp;
+           return NULL;
        }
     }
     if (did_pipes)
         PerlLIO_close(pp[0]);
     return PerlIO_fdopen(p[This], mode);
 #else
        }
     }
     if (did_pipes)
         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_ Nullch, 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
 }
 
 #endif
 }
 
@@ -2239,7 +2339,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
        taint_proper("Insecure %s%s", "EXEC");
     }
     if (PerlProc_pipe(p) < 0)
        taint_proper("Insecure %s%s", "EXEC");
     }
     if (PerlProc_pipe(p) < 0)
-       return Nullfp;
+       return NULL;
     if (doexec && PerlProc_pipe(pp) >= 0)
        did_pipes = 1;
     while ((pid = PerlProc_fork()) < 0) {
     if (doexec && PerlProc_pipe(pp) >= 0)
        did_pipes = 1;
     while ((pid = PerlProc_fork()) < 0) {
@@ -2252,7 +2352,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
            }
            if (!doexec)
                Perl_croak(aTHX_ "Can't fork");
            }
            if (!doexec)
                Perl_croak(aTHX_ "Can't fork");
-           return Nullfp;
+           return NULL;
        }
        sleep(5);
     }
        }
        sleep(5);
     }
@@ -2296,7 +2396,15 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
            PerlProc__exit(1);
        }
 #endif /* defined OS2 */
            PerlProc__exit(1);
        }
 #endif /* defined OS2 */
-       if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
+
+#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());
            SvREADONLY_on(GvSV(tmpgv));
            SvREADONLY_off(GvSV(tmpgv));
            sv_setiv(GvSV(tmpgv), PerlProc_getpid());
            SvREADONLY_on(GvSV(tmpgv));
@@ -2308,7 +2416,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 #ifdef PERL_USES_PL_PIDSTATUS
        hv_clear(PL_pidstatus); /* we have no children */
 #endif
 #ifdef PERL_USES_PL_PIDSTATUS
        hv_clear(PL_pidstatus); /* we have no children */
 #endif
-       return Nullfp;
+       return NULL;
 #undef THIS
 #undef THAT
     }
 #undef THIS
 #undef THAT
     }
@@ -2331,7 +2439,8 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
     PL_forkprocess = pid;
     if (did_pipes && pid > 0) {
        int errkid;
     PL_forkprocess = pid;
     if (did_pipes && pid > 0) {
        int errkid;
-       int n = 0, n1;
+       unsigned n = 0;
+       SSize_t n1;
 
        while (n < sizeof(int)) {
            n1 = PerlLIO_read(pp[0],
 
        while (n < sizeof(int)) {
            n1 = PerlLIO_read(pp[0],
@@ -2352,7 +2461,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
                pid2 = wait4pid(pid, &status, 0);
            } while (pid2 == -1 && errno == EINTR);
            errno = errkid;             /* Propagate errno from kid */
                pid2 = wait4pid(pid, &status, 0);
            } while (pid2 == -1 && errno == EINTR);
            errno = errkid;             /* Propagate errno from kid */
-           return Nullfp;
+           return NULL;
        }
     }
     if (did_pipes)
        }
     }
     if (did_pipes)
@@ -2363,7 +2472,7 @@ 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_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.
@@ -2376,7 +2485,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.
@@ -2532,6 +2641,7 @@ Sighandler_t
 Perl_rsignal_state(pTHX_ int signo)
 {
     struct sigaction oact;
 Perl_rsignal_state(pTHX_ int signo)
 {
     struct sigaction oact;
+    PERL_UNUSED_CONTEXT;
 
     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
        return (Sighandler_t) SIG_ERR;
 
     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
        return (Sighandler_t) SIG_ERR;
@@ -2758,7 +2868,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
     goto finish;
 #endif
 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
     goto finish;
 #endif
 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
-    result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
+    result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
     goto finish;
 #endif
 #ifdef PERL_USES_PL_PIDSTATUS
     goto finish;
 #endif
 #ifdef PERL_USES_PL_PIDSTATUS
@@ -2837,6 +2947,7 @@ Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, regi
 {
     register I32 todo;
     register const char * const frombase = from;
 {
     register I32 todo;
     register const char * const frombase = from;
+    PERL_UNUSED_CONTEXT;
 
     if (len == 1) {
        register const char c = *from;
 
     if (len == 1) {
        register const char c = *from;
@@ -2894,8 +3005,8 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
                 const char *const *const search_ext, I32 flags)
 {
     dVAR;
                 const char *const *const search_ext, I32 flags)
 {
     dVAR;
-    const char *xfound = Nullch;
-    char *xfailed = Nullch;
+    const char *xfound = NULL;
+    char *xfailed = NULL;
     char tmpbuf[MAXPATHLEN];
     register char *s;
     I32 len = 0;
     char tmpbuf[MAXPATHLEN];
     register char *s;
     I32 len = 0;
@@ -2917,7 +3028,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
     static const char *const exts[] = { SEARCH_EXTS };
     const char *const *const ext = search_ext ? search_ext : exts;
     int extidx = 0, i = 0;
     static const char *const exts[] = { SEARCH_EXTS };
     const char *const *const ext = search_ext ? search_ext : exts;
     int extidx = 0, i = 0;
-    const char *curext = Nullch;
+    const char *curext = NULL;
 #else
     PERL_UNUSED_ARG(search_ext);
 #  define MAX_EXT_LEN 0
 #else
     PERL_UNUSED_ARG(search_ext);
 #  define MAX_EXT_LEN 0
@@ -2950,13 +3061,13 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
        int idx = 0, deftypes = 1;
        bool seen_dot = 1;
 
        int idx = 0, deftypes = 1;
        bool seen_dot = 1;
 
-       const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch);
+       const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
 #  else
     if (dosearch) {
        int idx = 0, deftypes = 1;
        bool seen_dot = 1;
 
 #  else
     if (dosearch) {
        int idx = 0, deftypes = 1;
        bool seen_dot = 1;
 
-       const int hasdir = (strpbrk(scriptname,":[</") != Nullch);
+       const int hasdir = (strpbrk(scriptname,":[</") != NULL);
 #  endif
        /* The first time through, just add SEARCH_EXTS to whatever we
         * already have, so we can check for default file types. */
 #  endif
        /* The first time through, just add SEARCH_EXTS to whatever we
         * already have, so we can check for default file types. */
@@ -2970,7 +3081,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
            if ((strlen(tmpbuf) + strlen(scriptname)
                 + MAX_EXT_LEN) >= sizeof tmpbuf)
                continue;       /* don't search dir with too-long name */
            if ((strlen(tmpbuf) + strlen(scriptname)
                 + MAX_EXT_LEN) >= sizeof tmpbuf)
                continue;       /* don't search dir with too-long name */
-           strcat(tmpbuf, scriptname);
+           my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
 #else  /* !VMS */
 
 #ifdef DOSISH
 #else  /* !VMS */
 
 #ifdef DOSISH
@@ -3002,11 +3113,11 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
                len = strlen(scriptname);
                if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
                    break;
                len = strlen(scriptname);
                if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
                    break;
-               /* FIXME? Convert to memcpy  */
-               cur = strcpy(tmpbuf, scriptname);
+               my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
+               cur = tmpbuf;
            }
        } while (extidx >= 0 && ext[extidx]     /* try an extension? */
            }
        } while (extidx >= 0 && ext[extidx]     /* try an extension? */
-                && strcpy(tmpbuf+len, ext[extidx++]));
+                && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
 #endif
     }
 #endif
 #endif
     }
 #endif
@@ -3066,9 +3177,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
            if (len == 2 && tmpbuf[0] == '.')
                seen_dot = 1;
 #endif
            if (len == 2 && tmpbuf[0] == '.')
                seen_dot = 1;
 #endif
-           /* FIXME? Convert to memcpy by storing previous strlen(scriptname)
-            */
-           (void)strcpy(tmpbuf + len, scriptname);
+           (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
 #endif  /* !VMS */
 
 #ifdef SEARCH_EXTS
 #endif  /* !VMS */
 
 #ifdef SEARCH_EXTS
@@ -3085,7 +3194,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
 #ifdef SEARCH_EXTS
            } while (  retval < 0               /* not there */
                    && extidx>=0 && ext[extidx] /* try an extension? */
 #ifdef SEARCH_EXTS
            } while (  retval < 0               /* not there */
                    && extidx>=0 && ext[extidx] /* try an extension? */
-                   && strcpy(tmpbuf+len, ext[extidx++])
+                   && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
                );
 #endif
            if (retval < 0)
                );
 #endif
            if (retval < 0)
@@ -3117,12 +3226,12 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
                      (xfailed ? "" : " on PATH"),
                      (xfailed || seen_dot) ? "" : ", '.' not in PATH");
            }
                      (xfailed ? "" : " on PATH"),
                      (xfailed || seen_dot) ? "" : ", '.' not in PATH");
            }
-           scriptname = Nullch;
+           scriptname = NULL;
        }
        Safefree(xfailed);
        scriptname = xfound;
     }
        }
        Safefree(xfailed);
        scriptname = xfound;
     }
-    return (scriptname ? savepv(scriptname) : Nullch);
+    return (scriptname ? savepv(scriptname) : NULL);
 }
 
 #ifndef PERL_GET_CONTEXT_DEFINED
 }
 
 #ifndef PERL_GET_CONTEXT_DEFINED
@@ -3178,32 +3287,37 @@ Perl_GetVars(pTHX)
 char **
 Perl_get_op_names(pTHX)
 {
 char **
 Perl_get_op_names(pTHX)
 {
- return (char **)PL_op_name;
+    PERL_UNUSED_CONTEXT;
+    return (char **)PL_op_name;
 }
 
 char **
 Perl_get_op_descs(pTHX)
 {
 }
 
 char **
 Perl_get_op_descs(pTHX)
 {
- return (char **)PL_op_desc;
+    PERL_UNUSED_CONTEXT;
+    return (char **)PL_op_desc;
 }
 
 const char *
 Perl_get_no_modify(pTHX)
 {
 }
 
 const char *
 Perl_get_no_modify(pTHX)
 {
- return PL_no_modify;
+    PERL_UNUSED_CONTEXT;
+    return PL_no_modify;
 }
 
 U32 *
 Perl_get_opargs(pTHX)
 {
 }
 
 U32 *
 Perl_get_opargs(pTHX)
 {
- return (U32 *)PL_opargs;
+    PERL_UNUSED_CONTEXT;
+    return (U32 *)PL_opargs;
 }
 
 PPADDR_t*
 Perl_get_ppaddr(pTHX)
 {
 }
 
 PPADDR_t*
 Perl_get_ppaddr(pTHX)
 {
- dVAR;
- return (PPADDR_t*)PL_ppaddr;
+    dVAR;
+    PERL_UNUSED_CONTEXT;
+    return (PPADDR_t*)PL_ppaddr;
 }
 
 #ifndef HAS_GETENV_LEN
 }
 
 #ifndef HAS_GETENV_LEN
@@ -3211,6 +3325,7 @@ char *
 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
 {
     char * const env_trans = PerlEnv_getenv(env_elem);
 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
 {
     char * const env_trans = PerlEnv_getenv(env_elem);
+    PERL_UNUSED_CONTEXT;
     if (env_trans)
        *len = strlen(env_trans);
     return env_trans;
     if (env_trans)
        *len = strlen(env_trans);
     return env_trans;
@@ -3222,6 +3337,7 @@ MGVTBL*
 Perl_get_vtbl(pTHX_ int vtbl_id)
 {
     const MGVTBL* result;
 Perl_get_vtbl(pTHX_ int vtbl_id)
 {
     const MGVTBL* result;
+    PERL_UNUSED_CONTEXT;
 
     switch(vtbl_id) {
     case want_vtbl_sv:
 
     switch(vtbl_id) {
     case want_vtbl_sv:
@@ -3257,9 +3373,6 @@ Perl_get_vtbl(pTHX_ int vtbl_id)
     case want_vtbl_arylen:
        result = &PL_vtbl_arylen;
        break;
     case want_vtbl_arylen:
        result = &PL_vtbl_arylen;
        break;
-    case want_vtbl_glob:
-       result = &PL_vtbl_glob;
-       break;
     case want_vtbl_mglob:
        result = &PL_vtbl_mglob;
        break;
     case want_vtbl_mglob:
        result = &PL_vtbl_mglob;
        break;
@@ -3317,7 +3430,7 @@ Perl_get_vtbl(pTHX_ int vtbl_id)
        result = &PL_vtbl_utf8;
        break;
     default:
        result = &PL_vtbl_utf8;
        break;
     default:
-       result = Null(MGVTBL*);
+       result = NULL;
        break;
     }
     return (MGVTBL*)result;
        break;
     }
     return (MGVTBL*)result;
@@ -3376,19 +3489,12 @@ Perl_my_fflush_all(pTHX)
 void
 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
 {
 void
 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
 {
-    const char * const func =
-       op == OP_READLINE   ? "readline"  :     /* "<HANDLE>" not nice */
-       op == OP_LEAVEWRITE ? "write" :         /* "write exit" not nice */
-       PL_op_desc[op];
-    const char * const pars = OP_IS_FILETEST(op) ? "" : "()";
-    const char * const type = OP_IS_SOCKET(op)
-           || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
-               ?  "socket" : "filehandle";
     const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
 
     if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
        if (ckWARN(WARN_IO)) {
     const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
 
     if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
        if (ckWARN(WARN_IO)) {
-           const char * const direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
+           const char * const direction =
+               (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
            if (name && *name)
                Perl_warner(aTHX_ packWARN(WARN_IO),
                            "Filehandle %s opened only for %sput",
            if (name && *name)
                Perl_warner(aTHX_ packWARN(WARN_IO),
                            "Filehandle %s opened only for %sput",
@@ -3412,6 +3518,19 @@ Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
        }
 
        if (ckWARN(warn_type)) {
        }
 
        if (ckWARN(warn_type)) {
+           const char * const pars =
+               (const char *)(OP_IS_FILETEST(op) ? "" : "()");
+           const char * const func =
+               (const char *)
+               (op == OP_READLINE   ? "readline"  :    /* "<HANDLE>" not nice */
+                op == OP_LEAVEWRITE ? "write" :                /* "write exit" not nice */
+                op < 0              ? "" :              /* handle phoney cases */
+                PL_op_desc[op]);
+           const char * const type =
+               (const char *)
+               (OP_IS_SOCKET(op) ||
+                (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
+                "socket" : "filehandle");
            if (name && *name) {
                Perl_warner(aTHX_ packWARN(warn_type),
                            "%s%s on %s %s %s", func, pars, vile, type, name);
            if (name && *name) {
                Perl_warner(aTHX_ packWARN(warn_type),
                            "%s%s on %s %s %s", func, pars, vile, type, name);
@@ -3524,6 +3643,7 @@ Perl_mini_mktime(pTHX_ struct tm *ptm)
     int secs;
     int month, mday, year, jday;
     int odd_cent, odd_year;
     int secs;
     int month, mday, year, jday;
     int odd_cent, odd_year;
+    PERL_UNUSED_CONTEXT;
 
 #define        DAYS_PER_YEAR   365
 #define        DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
 
 #define        DAYS_PER_YEAR   365
 #define        DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
@@ -3766,7 +3886,7 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in
   else {
     /* Possibly buf overflowed - try again with a bigger buf */
     const int fmtlen = strlen(fmt);
   else {
     /* Possibly buf overflowed - try again with a bigger buf */
     const int fmtlen = strlen(fmt);
-    const int bufsize = fmtlen + buflen;
+    int bufsize = fmtlen + buflen;
 
     Newx(buf, bufsize, char);
     while (buf) {
 
     Newx(buf, bufsize, char);
     while (buf) {
@@ -3779,7 +3899,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;
   }
@@ -3972,12 +4093,12 @@ an RV.
 Function must be called with an already existing SV like
 
     sv = newSV(0);
 Function must be called with an already existing SV like
 
     sv = newSV(0);
-    s = scan_version(s,SV *sv, bool qv);
+    s = scan_version(s, SV *sv, bool qv);
 
 Performs some preprocessing to the string to ensure that
 it has the correct characteristics of a version.  Flags the
 object if it contains an underscore (which denotes this
 
 Performs some preprocessing to the string to ensure that
 it has the correct characteristics of a version.  Flags the
 object if it contains an underscore (which denotes this
-is a alpha version).  The boolean qv denotes that the version
+is an alpha version).  The boolean qv denotes that the version
 should be interpreted as if it had multiple decimals, even if
 it doesn't.
 
 should be interpreted as if it had multiple decimals, even if
 it doesn't.
 
@@ -4031,6 +4152,12 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
        pos++;
     }
 
        pos++;
     }
 
+    if ( alpha && !saw_period )
+       Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
+
+    if ( alpha && saw_period && width == 0 )
+       Perl_croak(aTHX_ "Invalid version format (misplaced _ in number)");
+
     if ( saw_period > 1 )
        qv = 1; /* force quoted version processing */
 
     if ( saw_period > 1 )
        qv = 1; /* force quoted version processing */
 
@@ -4086,7 +4213,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
 
            /* Append revision */
            av_push(av, newSViv(rev));
 
            /* Append revision */
            av_push(av, newSViv(rev));
-           if ( *pos == '.' && isDIGIT(pos[1]) )
+           if ( *pos == '.' )
                s = ++pos;
            else if ( *pos == '_' && isDIGIT(pos[1]) )
                s = ++pos;
                s = ++pos;
            else if ( *pos == '_' && isDIGIT(pos[1]) )
                s = ++pos;
@@ -4127,6 +4254,11 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
        av_push(av, newSViv(0));
 
     if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
        av_push(av, newSViv(0));
 
+    /* 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;
     /* And finally, store the AV in the hash */
     hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
     return s;
@@ -4174,11 +4306,11 @@ Perl_new_version(pTHX_ SV *ver)
        
        if ( hv_exists((HV*)ver, "width", 5 ) )
        {
        
        if ( hv_exists((HV*)ver, "width", 5 ) )
        {
-           const I32 width = SvIV(*hv_fetch((HV*)ver, "width", 5, FALSE));
+           const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE));
            hv_store((HV *)hv, "width", 5, newSViv(width), 0);
        }
 
            hv_store((HV *)hv, "width", 5, newSViv(width), 0);
        }
 
-       sav = (AV *)SvRV(*hv_fetch((HV*)ver, "version", 7, FALSE));
+       sav = (AV *)SvRV(*hv_fetchs((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++ )
        {
@@ -4190,21 +4322,22 @@ Perl_new_version(pTHX_ SV *ver)
        return rv;
     }
 #ifdef SvVOK
        return rv;
     }
 #ifdef SvVOK
-    if ( SvVOK(ver) ) { /* already a v-string */
-       const MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring);
-       const STRLEN len = mg->mg_len;
-       char * const version = savepvn( (const char*)mg->mg_ptr, len);
-       sv_setpvn(rv,version,len);
-       Safefree(version);
-    }
-    else {
+    {
+       const MAGIC* const mg = SvVSTRING_mg(ver);
+       if ( mg ) { /* already a v-string */
+           const STRLEN len = mg->mg_len;
+           char * const version = savepvn( (const char*)mg->mg_ptr, len);
+           sv_setpvn(rv,version,len);
+           Safefree(version);
+       }
+       else {
 #endif
 #endif
-    sv_setsv(rv,ver); /* make a duplicate */
+       sv_setsv(rv,ver); /* make a duplicate */
 #ifdef SvVOK
 #ifdef SvVOK
+       }
     }
 #endif
     }
 #endif
-    upg_version(rv);
-    return rv;
+    return upg_version(rv, FALSE);
 }
 
 /*
 }
 
 /*
@@ -4212,37 +4345,81 @@ 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)
 {
 {
-    char *version;
-    bool qv = 0;
+    const char *version, *s;
+#ifdef SvVOK
+    const MAGIC *mg;
+#endif
 
 
-    if ( SvNOK(ver) ) /* may get too much accuracy */ 
+    if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
     {
     {
+       /* may get too much accuracy */ 
        char tbuf[64];
        char tbuf[64];
-       const STRLEN len = my_sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
+#ifdef USE_LOCALE_NUMERIC
+       char *loc = setlocale(LC_NUMERIC, "C");
+#endif
+       STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
+#ifdef USE_LOCALE_NUMERIC
+       setlocale(LC_NUMERIC, loc);
+#endif
+       while (tbuf[len-1] == '0' && len > 0) len--;
        version = savepvn(tbuf, len);
     }
 #ifdef SvVOK
        version = savepvn(tbuf, len);
     }
 #ifdef SvVOK
-    else if ( SvVOK(ver) ) { /* already a v-string */
-       const MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring);
+    else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
        version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
        qv = 1;
     }
 #endif
     else /* must be a string or something like a string */
     {
        version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
        qv = 1;
     }
 #endif
     else /* must be a string or something like a string */
     {
-       version = savepv(SvPV_nolen(ver));
+       STRLEN len;
+       version = savepv(SvPV(ver,len));
+#ifndef SvVOK
+#  if PERL_VERSION > 5
+       /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
+       if ( len == 3 && !instr(version,".") && !instr(version,"_") ) {
+           /* may be a v-string */
+           SV * const nsv = sv_newmortal();
+           const char *nver;
+           const char *pos;
+           int saw_period = 0;
+           sv_setpvf(nsv,"%vd",ver);
+           pos = nver = savepv(SvPV_nolen(nsv));
+
+           /* scan the resulting formatted string */
+           while ( *pos == '.' || isDIGIT(*pos) ) {
+               if ( *pos == '.' )
+                   saw_period++ ;
+               pos++;
+           }
+
+           /* is definitely a v-string */
+           if ( saw_period == 2 ) {    
+               Safefree(version);
+               version = nver;
+           }
+       }
+#  endif
+#endif
     }
     }
-    (void)scan_version(version, ver, qv);
+
+    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);
     Safefree(version);
     return ver;
 }
     Safefree(version);
     return ver;
 }
@@ -4280,7 +4457,7 @@ Perl_vverify(pTHX_ SV *vs)
     /* see if the appropriate elements exist */
     if ( SvTYPE(vs) == SVt_PVHV
         && hv_exists((HV*)vs, "version", 7)
     /* see if the appropriate elements exist */
     if ( SvTYPE(vs) == SVt_PVHV
         && hv_exists((HV*)vs, "version", 7)
-        && (sv = SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)))
+        && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE)))
         && SvTYPE(sv) == SVt_PVAV )
        return TRUE;
     else
         && SvTYPE(sv) == SVt_PVAV )
        return TRUE;
     else
@@ -4319,13 +4496,13 @@ Perl_vnumify(pTHX_ SV *vs)
     if ( hv_exists((HV*)vs, "alpha", 5 ) )
        alpha = TRUE;
     if ( hv_exists((HV*)vs, "width", 5 ) )
     if ( hv_exists((HV*)vs, "alpha", 5 ) )
        alpha = TRUE;
     if ( hv_exists((HV*)vs, "width", 5 ) )
-       width = SvIV(*hv_fetch((HV*)vs, "width", 5, FALSE));
+       width = SvIV(*hv_fetchs((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_fetch((HV*)vs, "version", 7, FALSE)) ) ) {
+    if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) {
        sv_catpvs(sv,"0");
        return sv;
     }
        sv_catpvs(sv,"0");
        return sv;
     }
@@ -4395,7 +4572,7 @@ Perl_vnormal(pTHX_ SV *vs)
 
     if ( hv_exists((HV*)vs, "alpha", 5 ) )
        alpha = TRUE;
 
     if ( hv_exists((HV*)vs, "alpha", 5 ) )
        alpha = TRUE;
-    av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE));
+    av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE));
 
     len = av_len(av);
     if ( len == -1 )
 
     len = av_len(av);
     if ( len == -1 )
@@ -4483,12 +4660,12 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
        Perl_croak(aTHX_ "Invalid version object");
 
     /* get the left hand term */
        Perl_croak(aTHX_ "Invalid version object");
 
     /* get the left hand term */
-    lav = (AV *)SvRV(*hv_fetch((HV*)lhv, "version", 7, FALSE));
+    lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE));
     if ( hv_exists((HV*)lhv, "alpha", 5 ) )
        lalpha = TRUE;
 
     /* and the right hand term */
     if ( hv_exists((HV*)lhv, "alpha", 5 ) )
        lalpha = TRUE;
 
     /* and the right hand term */
-    rav = (AV *)SvRV(*hv_fetch((HV*)rhv, "version", 7, FALSE));
+    rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE));
     if ( hv_exists((HV*)rhv, "alpha", 5 ) )
        ralpha = TRUE;
 
     if ( hv_exists((HV*)rhv, "alpha", 5 ) )
        ralpha = TRUE;
 
@@ -4624,8 +4801,8 @@ S_socketpair_udp (int fd[2]) {
        fd_set rset;
 
        FD_ZERO(&rset);
        fd_set rset;
 
        FD_ZERO(&rset);
-       FD_SET(sockets[0], &rset);
-       FD_SET(sockets[1], &rset);
+       FD_SET((unsigned int)sockets[0], &rset);
+       FD_SET((unsigned int)sockets[1], &rset);
 
        got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
        if (got != 2 || !FD_ISSET(sockets[0], &rset)
 
        got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
        if (got != 2 || !FD_ISSET(sockets[0], &rset)
@@ -4822,6 +4999,7 @@ potentially warn under some level of strict-ness.
 void
 Perl_sv_nosharing(pTHX_ SV *sv)
 {
 void
 Perl_sv_nosharing(pTHX_ SV *sv)
 {
+    PERL_UNUSED_CONTEXT;
     PERL_UNUSED_ARG(sv);
 }
 
     PERL_UNUSED_ARG(sv);
 }
 
@@ -4834,7 +5012,8 @@ Perl_parse_unicode_opts(pTHX_ const char **popt)
   if (*p) {
        if (isDIGIT(*p)) {
            opt = (U32) atoi(p);
   if (*p) {
        if (isDIGIT(*p)) {
            opt = (U32) atoi(p);
-           while (isDIGIT(*p)) p++;
+           while (isDIGIT(*p))
+               p++;
            if (*p && *p != '\n' && *p != '\r')
                 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
        }
            if (*p && *p != '\n' && *p != '\r')
                 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
        }
@@ -4859,6 +5038,8 @@ Perl_parse_unicode_opts(pTHX_ const char **popt)
                      opt |= PERL_UNICODE_LOCALE_FLAG;  break;
                 case PERL_UNICODE_ARGV:
                      opt |= PERL_UNICODE_ARGV_FLAG;    break;
                      opt |= PERL_UNICODE_LOCALE_FLAG;  break;
                 case PERL_UNICODE_ARGV:
                      opt |= PERL_UNICODE_ARGV_FLAG;    break;
+                case PERL_UNICODE_UTF8CACHEASSERT:
+                     opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
                 default:
                      if (*p != '\n' && *p != '\r')
                          Perl_croak(aTHX_
                 default:
                      if (*p != '\n' && *p != '\r')
                          Perl_croak(aTHX_
@@ -4969,7 +5150,8 @@ Perl_get_hash_seed(pTHX)
      UV myseed = 0;
 
      if (s)
      UV myseed = 0;
 
      if (s)
-         while (isSPACE(*s)) s++;
+       while (isSPACE(*s))
+           s++;
      if (s && isDIGIT(*s))
          myseed = (UV)Atoul(s);
      else
      if (s && isDIGIT(*s))
          myseed = (UV)Atoul(s);
      else
@@ -5005,6 +5187,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);
 {
     const char * const stashpv = CopSTASHPV(c);
     const char * const name = HvNAME_get(hv);
+    PERL_UNUSED_CONTEXT;
 
     if (stashpv == name)
        return TRUE;
 
     if (stashpv == name)
        return TRUE;
@@ -5018,13 +5201,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
@@ -5052,10 +5236,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); 
@@ -5064,8 +5252,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;
 }
 
@@ -5076,36 +5264,94 @@ 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
+# 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.
+ *
+ * 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.)
+ */
+
+/*
+ * PERL_MEM_LOG_SPRINTF_BUF_SIZE: size of a (stack-allocated) buffer
+ * the Perl_mem_log_...() will use (either via sprintf or snprintf).
+ */
 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
 
 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
 
+/*
+ * 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.
+ */
+#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
 Malloc_t
 Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
 {
 #ifdef PERL_MEM_LOG_STDERR
-    /* We can't use PerlIO for obvious reasons. */
-    char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
-    const STRLEN len = my_sprintf(buf,
-                                 "alloc: %s:%d:%s: %"IVdf" %"UVuf
-                                 " %s = %"IVdf": %"UVxf"\n",
-                                 filename, linenumber, funcname, n, typesize,
-                                 typename, n * typesize, PTR2UV(newalloc));
-    PerlLIO_write(2,  buf, len);
+# 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)
+# 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;
+#   ifdef HAS_GETTIMEOFDAY
+       gettimeofday(&tv, 0);
+#   endif
+       /* If there are other OS specific ways of hires time than
+        * gettimeofday() (see ext/Time/HiRes), the easiest way is
+        * probably that they would be used to fill in the struct
+        * timeval. */
+# 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
+       }
+    }
 #endif
     return newalloc;
 }
 #endif
     return newalloc;
 }
@@ -5114,14 +5360,44 @@ 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
 Perl_mem_log_realloc(const UV n, const UV typesize, const char *typename, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
 {
 #ifdef PERL_MEM_LOG_STDERR
-    /* We can't use PerlIO for obvious reasons. */
-    char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
-    const STRLEN len = my_sprintf(buf, "realloc: %s:%d:%s: %"IVdf" %"UVuf
-                                 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
-                                 filename, linenumber, funcname, n, typesize,
-                                 typename, n * typesize, PTR2UV(oldalloc),
-                                 PTR2UV(newalloc));
-    PerlLIO_write(2,  buf, len);
+# 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
     return newalloc;
 }
 #endif
     return newalloc;
 }
@@ -5130,12 +5406,42 @@ Malloc_t
 Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
 {
 #ifdef PERL_MEM_LOG_STDERR
 Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
 {
 #ifdef PERL_MEM_LOG_STDERR
-    /* We can't use PerlIO for obvious reasons. */
-    char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
-    const STRLEN len = my_sprintf(buf, "free: %s:%d:%s: %"UVxf"\n",
-                                 filename, linenumber, funcname,
-                                 PTR2UV(oldalloc));
-    PerlLIO_write(2,  buf, len);
+# 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
     return oldalloc;
 }
 #endif
     return oldalloc;
 }
@@ -5163,6 +5469,74 @@ Perl_my_sprintf(char *buffer, const char* pat, ...)
 }
 #endif
 
 }
 #endif
 
+/*
+=for apidoc my_snprintf
+
+The C library C<snprintf> functionality, if available and
+standards-compliant (uses C<vsnprintf>, actually).  However, if the
+C<vsnprintf> is not available, will unfortunately use the unsafe
+C<vsprintf> which can overrun the buffer (there is an overrun check,
+but that may be too late).  Consider using C<sv_vcatpvf> instead, or
+getting C<vsnprintf>.
+
+=cut
+*/
+int
+Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
+{
+    dTHX;
+    int retval;
+    va_list ap;
+    va_start(ap, format);
+#ifdef HAS_VSNPRINTF
+    retval = vsnprintf(buffer, len, format, ap);
+#else
+    retval = vsprintf(buffer, format, ap);
+#endif
+    va_end(ap);
+    /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
+    if (retval < 0 || (len > 0 && (Size_t)retval >= len))
+       Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
+    return retval;
+}
+
+/*
+=for apidoc my_vsnprintf
+
+The C library C<vsnprintf> if available and standards-compliant.
+However, if if the C<vsnprintf> is not available, will unfortunately
+use the unsafe C<vsprintf> which can overrun the buffer (there is an
+overrun check, but that may be too late).  Consider using
+C<sv_vcatpvf> instead, or getting C<vsnprintf>.
+
+=cut
+*/
+int
+Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
+{
+    dTHX;
+    int retval;
+#ifdef NEED_VA_COPY
+    va_list apc;
+    Perl_va_copy(ap, apc);
+# ifdef HAS_VSNPRINTF
+    retval = vsnprintf(buffer, len, format, apc);
+# else
+    retval = vsprintf(buffer, format, apc);
+# endif
+#else
+# ifdef HAS_VSNPRINTF
+    retval = vsnprintf(buffer, len, format, ap);
+# else
+    retval = vsprintf(buffer, format, ap);
+# endif
+#endif /* #ifdef NEED_VA_COPY */
+    /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
+    if (retval < 0 || (len > 0 && (Size_t)retval >= len))
+       Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
+    return retval;
+}
+
 void
 Perl_my_clearenv(pTHX)
 {
 void
 Perl_my_clearenv(pTHX)
 {
@@ -5192,17 +5566,17 @@ Perl_my_clearenv(pTHX)
     (void)clearenv();
 #        elif defined(HAS_UNSETENV)
     int bsiz = 80; /* Most envvar names will be shorter than this. */
     (void)clearenv();
 #        elif defined(HAS_UNSETENV)
     int bsiz = 80; /* Most envvar names will be shorter than this. */
-    char *buf = (char*)safesysmalloc(bsiz * sizeof(char));
+    int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
+    char *buf = (char*)safesysmalloc(bufsiz);
     while (*environ != NULL) {
       char *e = strchr(*environ, '=');
     while (*environ != NULL) {
       char *e = strchr(*environ, '=');
-      int l = e ? e - *environ : strlen(*environ);
+      int l = e ? e - *environ : (int)strlen(*environ);
       if (bsiz < l + 1) {
         (void)safesysfree(buf);
       if (bsiz < l + 1) {
         (void)safesysfree(buf);
-        bsiz = l + 1;
-        buf = (char*)safesysmalloc(bsiz * sizeof(char));
+        bsiz = l + 1; /* + 1 for the \0. */
+        buf = (char*)safesysmalloc(bufsiz);
       } 
       } 
-      strncpy(buf, *environ, l);
-      *(buf + l) = '\0';
+      my_strlcpy(buf, *environ, l + 1);
       (void)unsetenv(buf);
     }
     (void)safesysfree(buf);
       (void)unsetenv(buf);
     }
     (void)safesysfree(buf);
@@ -5219,13 +5593,14 @@ 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)
 {
 void *
 Perl_my_cxt_init(pTHX_ int *index, size_t size)
 {
@@ -5256,8 +5631,146 @@ 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;
+
+    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;
+
+    index = Perl_my_cxt_index(aTHX_ my_cxt_key);
+    if (index == -1) {
+       /* this module hasn't been allocated an index yet */
+       MUTEX_LOCK(&PL_my_ctx_mutex);
+       index = PL_my_cxt_index++;
+       MUTEX_UNLOCK(&PL_my_ctx_mutex);
+    }
+
+    /* make sure the array is big enough */
+    if (PL_my_cxt_size <= index) {
+       int old_size = PL_my_cxt_size;
+       int i;
+       if (PL_my_cxt_size) {
+           while (PL_my_cxt_size <= index)
+               PL_my_cxt_size *= 2;
+           Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
+           Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
+       }
+       else {
+           PL_my_cxt_size = 16;
+           Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
+           Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
+       }
+       for (i = old_size; i < PL_my_cxt_size; i++) {
+           PL_my_cxt_keys[i] = 0;
+           PL_my_cxt_list[i] = 0;
+       }
+    }
+    PL_my_cxt_keys[index] = my_cxt_key;
+    /* newSV() allocates one more than needed */
+    p = (void*)SvPVX(newSV(size-1));
+    PL_my_cxt_list[index] = p;
+    Zero(p, size, char);
+    return p;
+}
+#endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
+#endif /* PERL_IMPLICIT_CONTEXT */
+
+#ifndef HAS_STRLCAT
+Size_t
+Perl_my_strlcat(char *dst, const char *src, Size_t size)
+{
+    Size_t used, length, copy;
+
+    used = strlen(dst);
+    length = strlen(src);
+    if (size > 0 && used < size - 1) {
+        copy = (length >= size - used) ? size - used - 1 : length;
+        memcpy(dst + used, src, copy);
+        dst[used + copy] = '\0';
+    }
+    return used + length;
+}
 #endif
 
 #endif
 
+#ifndef HAS_STRLCPY
+Size_t
+Perl_my_strlcpy(char *dst, const char *src, Size_t size)
+{
+    Size_t length, copy;
+
+    length = strlen(src);
+    if (size > 0) {
+        copy = (length >= size) ? size - 1 : length;
+        memcpy(dst, src, copy);
+        dst[copy] = '\0';
+    }
+    return length;
+}
+#endif
+
+#if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
+/* VC7 or 7.1, building with pre-VC7 runtime libraries. */
+long _ftol( double ); /* Defined by VC6 C libs. */
+long _ftol2( double dblSource ) { return _ftol( dblSource ); }
+#endif
+
+void
+Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
+{
+    dVAR;
+    SV * const dbsv = GvSVn(PL_DBsub);
+    /* We do not care about using sv to call CV;
+     * it's for informational purposes only.
+     */
+
+    save_item(dbsv);
+    if (!PERLDB_SUB_NN) {
+       GV * const gv = CvGV(cv);
+
+       if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
+            || strEQ(GvNAME(gv), "END")
+            || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
+                !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) )))) {
+           /* Use GV from the stack as a fallback. */
+           /* GV is potentially non-unique, or contain different CV. */
+           SV * const tmp = newRV((SV*)cv);
+           sv_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  */
+    }
+}
+
 /*
  * Local variables:
  * c-indentation-style: bsd
 /*
  * Local variables:
  * c-indentation-style: bsd
Unnamed repository; edit this file 'description' to name the repository.