regex: Remove FOLDCHAR regnode type

[perl5.git] / util.c

diff --git a/util.c b/util.c
index f1d7d50..bb220e3 100644 (file)
--- a/util.c
+++ b/util.c
@@ -12,7 +12,7 @@
  * 'Very useful, no doubt, that was to Saruman; yet it seems that he was
  *  not content.'                                    --Gandalf to Pippin
  *
  * 'Very useful, no doubt, that was to Saruman; yet it seems that he was
  *  not content.'                                    --Gandalf to Pippin
  *

- *     [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"]
+ *     [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"]

  */
 
 /* This file contains assorted utility routines.
  */
 
 /* This file contains assorted utility routines.


@@ -25,6 +25,10 @@
 #define PERL_IN_UTIL_C
 #include "perl.h"
 
 #define PERL_IN_UTIL_C
 #include "perl.h"
 

+#ifdef USE_PERLIO
+#include "perliol.h" /* For PerlIOUnix_refcnt */
+#endif
+

 #ifndef PERL_MICRO
 #include <signal.h>
 #ifndef SIG_ERR
 #ifndef PERL_MICRO
 #include <signal.h>
 #ifndef SIG_ERR


@@ -37,10 +41,6 @@
 int putenv(char *);
 #endif
 
 int putenv(char *);
 #endif
 

-#ifdef I_SYS_WAIT
-#  include <sys/wait.h>
-#endif
-

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


@@ -70,12 +70,18 @@ S_write_no_mem(pTHX)
     NORETURN_FUNCTION_END;
 }
 
     NORETURN_FUNCTION_END;
 }
 

+#if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
+#  define ALWAYS_NEED_THX
+#endif
+

 /* paranoid version of system's malloc() */
 
 Malloc_t
 Perl_safesysmalloc(MEM_SIZE size)
 {
 /* paranoid version of system's malloc() */
 
 Malloc_t
 Perl_safesysmalloc(MEM_SIZE size)
 {

+#ifdef ALWAYS_NEED_THX

     dTHX;
     dTHX;

+#endif

     Malloc_t ptr;
 #ifdef HAS_64K_LIMIT
        if (size > 0xffff) {
     Malloc_t ptr;
 #ifdef HAS_64K_LIMIT
        if (size > 0xffff) {


@@ -88,12 +94,11 @@ Perl_safesysmalloc(MEM_SIZE size)
     size += sTHX;
 #endif
 #ifdef DEBUGGING
     size += sTHX;
 #endif
 #ifdef DEBUGGING

-    if ((long)size < 0)
-       Perl_croak_nocontext("panic: malloc");
+    if ((SSize_t)size < 0)
+       Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);

 #endif
     ptr = (Malloc_t)PerlMem_malloc(size?size:1);       /* malloc(0) is NASTY on our system */
     PERL_ALLOC_CHECK(ptr);
 #endif
     ptr = (Malloc_t)PerlMem_malloc(size?size:1);       /* malloc(0) is NASTY on our system */
     PERL_ALLOC_CHECK(ptr);

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

     if (ptr != NULL) {
 #ifdef PERL_TRACK_MEMPOOL
        struct perl_memory_debug_header *const header
     if (ptr != NULL) {
 #ifdef PERL_TRACK_MEMPOOL
        struct perl_memory_debug_header *const header


@@ -116,12 +121,18 @@ Perl_safesysmalloc(MEM_SIZE size)
 #  endif
         ptr = (Malloc_t)((char*)ptr+sTHX);
 #endif
 #  endif
         ptr = (Malloc_t)((char*)ptr+sTHX);
 #endif

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

        return ptr;
 }
        return ptr;
 }

-    else if (PL_nomemok)
-       return NULL;

     else {
     else {

-       return write_no_mem();
+#ifndef ALWAYS_NEED_THX
+       dTHX;
+#endif
+       if (PL_nomemok)
+           return NULL;
+       else {
+           return write_no_mem();
+       }

     }
     /*NOTREACHED*/
 }
     }
     /*NOTREACHED*/
 }


@@ -131,7 +142,9 @@ Perl_safesysmalloc(MEM_SIZE size)
 Malloc_t
 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 {
 Malloc_t
 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 {

+#ifdef ALWAYS_NEED_THX

     dTHX;
     dTHX;

+#endif

     Malloc_t ptr;
 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
     Malloc_t PerlMem_realloc();
     Malloc_t ptr;
 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
     Malloc_t PerlMem_realloc();


@@ -159,7 +172,8 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
            = (struct perl_memory_debug_header *)where;
 
        if (header->interpreter != aTHX) {
            = (struct perl_memory_debug_header *)where;
 
        if (header->interpreter != aTHX) {

-           Perl_croak_nocontext("panic: realloc from wrong pool");
+           Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
+                                header->interpreter, aTHX);

        }
        assert(header->next->prev == header);
        assert(header->prev->next == header);
        }
        assert(header->next->prev == header);
        assert(header->prev->next == header);


@@ -174,8 +188,8 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
     }
 #endif
 #ifdef DEBUGGING
     }
 #endif
 #ifdef DEBUGGING

-    if ((long)size < 0)
-       Perl_croak_nocontext("panic: realloc");
+    if ((SSize_t)size < 0)
+       Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);

 #endif
     ptr = (Malloc_t)PerlMem_realloc(where,size);
     PERL_ALLOC_CHECK(ptr);
 #endif
     ptr = (Malloc_t)PerlMem_realloc(where,size);
     PERL_ALLOC_CHECK(ptr);


@@ -213,10 +227,15 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
     if (ptr != NULL) {
        return ptr;
     }
     if (ptr != NULL) {
        return ptr;
     }

-    else if (PL_nomemok)
-       return NULL;

     else {
     else {

-       return write_no_mem();
+#ifndef ALWAYS_NEED_THX
+       dTHX;
+#endif
+       if (PL_nomemok)
+           return NULL;
+       else {
+           return write_no_mem();
+       }

     }
     /*NOTREACHED*/
 }
     }
     /*NOTREACHED*/
 }


@@ -226,7 +245,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 Free_t
 Perl_safesysfree(Malloc_t where)
 {
 Free_t
 Perl_safesysfree(Malloc_t where)
 {

-#if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL)
+#ifdef ALWAYS_NEED_THX

     dTHX;
 #else
     dVAR;
     dTHX;
 #else
     dVAR;


@@ -240,14 +259,19 @@ Perl_safesysfree(Malloc_t where)
                = (struct perl_memory_debug_header *)where;
 
            if (header->interpreter != aTHX) {
                = (struct perl_memory_debug_header *)where;
 
            if (header->interpreter != aTHX) {

-               Perl_croak_nocontext("panic: free from wrong pool");
+               Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
+                                    header->interpreter, aTHX);

            }
            if (!header->prev) {
                Perl_croak_nocontext("panic: duplicate free");
            }
            }
            if (!header->prev) {
                Perl_croak_nocontext("panic: duplicate free");
            }

-           if (!(header->next) || header->next->prev != header
-               || header->prev->next != header) {
-               Perl_croak_nocontext("panic: bad free");
+           if (!(header->next))
+               Perl_croak_nocontext("panic: bad free, header->next==NULL");
+           if (header->next->prev != header || header->prev->next != header) {
+               Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
+                                    "header=%p, ->prev->next=%p",
+                                    header->next->prev, header,
+                                    header->prev->next);

            }
            /* Unlink us from the chain.  */
            header->next->prev = header->prev;
            }
            /* Unlink us from the chain.  */
            header->next->prev = header->prev;


@@ -268,13 +292,20 @@ Perl_safesysfree(Malloc_t where)
 Malloc_t
 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 {
 Malloc_t
 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 {

+#ifdef ALWAYS_NEED_THX

     dTHX;
     dTHX;

+#endif

     Malloc_t ptr;
     Malloc_t ptr;

+#if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)

     MEM_SIZE total_size = 0;
     MEM_SIZE total_size = 0;

+#endif

 
     /* Even though calloc() for zero bytes is strange, be robust. */
 
     /* Even though calloc() for zero bytes is strange, be robust. */

-    if (size && (count <= MEM_SIZE_MAX / size))
+    if (size && (count <= MEM_SIZE_MAX / size)) {
+#if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)

        total_size = size * count;
        total_size = size * count;

+#endif
+    }

     else
        Perl_croak_nocontext("%s", PL_memory_wrap);
 #ifdef PERL_TRACK_MEMPOOL
     else
        Perl_croak_nocontext("%s", PL_memory_wrap);
 #ifdef PERL_TRACK_MEMPOOL


@@ -291,8 +322,9 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
     }
 #endif /* HAS_64K_LIMIT */
 #ifdef DEBUGGING
     }
 #endif /* HAS_64K_LIMIT */
 #ifdef DEBUGGING

-    if ((long)size < 0 || (long)count < 0)
-       Perl_croak_nocontext("panic: calloc");
+    if ((SSize_t)size < 0 || (SSize_t)count < 0)
+       Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf,
+                            (UV)size, (UV)count);

 #endif
 #ifdef PERL_TRACK_MEMPOOL
     /* Have to use malloc() because we've added some space for our tracking
 #endif
 #ifdef PERL_TRACK_MEMPOOL
     /* Have to use malloc() because we've added some space for our tracking


@@ -330,9 +362,14 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 #endif
        return ptr;
     }
 #endif
        return ptr;
     }

-    else if (PL_nomemok)
-       return NULL;
-    return write_no_mem();
+    else {
+#ifndef ALWAYS_NEED_THX
+       dTHX;
+#endif
+       if (PL_nomemok)
+           return NULL;
+       return write_no_mem();
+    }

 }
 
 /* These must be defined when not using Perl's malloc for binary
 }
 
 /* These must be defined when not using Perl's malloc for binary


@@ -430,7 +467,8 @@ Perl_instr(register const char *big, register const char *little)
     return NULL;
 }
 
     return NULL;
 }
 

-/* same as instr but allow embedded nulls */
+/* same as instr but allow embedded nulls.  The end pointers point to 1 beyond
+ * the final character desired to be checked */

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


@@ -511,13 +549,24 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
 {
     dVAR;
     register const U8 *s;
 {
     dVAR;
     register const U8 *s;

-    register U32 i;
+    STRLEN i;

     STRLEN len;
     STRLEN len;

-    U32 rarest = 0;
+    STRLEN rarest = 0;

     U32 frequency = 256;
     U32 frequency = 256;

+    MAGIC *mg;

 
     PERL_ARGS_ASSERT_FBM_COMPILE;
 
 
     PERL_ARGS_ASSERT_FBM_COMPILE;
 

+    /* Refuse to fbm_compile a studied scalar, as this gives more flexibility in
+       SV flag usage.  No real-world code would ever end up using a studied
+       scalar as a compile-time second argument to index, so this isn't a real
+       pessimisation.  */
+    if (SvSCREAM(sv))
+       return;
+
+    if (SvVALID(sv))
+       return;
+

     if (flags & FBMcf_TAIL) {
        MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
        sv_catpvs(sv, "\n");            /* Taken into account in fbm_instr() */
     if (flags & FBMcf_TAIL) {
        MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
        sv_catpvs(sv, "\n");            /* Taken into account in fbm_instr() */


@@ -527,31 +576,49 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
     s = (U8*)SvPV_force_mutable(sv, len);
     if (len == 0)              /* TAIL might be on a zero-length string. */
        return;
     s = (U8*)SvPV_force_mutable(sv, len);
     if (len == 0)              /* TAIL might be on a zero-length string. */
        return;

-    SvUPGRADE(sv, SVt_PVGV);
+    SvUPGRADE(sv, SVt_PVMG);

     SvIOK_off(sv);
     SvNOK_off(sv);
     SvVALID_on(sv);
     SvIOK_off(sv);
     SvNOK_off(sv);
     SvVALID_on(sv);

+
+    /* "deep magic", the comment used to add. The use of MAGIC itself isn't
+       really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2)
+       to call SvVALID_off() if the scalar was assigned to.
+
+       The comment itself (and "deeper magic" below) date back to
+       378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on
+       str->str_pok |= 2;
+       where the magic (presumably) was that the scalar had a BM table hidden
+       inside itself.
+
+       As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store
+       the table instead of the previous (somewhat hacky) approach of co-opting
+       the string buffer and storing it after the string.  */
+
+    assert(!mg_find(sv, PERL_MAGIC_bm));
+    mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
+    assert(mg);
+

     if (len > 2) {
     if (len > 2) {

-       const unsigned char *sb;
+       /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
+          the BM table.  */

        const U8 mlen = (len>255) ? 255 : (U8)len;
        const U8 mlen = (len>255) ? 255 : (U8)len;

+       const unsigned char *const sb = s + len - mlen; /* first char (maybe) */

        register U8 *table;
 
        register U8 *table;
 

-       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 */
+       Newx(table, 256, U8);

        memset((void*)table, mlen, 256);
        memset((void*)table, mlen, 256);

+       mg->mg_ptr = (char *)table;
+       mg->mg_len = 256;
+
+       s += len - 1; /* last char */

        i = 0;
        i = 0;

-       sb = s - mlen + 1;                      /* first char (maybe) */

        while (s >= sb) {
            if (table[*s] == mlen)
                table[*s] = (U8)i;
            s--, i++;
        }
        while (s >= sb) {
            if (table[*s] == mlen)
                table[*s] = (U8)i;
            s--, i++;
        }

-    } else {
-       Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET);

     }
     }

-    sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0);        /* deep magic */

 
     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++) {


@@ -560,14 +627,13 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
            frequency = PL_freq[s[i]];
        }
     }
            frequency = PL_freq[s[i]];
        }
     }

-    BmFLAGS(sv) = (U8)flags;

     BmRARE(sv) = s[rarest];
     BmPREVIOUS(sv) = rarest;
     BmUSEFUL(sv) = 100;                        /* Initial value */
     if (flags & FBMcf_TAIL)
        SvTAIL_on(sv);
     BmRARE(sv) = s[rarest];
     BmPREVIOUS(sv) = rarest;
     BmUSEFUL(sv) = 100;                        /* Initial value */
     if (flags & FBMcf_TAIL)
        SvTAIL_on(sv);

-    DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n",
-                         BmRARE(sv),(unsigned long)BmPREVIOUS(sv)));
+    DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n",
+                         BmRARE(sv), BmPREVIOUS(sv)));

 }
 
 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
 }
 
 /* If SvTAIL(littlestr), it has a fake '\n' at end. */


@@ -607,9 +673,10 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
        return NULL;
     }
 
        return NULL;
     }
 

-    if (littlelen <= 2) {              /* Special-cased */
-
-       if (littlelen == 1) {
+    switch (littlelen) { /* Special cases for 0, 1 and 2  */
+    case 0:
+       return (char*)big;              /* Cannot be SvTAIL! */
+    case 1:

            if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
                /* Know that bigend != big.  */
                if (bigend[-1] == '\n')
            if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
                /* Know that bigend != big.  */
                if (bigend[-1] == '\n')


@@ -625,11 +692,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
            if (SvTAIL(littlestr))
                return (char *) bigend;
            return NULL;
            if (SvTAIL(littlestr))
                return (char *) bigend;
            return NULL;

-       }
-       if (!littlelen)
-           return (char*)big;          /* Cannot be SvTAIL! */
-
-       /* littlelen is 2 */
+    case 2:

        if (SvTAIL(littlestr) && !multiline) {
            if (bigend[-1] == '\n' && bigend[-2] == *little)
                return (char*)bigend - 2;
        if (SvTAIL(littlestr) && !multiline) {
            if (bigend[-1] == '\n' && bigend[-2] == *little)
                return (char*)bigend - 2;


@@ -689,7 +752,10 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
        if (SvTAIL(littlestr) && (*bigend == *little))
            return (char *)bigend;      /* bigend is already decremented. */
        return NULL;
        if (SvTAIL(littlestr) && (*bigend == *little))
            return (char *)bigend;      /* bigend is already decremented. */
        return NULL;

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

     }
     }

+

     if (SvTAIL(littlestr) && !multiline) {     /* tail anchored? */
        s = bigend - littlelen;
        if (s >= big && bigend[-1] == '\n' && *s == *little
     if (SvTAIL(littlestr) && !multiline) {     /* tail anchored? */
        s = bigend - littlelen;
        if (s >= big && bigend[-1] == '\n' && *s == *little


@@ -727,8 +793,8 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
        return NULL;
 
     {
        return NULL;
 
     {

-       register const unsigned char * const table
-           = little + littlelen + PERL_FBM_TABLE_OFFSET;
+       const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
+       const unsigned char * const table = (const unsigned char *) mg->mg_ptr;

        register const unsigned char *oldlittle;
 
        --littlelen;                    /* Last char found by table lookup */
        register const unsigned char *oldlittle;
 
        --littlelen;                    /* Last char found by table lookup */


@@ -764,7 +830,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
        }
       check_end:
        if ( s == bigend
        }
       check_end:
        if ( s == bigend

-            && (BmFLAGS(littlestr) & FBMcf_TAIL)
+            && SvTAIL(littlestr)

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


@@ -792,22 +858,56 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
 {
     dVAR;
     register const unsigned char *big;
 {
     dVAR;
     register const unsigned char *big;

-    register I32 pos;
+    U32 pos = 0; /* hush a gcc warning */

     register I32 previous;
     register I32 first;
     register const unsigned char *little;
     register I32 stop_pos;
     register const unsigned char *littleend;
     register I32 previous;
     register I32 first;
     register const unsigned char *little;
     register I32 stop_pos;
     register const unsigned char *littleend;

-    I32 found = 0;
+    bool found = FALSE;
+    const MAGIC * mg;
+    const void *screamnext_raw = NULL; /* hush a gcc warning */
+    bool cant_find = FALSE; /* hush a gcc warning */

 
     PERL_ARGS_ASSERT_SCREAMINSTR;
 
 
     PERL_ARGS_ASSERT_SCREAMINSTR;
 

-    assert(SvTYPE(littlestr) == SVt_PVGV);
+    assert(SvMAGICAL(bigstr));
+    mg = mg_find(bigstr, PERL_MAGIC_study);
+    assert(mg);
+    assert(SvTYPE(littlestr) == SVt_PVMG);

     assert(SvVALID(littlestr));
 
     assert(SvVALID(littlestr));
 

-    if (*old_posp == -1
-       ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
-       : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
+    if (mg->mg_private == 1) {
+       const U8 *const screamfirst = (U8 *)mg->mg_ptr;
+       const U8 *const screamnext = screamfirst + 256;
+
+       screamnext_raw = (const void *)screamnext;
+
+       pos = *old_posp == -1
+           ? screamfirst[BmRARE(littlestr)] : screamnext[*old_posp];
+       cant_find = pos == (U8)~0;
+    } else if (mg->mg_private == 2) {
+       const U16 *const screamfirst = (U16 *)mg->mg_ptr;
+       const U16 *const screamnext = screamfirst + 256;
+
+       screamnext_raw = (const void *)screamnext;
+
+       pos = *old_posp == -1
+           ? screamfirst[BmRARE(littlestr)] : screamnext[*old_posp];
+       cant_find = pos == (U16)~0;
+    } else if (mg->mg_private == 4) {
+       const U32 *const screamfirst = (U32 *)mg->mg_ptr;
+       const U32 *const screamnext = screamfirst + 256;
+
+       screamnext_raw = (const void *)screamnext;
+
+       pos = *old_posp == -1
+           ? screamfirst[BmRARE(littlestr)] : screamnext[*old_posp];
+       cant_find = pos == (U32)~0;
+    } else
+       Perl_croak(aTHX_ "panic: unknown study size %u", mg->mg_private);
+
+    if (cant_find) {

       cant_find:
        if ( BmRARE(littlestr) == '\n'
             && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
       cant_find:
        if ( BmRARE(littlestr) == '\n'
             && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {


@@ -838,28 +938,59 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
 #endif
        return NULL;
     }
 #endif
        return NULL;
     }

-    while (pos < previous + start_shift) {
-       if (!(pos += PL_screamnext[pos]))
-           goto cant_find;
+    if (mg->mg_private == 1) {
+       const U8 *const screamnext = (const U8 *const) screamnext_raw;
+       while ((I32)pos < previous + start_shift) {
+           pos = screamnext[pos];
+           if (pos == (U8)~0)
+               goto cant_find;
+       }
+    } else if (mg->mg_private == 2) {
+       const U16 *const screamnext = (const U16 *const) screamnext_raw;
+       while ((I32)pos < previous + start_shift) {
+           pos = screamnext[pos];
+           if (pos == (U16)~0)
+               goto cant_find;
+       }
+    } else if (mg->mg_private == 4) {
+       const U32 *const screamnext = (const U32 *const) screamnext_raw;
+       while ((I32)pos < previous + start_shift) {
+           pos = screamnext[pos];
+           if (pos == (U32)~0)
+               goto cant_find;
+       }

     }
     big -= previous;
     }
     big -= previous;

-    do {
-       register const unsigned char *s, *x;
-       if (pos >= stop_pos) break;
-       if (big[pos] != first)
-           continue;
-       for (x=big+pos+1,s=little; s < littleend; /**/ ) {
-           if (*s++ != *x++) {
-               s--;
-               break;
+    while (1) {
+       if ((I32)pos >= stop_pos) break;
+       if (big[pos] == first) {
+           const unsigned char *s = little;
+           const unsigned char *x = big + pos + 1;
+           while (s < littleend) {
+               if (*s != *x++)
+                   break;
+               ++s;
+           }
+           if (s == littleend) {
+               *old_posp = (I32)pos;
+               if (!last) return (char *)(big+pos);
+               found = TRUE;

            }
        }
            }
        }

-       if (s == littleend) {
-           *old_posp = pos;
-           if (!last) return (char *)(big+pos);
-           found = 1;
+       if (mg->mg_private == 1) {
+           pos = ((const U8 *const)screamnext_raw)[pos];
+           if (pos == (U8)~0)
+               break;
+       } else if (mg->mg_private == 2) {
+           pos = ((const U16 *const)screamnext_raw)[pos];
+           if (pos == (U16)~0)
+               break;
+       } else if (mg->mg_private == 4) {
+           pos = ((const U32 *const)screamnext_raw)[pos];
+           if (pos == (U32)~0)
+               break;

        }
        }

-    } while ( pos += PL_screamnext[pos] );
+    };

     if (last && found)
        return (char *)(big+(*old_posp));
   check_tail:
     if (last && found)
        return (char *)(big+(*old_posp));
   check_tail:


@@ -878,37 +1009,79 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
     return NULL;
 }
 
     return NULL;
 }
 

+/*
+=for apidoc foldEQ
+
+Returns true if the leading len bytes of the strings s1 and s2 are the same
+case-insensitively; false otherwise.  Uppercase and lowercase ASCII range bytes
+match themselves and their opposite case counterparts.  Non-cased and non-ASCII
+range bytes match only themselves.
+
+=cut
+*/
+
+

 I32
 I32

-Perl_ibcmp(const char *s1, const char *s2, register I32 len)
+Perl_foldEQ(const char *s1, const char *s2, register I32 len)

 {
     register const U8 *a = (const U8 *)s1;
     register const U8 *b = (const U8 *)s2;
 
 {
     register const U8 *a = (const U8 *)s1;
     register const U8 *b = (const U8 *)s2;
 

-    PERL_ARGS_ASSERT_IBCMP;
+    PERL_ARGS_ASSERT_FOLDEQ;

 
     while (len--) {
        if (*a != *b && *a != PL_fold[*b])
 
     while (len--) {
        if (*a != *b && *a != PL_fold[*b])

-           return 1;
+           return 0;

        a++,b++;
     }
        a++,b++;
     }

-    return 0;
+    return 1;
+}
+I32
+Perl_foldEQ_latin1(const char *s1, const char *s2, register I32 len)
+{
+    /* Compare non-utf8 using Unicode (Latin1) semantics.  Does not work on
+     * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
+     * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these.  Nor
+     * does it check that the strings each have at least 'len' characters */
+
+    register const U8 *a = (const U8 *)s1;
+    register const U8 *b = (const U8 *)s2;
+
+    PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
+
+    while (len--) {
+       if (*a != *b && *a != PL_fold_latin1[*b]) {
+           return 0;
+       }
+       a++, b++;
+    }
+    return 1;

 }
 
 }
 

+/*
+=for apidoc foldEQ_locale
+
+Returns true if the leading len bytes of the strings s1 and s2 are the same
+case-insensitively in the current locale; false otherwise.
+
+=cut
+*/
+

 I32
 I32

-Perl_ibcmp_locale(const char *s1, const char *s2, register I32 len)
+Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len)

 {
     dVAR;
     register const U8 *a = (const U8 *)s1;
     register const U8 *b = (const U8 *)s2;
 
 {
     dVAR;
     register const U8 *a = (const U8 *)s1;
     register const U8 *b = (const U8 *)s2;
 

-    PERL_ARGS_ASSERT_IBCMP_LOCALE;
+    PERL_ARGS_ASSERT_FOLDEQ_LOCALE;

 
     while (len--) {
        if (*a != *b && *a != PL_fold_locale[*b])
 
     while (len--) {
        if (*a != *b && *a != PL_fold_locale[*b])

-           return 1;
+           return 0;

        a++,b++;
     }
        a++,b++;
     }

-    return 0;
+    return 1;

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


@@ -1041,6 +1214,25 @@ Perl_savesvpv(pTHX_ SV *sv)
     return (char *) CopyD(pv,newaddr,len,char);
 }
 
     return (char *) CopyD(pv,newaddr,len,char);
 }
 

+/*
+=for apidoc savesharedsvpv
+
+A version of C<savesharedpv()> which allocates the duplicate string in
+memory which is shared between threads.
+
+=cut
+*/
+
+char *
+Perl_savesharedsvpv(pTHX_ SV *sv)
+{
+    STRLEN len;
+    const char * const pv = SvPV_const(sv, len);
+
+    PERL_ARGS_ASSERT_SAVESHAREDSVPV;
+
+    return savesharedpvn(pv, len);
+}

 
 /* the SV for Perl_form() and mess() is not kept in an arena */
 
 
 /* the SV for Perl_form() and mess() is not kept in an arena */
 


@@ -1051,7 +1243,7 @@ S_mess_alloc(pTHX)
     SV *sv;
     XPVMG *any;
 
     SV *sv;
     XPVMG *any;
 

-    if (!PL_dirty)
+    if (PL_phase != PERL_PHASE_DESTRUCT)

        return newSVpvs_flags("", SVs_TEMP);
 
     if (PL_mess_sv)
        return newSVpvs_flags("", SVs_TEMP);
 
     if (PL_mess_sv)


@@ -1273,12 +1465,14 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
        {
            const bool line_mode = (RsSIMPLE(PL_rs) &&
                              SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
        {
            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),
+           Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf,
+                          SVfARG(PL_last_in_gv == PL_argvgv
+                                 ? &PL_sv_no
+                                 : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),

                           line_mode ? "line" : "chunk",
                           (IV)IoLINES(GvIOp(PL_last_in_gv)));
        }
                           line_mode ? "line" : "chunk",
                           (IV)IoLINES(GvIOp(PL_last_in_gv)));
        }

-       if (PL_dirty)
+       if (PL_phase == PERL_PHASE_DESTRUCT)

            sv_catpvs(sv, " during global destruction");
        sv_catpvs(sv, ".\n");
     }
            sv_catpvs(sv, " during global destruction");
        sv_catpvs(sv, ".\n");
     }


@@ -1325,38 +1519,16 @@ Perl_write_to_stderr(pTHX_ SV* msv)
     if (PL_stderrgv && SvREFCNT(PL_stderrgv) 
        && (io = GvIO(PL_stderrgv))
        && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) 
     if (PL_stderrgv && SvREFCNT(PL_stderrgv) 
        && (io = GvIO(PL_stderrgv))
        && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) 

-    {
-       dSP;
-       ENTER;
-       SAVETMPS;
-
-       save_re_context();
-       SAVESPTR(PL_stderrgv);
-       PL_stderrgv = NULL;
-
-       PUSHSTACKi(PERLSI_MAGIC);
-
-       PUSHMARK(SP);
-       EXTEND(SP,2);
-       PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
-       PUSHs(msv);
-       PUTBACK;
-       call_method("PRINT", G_SCALAR);
-
-       POPSTACK;
-       FREETMPS;
-       LEAVE;
-    }
+       Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, "PRINT",
+                           G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);

     else {
 #ifdef USE_SFIO
        /* SFIO can really mess with your errno */
        dSAVED_ERRNO;
 #endif
        PerlIO * const serr = Perl_error_log;
     else {
 #ifdef USE_SFIO
        /* SFIO can really mess with your errno */
        dSAVED_ERRNO;
 #endif
        PerlIO * const serr = Perl_error_log;

-       STRLEN msglen;
-       const char* message = SvPVx_const(msv, msglen);

 
 

-       PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
+       do_print(msv, serr);

        (void)PerlIO_flush(serr);
 #ifdef USE_SFIO
        RESTORE_ERRNO;
        (void)PerlIO_flush(serr);
 #ifdef USE_SFIO
        RESTORE_ERRNO;


@@ -1592,6 +1764,22 @@ Perl_croak(pTHX_ const char *pat, ...)
 }
 
 /*
 }
 
 /*

+=for apidoc Am|void|croak_no_modify
+
+Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
+terser object code than using C<Perl_croak>. Less code used on exception code
+paths reduces CPU cache pressure.
+
+=cut
+*/
+
+void
+Perl_croak_no_modify(pTHX)
+{
+    Perl_croak(aTHX_ "%s", PL_no_modify);
+}
+
+/*

 =for apidoc Am|void|warn_sv|SV *baseex
 
 This is an XS interface to Perl's C<warn> function.
 =for apidoc Am|void|warn_sv|SV *baseex
 
 This is an XS interface to Perl's C<warn> function.


@@ -2555,7 +2743,7 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
            int pid2, status;
            PerlLIO_close(p[This]);
            if (n != sizeof(int))
            int pid2, status;
            PerlLIO_close(p[This]);
            if (n != sizeof(int))

-               Perl_croak(aTHX_ "panic: kid popen errno read");
+               Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);

            do {
                pid2 = wait4pid(pid, &status, 0);
            } while (pid2 == -1 && errno == EINTR);
            do {
                pid2 = wait4pid(pid, &status, 0);
            } while (pid2 == -1 && errno == EINTR);


@@ -2624,7 +2812,6 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
        sleep(5);
     }
     if (pid == 0) {
        sleep(5);
     }
     if (pid == 0) {

-       GV* tmpgv;

 
 #undef THIS
 #undef THAT
 
 #undef THIS
 #undef THAT


@@ -2670,12 +2857,6 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
       default, binary, low-level mode; see PerlIOBuf_open(). */
    PerlLIO_setmode((*mode == 'r'), O_BINARY);
 #endif 
       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));
-       }

 #ifdef THREADS_HAVE_PIDS
        PL_ppid = (IV)getppid();
 #endif
 #ifdef THREADS_HAVE_PIDS
        PL_ppid = (IV)getppid();
 #endif


@@ -2721,7 +2902,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
            int pid2, status;
            PerlLIO_close(p[This]);
            if (n != sizeof(int))
            int pid2, status;
            PerlLIO_close(p[This]);
            if (n != sizeof(int))

-               Perl_croak(aTHX_ "panic: kid popen errno read");
+               Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);

            do {
                pid2 = wait4pid(pid, &status, 0);
            } while (pid2 == -1 && errno == EINTR);
            do {
                pid2 = wait4pid(pid, &status, 0);
            } while (pid2 == -1 && errno == EINTR);


@@ -3038,11 +3219,20 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
     int status;
     SV **svp;
     Pid_t pid;
     int status;
     SV **svp;
     Pid_t pid;

-    Pid_t pid2;
+    Pid_t pid2 = 0;

     bool close_failed;
     dSAVEDERRNO;
     bool close_failed;
     dSAVEDERRNO;

+    const int fd = PerlIO_fileno(ptr);

 
 

-    svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
+#ifdef USE_PERLIO
+    /* Find out whether the refcount is low enough for us to wait for the
+       child proc without blocking. */
+    const bool should_wait = PerlIOUnix_refcnt(fd) == 1;
+#else
+    const bool should_wait = 1;
+#endif
+
+    svp = av_fetch(PL_fdpid,fd,TRUE);

     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
     SvREFCNT_dec(*svp);
     *svp = &PL_sv_undef;
     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
     SvREFCNT_dec(*svp);
     *svp = &PL_sv_undef;


@@ -3061,7 +3251,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
     rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &istat);
     rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
 #endif
     rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &istat);
     rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
 #endif

-    do {
+    if (should_wait) do {

        pid2 = wait4pid(pid, &status, 0);
     } while (pid2 == -1 && errno == EINTR);
 #ifndef PERL_MICRO
        pid2 = wait4pid(pid, &status, 0);
     } while (pid2 == -1 && errno == EINTR);
 #ifndef PERL_MICRO


@@ -3073,7 +3263,11 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
        RESTORE_ERRNO;
        return -1;
     }
        RESTORE_ERRNO;
        return -1;
     }

-    return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
+    return(
+      should_wait
+       ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
+       : 0
+    );

 }
 #else
 #if defined(__LIBCATAMOUNT__)
 }
 #else
 #if defined(__LIBCATAMOUNT__)


@@ -3218,7 +3412,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
 
 #define PERL_REPEATCPY_LINEAR 4
 void
 
 #define PERL_REPEATCPY_LINEAR 4
 void

-Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
+Perl_repeatcpy(register char *to, register const char *from, I32 len, register IV count)

 {
     PERL_ARGS_ASSERT_REPEATCPY;
 
 {
     PERL_ARGS_ASSERT_REPEATCPY;
 


@@ -3226,19 +3420,19 @@ Perl_repeatcpy(register char *to, register const char *from, I32 len, register I
        memset(to, *from, count);
     else if (count) {
        register char *p = to;
        memset(to, *from, count);
     else if (count) {
        register char *p = to;

-       I32 items, linear, half;
+       IV items, linear, half;

 
        linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
        for (items = 0; items < linear; ++items) {
            register const char *q = from;
 
        linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
        for (items = 0; items < linear; ++items) {
            register const char *q = from;

-           I32 todo;
+           IV todo;

            for (todo = len; todo > 0; todo--)
                *p++ = *q++;
         }
 
        half = count / 2;
        while (items <= half) {
            for (todo = len; todo > 0; todo--)
                *p++ = *q++;
         }
 
        half = count / 2;
        while (items <= half) {

-           I32 size = items * len;
+           IV size = items * len;

            memcpy(p, to, size);
            p     += size;
            items *= 2;
            memcpy(p, to, size);
            p     += size;
            items *= 2;


@@ -3495,6 +3689,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
            seen_dot = 1;                       /* Disable message. */
        if (!xfound) {
            if (flags & 1) {                    /* do or die? */
            seen_dot = 1;                       /* Disable message. */
        if (!xfound) {
            if (flags & 1) {                    /* do or die? */

+               /* diag_listed_as: Can't execute %s */

                Perl_croak(aTHX_ "Can't %s %s%s%s",
                      (xfailed ? "execute" : "find"),
                      (xfailed ? xfailed : scriptname),
                Perl_croak(aTHX_ "Can't %s %s%s%s",
                      (xfailed ? "execute" : "find"),
                      (xfailed ? xfailed : scriptname),


@@ -3518,8 +3713,9 @@ Perl_get_context(void)
 #if defined(USE_ITHREADS)
 #  ifdef OLD_PTHREADS_API
     pthread_addr_t t;
 #if defined(USE_ITHREADS)
 #  ifdef OLD_PTHREADS_API
     pthread_addr_t t;

-    if (pthread_getspecific(PL_thr_key, &t))
-       Perl_croak_nocontext("panic: pthread_getspecific");
+    int error = pthread_getspecific(PL_thr_key, &t)
+    if (error)
+       Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);

     return (void*)t;
 #  else
 #    ifdef I_MACH_CTHREADS
     return (void*)t;
 #  else
 #    ifdef I_MACH_CTHREADS


@@ -3542,8 +3738,11 @@ Perl_set_context(void *t)
 #  ifdef I_MACH_CTHREADS
     cthread_set_data(cthread_self(), t);
 #  else
 #  ifdef I_MACH_CTHREADS
     cthread_set_data(cthread_self(), t);
 #  else

-    if (pthread_setspecific(PL_thr_key, t))
-       Perl_croak_nocontext("panic: pthread_setspecific");
+    {
+       const int error = pthread_setspecific(PL_thr_key, t);
+       if (error)
+           Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
+    }

 #  endif
 #else
     PERL_UNUSED_ARG(t);
 #  endif
 #else
     PERL_UNUSED_ARG(t);


@@ -3613,104 +3812,10 @@ Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
 MGVTBL*
 Perl_get_vtbl(pTHX_ int vtbl_id)
 {
 MGVTBL*
 Perl_get_vtbl(pTHX_ int vtbl_id)
 {

-    const MGVTBL* result;

     PERL_UNUSED_CONTEXT;
 
     PERL_UNUSED_CONTEXT;
 

-    switch(vtbl_id) {
-    case want_vtbl_sv:
-       result = &PL_vtbl_sv;
-       break;
-    case want_vtbl_env:
-       result = &PL_vtbl_env;
-       break;
-    case want_vtbl_envelem:
-       result = &PL_vtbl_envelem;
-       break;
-    case want_vtbl_sig:
-       result = &PL_vtbl_sig;
-       break;
-    case want_vtbl_sigelem:
-       result = &PL_vtbl_sigelem;
-       break;
-    case want_vtbl_pack:
-       result = &PL_vtbl_pack;
-       break;
-    case want_vtbl_packelem:
-       result = &PL_vtbl_packelem;
-       break;
-    case want_vtbl_dbline:
-       result = &PL_vtbl_dbline;
-       break;
-    case want_vtbl_isa:
-       result = &PL_vtbl_isa;
-       break;
-    case want_vtbl_isaelem:
-       result = &PL_vtbl_isaelem;
-       break;
-    case want_vtbl_arylen:
-       result = &PL_vtbl_arylen;
-       break;
-    case want_vtbl_mglob:
-       result = &PL_vtbl_mglob;
-       break;
-    case want_vtbl_nkeys:
-       result = &PL_vtbl_nkeys;
-       break;
-    case want_vtbl_taint:
-       result = &PL_vtbl_taint;
-       break;
-    case want_vtbl_substr:
-       result = &PL_vtbl_substr;
-       break;
-    case want_vtbl_vec:
-       result = &PL_vtbl_vec;
-       break;
-    case want_vtbl_pos:
-       result = &PL_vtbl_pos;
-       break;
-    case want_vtbl_bm:
-       result = &PL_vtbl_bm;
-       break;
-    case want_vtbl_fm:
-       result = &PL_vtbl_fm;
-       break;
-    case want_vtbl_uvar:
-       result = &PL_vtbl_uvar;
-       break;
-    case want_vtbl_defelem:
-       result = &PL_vtbl_defelem;
-       break;
-    case want_vtbl_regexp:
-       result = &PL_vtbl_regexp;
-       break;
-    case want_vtbl_regdata:
-       result = &PL_vtbl_regdata;
-       break;
-    case want_vtbl_regdatum:
-       result = &PL_vtbl_regdatum;
-       break;
-#ifdef USE_LOCALE_COLLATE
-    case want_vtbl_collxfrm:
-       result = &PL_vtbl_collxfrm;
-       break;
-#endif
-    case want_vtbl_amagic:
-       result = &PL_vtbl_amagic;
-       break;
-    case want_vtbl_amagicelem:
-       result = &PL_vtbl_amagicelem;
-       break;
-    case want_vtbl_backref:
-       result = &PL_vtbl_backref;
-       break;
-    case want_vtbl_utf8:
-       result = &PL_vtbl_utf8;
-       break;
-    default:
-       result = NULL;
-       break;
-    }
-    return (MGVTBL*)result;
+    return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
+       ? NULL : PL_magic_vtables + vtbl_id;

 }
 
 I32
 }
 
 I32


@@ -3764,105 +3869,70 @@ Perl_my_fflush_all(pTHX)
 }
 
 void
 }
 
 void

-Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
-{
-    const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
-
-    if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
-       if (ckWARN(WARN_IO)) {
-           const char * const direction =
-               (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
-           if (name && *name)
-               Perl_warner(aTHX_ packWARN(WARN_IO),
-                           "Filehandle %s opened only for %sput",
-                           name, direction);
-           else
-               Perl_warner(aTHX_ packWARN(WARN_IO),
-                           "Filehandle opened only for %sput", direction);
-       }
-    }
-    else {
-        const char *vile;
-       I32   warn_type;
-
-       if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
-           vile = "closed";
-           warn_type = WARN_CLOSED;
-       }
-       else {
-           vile = "unopened";
-           warn_type = WARN_UNOPENED;
-       }
-
-       if (ckWARN(warn_type)) {
-           const char * const pars =
-               (const char *)(OP_IS_FILETEST(op) ? "" : "()");
-           const char * const func =
-               (const char *)
-               (op == OP_READLINE   ? "readline"  :    /* "<HANDLE>" not nice */
-                op == OP_LEAVEWRITE ? "write" :                /* "write exit" not nice */
-                op < 0              ? "" :              /* handle phoney cases */
-                PL_op_desc[op]);
-           const char * const type =
-               (const char *)
-               (OP_IS_SOCKET(op) ||
-                (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
-                "socket" : "filehandle");
-           if (name && *name) {
-               Perl_warner(aTHX_ packWARN(warn_type),
-                           "%s%s on %s %s %s", func, pars, vile, type, name);
-               if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
-                   Perl_warner(
-                       aTHX_ packWARN(warn_type),
-                       "\t(Are you trying to call %s%s on dirhandle %s?)\n",
-                       func, pars, name
-                   );
-           }
-           else {
-               Perl_warner(aTHX_ packWARN(warn_type),
-                           "%s%s on %s %s", func, pars, vile, type);
-               if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
-                   Perl_warner(
-                       aTHX_ packWARN(warn_type),
-                       "\t(Are you trying to call %s%s on dirhandle?)\n",
-                       func, pars
-                   );
-           }
-       }
+Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
+{
+    if (ckWARN(WARN_IO)) {
+        SV * const name
+           = gv && (isGV(gv) || isGV_with_GP(gv))
+                ? sv_2mortal(newSVhek(GvENAME_HEK((gv))))
+                : NULL;
+       const char * const direction = have == '>' ? "out" : "in";
+
+       if (name && SvPOK(name) && *SvPV_nolen(name))
+           Perl_warner(aTHX_ packWARN(WARN_IO),
+                       "Filehandle %"SVf" opened only for %sput",
+                       name, direction);
+       else
+           Perl_warner(aTHX_ packWARN(WARN_IO),
+                       "Filehandle opened only for %sput", direction);

     }
 }
 
     }
 }
 

-/* XXX Add documentation after final interface and behavior is decided */
-/* May want to show context for error, so would pass Perl_bslash_c(pTHX_ const char* current, const char* start, const bool output_warning)
-    U8 source = *current;
-
-    May want to add eg, WARN_REGEX
-*/
-
-char
-Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning)
+void
+Perl_report_evil_fh(pTHX_ const GV *gv)

 {
 {

-    
-    U8 result;
+    const IO *io = gv ? GvIO(gv) : NULL;
+    const PERL_BITFIELD16 op = PL_op->op_type;
+    const char *vile;
+    I32 warn_type;

 
 

-    if (! isASCII(source)) {
-       Perl_croak(aTHX_ "Character following \"\\c\" must be ASCII");
+    if (io && IoTYPE(io) == IoTYPE_CLOSED) {
+       vile = "closed";
+       warn_type = WARN_CLOSED;

     }
     }

-
-    result = toCTRL(source);
-    if (! isCNTRL(result)) {
-       if (source == '{') {
-           Perl_croak(aTHX_ "It is proposed that \"\\c{\" no longer be valid. It has historically evaluated to\n \";\".  If you disagree with this proposal, send email to perl5-porters@perl.org\nOtherwise, or in the meantime, you can work around this failure by changing\n\"\\c{\" to \";\"");
-       }
-       else if (output_warning) {
-           Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
-                           "\"\\c%c\" more clearly written simply as \"%c\"",
-                           source,
-                           result);
-       }
+    else {
+       vile = "unopened";
+       warn_type = WARN_UNOPENED;
+    }
+
+    if (ckWARN(warn_type)) {
+        SV * const name
+            = gv && (isGV(gv) || isGV_with_GP(gv)) && GvENAMELEN(gv) ?
+                                     sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
+       const char * const pars =
+           (const char *)(OP_IS_FILETEST(op) ? "" : "()");
+       const char * const func =
+           (const char *)
+           (op == OP_READLINE   ? "readline"  :        /* "<HANDLE>" not nice */
+            op == OP_LEAVEWRITE ? "write" :            /* "write exit" not nice */
+            PL_op_desc[op]);
+       const char * const type =
+           (const char *)
+           (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
+            ? "socket" : "filehandle");
+       const bool have_name = name && SvPOK(name) && *SvPV_nolen(name);
+       Perl_warner(aTHX_ packWARN(warn_type),
+                  "%s%s on %s %s%s%"SVf, func, pars, vile, type,
+                   have_name ? " " : "",
+                   SVfARG(have_name ? name : &PL_sv_no));
+       if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+               Perl_warner(
+                           aTHX_ packWARN(warn_type),
+                       "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
+                       func, pars, have_name ? " " : "",
+                       SVfARG(have_name ? name : &PL_sv_no)
+                           );

     }
     }

-
-    return result;

 }
 
 /* To workaround core dumps from the uninitialised tm_zone we get the
 }
 
 /* To workaround core dumps from the uninitialised tm_zone we get the


@@ -3985,7 +4055,7 @@ Perl_mini_mktime(pTHX_ struct tm *ptm)
  * outside the scope for this routine.  Since we convert back based on the
  * same rules we used to build the yearday, you'll only get strange results
  * for input which needed normalising, or for the 'odd' century years which
  * outside the scope for this routine.  Since we convert back based on the
  * same rules we used to build the yearday, you'll only get strange results
  * for input which needed normalising, or for the 'odd' century years which

- * were leap years in the Julian calander but not in the Gregorian one.
+ * were leap years in the Julian calendar but not in the Gregorian one.

  * I can live with that.
  *
  * This algorithm also fails to handle years before A.D. 1 gracefully, but
  * I can live with that.
  *
  * This algorithm also fails to handle years before A.D. 1 gracefully, but


@@ -4164,7 +4234,7 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in
     const int fmtlen = strlen(fmt);
     int bufsize = fmtlen + buflen;
 
     const int fmtlen = strlen(fmt);
     int bufsize = fmtlen + buflen;
 

-    Newx(buf, bufsize, char);
+    Renew(buf, bufsize, char);

     while (buf) {
       buflen = strftime(buf, bufsize, fmt, &mytm);
       if (buflen > 0 && buflen < bufsize)
     while (buf) {
       buflen = strftime(buf, bufsize, fmt, &mytm);
       if (buflen > 0 && buflen < bufsize)


@@ -4367,6 +4437,11 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 /*
 =for apidoc prescan_version
 
 /*
 =for apidoc prescan_version
 

+Validate that a given string can be parsed as a version object, but doesn't
+actually perform the parsing.  Can use either strict or lax validation rules.
+Can optionally set a number of hint variables to save the parsing code
+some time when tokenizing.
+

 =cut
 */
 const char *
 =cut
 */
 const char *


@@ -4472,6 +4547,11 @@ dotted_decimal_version:
            }
        }
 
            }
        }
 

+       /* and we never support negative versions */
+       if ( *d == '-') {
+               BADVERSION(s,errstr,"Invalid version format (negative version number)");                
+       }
+

        /* consume all of the integer part */
        while (isDIGIT(*d))
            d++;
        /* consume all of the integer part */
        while (isDIGIT(*d))
            d++;


@@ -4482,7 +4562,7 @@ dotted_decimal_version:
            saw_decimal++;
            d++;
        }
            saw_decimal++;
            d++;
        }

-       else if (!*d || *d == ';' || isSPACE(*d) || *d == '}') {
+       else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {

            if ( d == s ) {
                /* found nothing */
                BADVERSION(s,errstr,"Invalid version format (version required)");
            if ( d == s ) {
                /* found nothing */
                BADVERSION(s,errstr,"Invalid version format (version required)");


@@ -4513,7 +4593,7 @@ dotted_decimal_version:
 
        /* scan the fractional part after the decimal point*/
 
 
        /* scan the fractional part after the decimal point*/
 

-       if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '}') )) {
+       if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {

                /* strict or lax-but-not-the-end */
                BADVERSION(s,errstr,"Invalid version format (fractional part required)");
        }
                /* strict or lax-but-not-the-end */
                BADVERSION(s,errstr,"Invalid version format (fractional part required)");
        }


@@ -4551,7 +4631,7 @@ version_prescan_finish:
     while (isSPACE(*d))
        d++;
 
     while (isSPACE(*d))
        d++;
 

-    if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '}') )) {
+    if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {

        /* trailing non-numeric data */
        BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
     }
        /* trailing non-numeric data */
        BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
     }


@@ -4782,7 +4862,8 @@ Perl_new_version(pTHX_ SV *ver)
     dVAR;
     SV * const rv = newSV(0);
     PERL_ARGS_ASSERT_NEW_VERSION;
     dVAR;
     SV * const rv = newSV(0);
     PERL_ARGS_ASSERT_NEW_VERSION;

-    if ( sv_derived_from(ver,"version") ) /* can just copy directly */
+    if ( sv_isobject(ver) && sv_derived_from(ver, "version") )
+        /* can just copy directly */

     {
        I32 key;
        AV * const av = newAV();
     {
        I32 key;
        AV * const av = newAV();


@@ -4874,14 +4955,18 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 
     if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
     {
 
     if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
     {

+       STRLEN len;
+

        /* may get too much accuracy */ 
        char tbuf[64];
 #ifdef USE_LOCALE_NUMERIC
        /* may get too much accuracy */ 
        char tbuf[64];
 #ifdef USE_LOCALE_NUMERIC

-       char *loc = setlocale(LC_NUMERIC, "C");
+       char *loc = savepv(setlocale(LC_NUMERIC, NULL));
+       setlocale(LC_NUMERIC, "C");

 #endif
 #endif

-       STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
+       len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));

 #ifdef USE_LOCALE_NUMERIC
        setlocale(LC_NUMERIC, loc);
 #ifdef USE_LOCALE_NUMERIC
        setlocale(LC_NUMERIC, loc);

+       Safefree(loc);

 #endif
        while (tbuf[len-1] == '0' && len > 0) len--;
        if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
 #endif
        while (tbuf[len-1] == '0' && len > 0) len--;
        if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */


@@ -4900,29 +4985,35 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 #ifndef SvVOK
 #  if PERL_VERSION > 5
        /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
 #ifndef SvVOK
 #  if PERL_VERSION > 5
        /* This will only be executed for 5.6.0 - 5.8.0 inclusive */

-       if ( len >= 3 && !instr(version,".") && !instr(version,"_")
-           && !(*version == 'u' && strEQ(version, "undef"))
-           && (*version < '0' || *version > '9') ) {
+       if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {

            /* may be a v-string */
            /* may be a v-string */

-           SV * const nsv = sv_newmortal();
-           const char *nver;
-           const char *pos;
-           int saw_decimal = 0;
-           sv_setpvf(nsv,"v%vd",ver);
-           pos = nver = savepv(SvPV_nolen(nsv));
-
-           /* scan the resulting formatted string */
-           pos++; /* skip the leading 'v' */
-           while ( *pos == '.' || isDIGIT(*pos) ) {
-               if ( *pos == '.' )
-                   saw_decimal++ ;
-               pos++;
-           }
+           char *testv = (char *)version;
+           STRLEN tlen = len;
+           for (tlen=0; tlen < len; tlen++, testv++) {
+               /* if one of the characters is non-text assume v-string */
+               if (testv[0] < ' ') {
+                   SV * const nsv = sv_newmortal();
+                   const char *nver;
+                   const char *pos;
+                   int saw_decimal = 0;
+                   sv_setpvf(nsv,"v%vd",ver);
+                   pos = nver = savepv(SvPV_nolen(nsv));
+
+                   /* scan the resulting formatted string */
+                   pos++; /* skip the leading 'v' */
+                   while ( *pos == '.' || isDIGIT(*pos) ) {
+                       if ( *pos == '.' )
+                           saw_decimal++ ;
+                       pos++;
+                   }

 
 

-           /* is definitely a v-string */
-           if ( saw_decimal >= 2 ) {
-               Safefree(version);
-               version = nver;
+                   /* is definitely a v-string */
+                   if ( saw_decimal >= 2 ) {   
+                       Safefree(version);
+                       version = nver;
+                   }
+                   break;
+               }

            }
        }
 #  endif
            }
        }
 #  endif


@@ -4941,27 +5032,30 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 /*
 =for apidoc vverify
 
 /*
 =for apidoc vverify
 

-Validates that the SV contains a valid version object.
+Validates that the SV contains valid internal structure for a version object.
+It may be passed either the version object (RV) or the hash itself (HV).  If
+the structure is valid, it returns the HV.  If the structure is invalid,
+it returns NULL.

 
 

-    bool vverify(SV *vobj);
+    SV *hv = vverify(sv);

 
 Note that it only confirms the bare minimum structure (so as not to get
 confused by derived classes which may contain additional hash entries):
 
 =over 4
 
 
 Note that it only confirms the bare minimum structure (so as not to get
 confused by derived classes which may contain additional hash entries):
 
 =over 4
 

-=item * The SV contains a [reference to a] hash
+=item * The SV is an HV or a reference to an HV

 
 =item * The hash contains a "version" key
 
 
 =item * The hash contains a "version" key
 

-=item * The "version" key has [a reference to] an AV as its value
+=item * The "version" key has a reference to an AV as its value

 
 =back
 
 =cut
 */
 
 
 =back
 
 =cut
 */
 

-bool
+SV *

 Perl_vverify(pTHX_ SV *vs)
 {
     SV *sv;
 Perl_vverify(pTHX_ SV *vs)
 {
     SV *sv;


@@ -4976,9 +5070,9 @@ Perl_vverify(pTHX_ SV *vs)
         && hv_exists(MUTABLE_HV(vs), "version", 7)
         && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
         && SvTYPE(sv) == SVt_PVAV )
         && hv_exists(MUTABLE_HV(vs), "version", 7)
         && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
         && SvTYPE(sv) == SVt_PVAV )

-       return TRUE;
+       return vs;

     else
     else

-       return FALSE;
+       return NULL;

 }
 
 /*
 }
 
 /*


@@ -4992,6 +5086,8 @@ point representation.  Call like:
 NOTE: you can pass either the object directly or the SV
 contained within the RV.
 
 NOTE: you can pass either the object directly or the SV
 contained within the RV.
 

+The SV returned has a refcount of 1.
+

 =cut
 */
 
 =cut
 */
 


@@ -5006,10 +5102,9 @@ Perl_vnumify(pTHX_ SV *vs)
 
     PERL_ARGS_ASSERT_VNUMIFY;
 
 
     PERL_ARGS_ASSERT_VNUMIFY;
 

-    if ( SvROK(vs) )
-       vs = SvRV(vs);
-
-    if ( !vverify(vs) )
+    /* extract the HV from the object */
+    vs = vverify(vs);
+    if ( ! vs )

        Perl_croak(aTHX_ "Invalid version object");
 
     /* see if various flags exist */
        Perl_croak(aTHX_ "Invalid version object");
 
     /* see if various flags exist */


@@ -5072,6 +5167,8 @@ representation.  Call like:
 NOTE: you can pass either the object directly or the SV
 contained within the RV.
 
 NOTE: you can pass either the object directly or the SV
 contained within the RV.
 

+The SV returned has a refcount of 1.
+

 =cut
 */
 
 =cut
 */
 


@@ -5085,10 +5182,9 @@ Perl_vnormal(pTHX_ SV *vs)
 
     PERL_ARGS_ASSERT_VNORMAL;
 
 
     PERL_ARGS_ASSERT_VNORMAL;
 

-    if ( SvROK(vs) )
-       vs = SvRV(vs);
-
-    if ( !vverify(vs) )
+    /* extract the HV from the object */
+    vs = vverify(vs);
+    if ( ! vs )

        Perl_croak(aTHX_ "Invalid version object");
 
     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
        Perl_croak(aTHX_ "Invalid version object");
 
     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )


@@ -5130,7 +5226,9 @@ Perl_vnormal(pTHX_ SV *vs)
 In order to maintain maximum compatibility with earlier versions
 of Perl, this function will return either the floating point
 notation or the multiple dotted notation, depending on whether
 In order to maintain maximum compatibility with earlier versions
 of Perl, this function will return either the floating point
 notation or the multiple dotted notation, depending on whether

-the original version contained 1 or more dots, respectively
+the original version contained 1 or more dots, respectively.
+
+The SV returned has a refcount of 1.

 
 =cut
 */
 
 =cut
 */


@@ -5140,10 +5238,9 @@ Perl_vstringify(pTHX_ SV *vs)
 {
     PERL_ARGS_ASSERT_VSTRINGIFY;
 
 {
     PERL_ARGS_ASSERT_VSTRINGIFY;
 

-    if ( SvROK(vs) )
-       vs = SvRV(vs);
-
-    if ( !vverify(vs) )
+    /* extract the HV from the object */
+    vs = vverify(vs);
+    if ( ! vs )

        Perl_croak(aTHX_ "Invalid version object");
 
     if (hv_exists(MUTABLE_HV(vs), "original",  sizeof("original") - 1)) {
        Perl_croak(aTHX_ "Invalid version object");
 
     if (hv_exists(MUTABLE_HV(vs), "original",  sizeof("original") - 1)) {


@@ -5183,15 +5280,10 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
 
     PERL_ARGS_ASSERT_VCMP;
 
 
     PERL_ARGS_ASSERT_VCMP;
 

-    if ( SvROK(lhv) )
-       lhv = SvRV(lhv);
-    if ( SvROK(rhv) )
-       rhv = SvRV(rhv);
-
-    if ( !vverify(lhv) )
-       Perl_croak(aTHX_ "Invalid version object");
-
-    if ( !vverify(rhv) )
+    /* extract the HVs from the objects */
+    lhv = vverify(lhv);
+    rhv = vverify(rhv);
+    if ( ! ( lhv && rhv ) )

        Perl_croak(aTHX_ "Invalid version object");
 
     /* get the left hand term */
        Perl_croak(aTHX_ "Invalid version object");
 
     /* get the left hand term */


@@ -5508,7 +5600,7 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
 }
 #else
 /* In any case have a stub so that there's code corresponding
 }
 #else
 /* In any case have a stub so that there's code corresponding

- * to the my_socketpair in global.sym. */
+ * to the my_socketpair in embed.fnc. */

 int
 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
 #ifdef HAS_SOCKETPAIR
 int
 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
 #ifdef HAS_SOCKETPAIR


@@ -5571,8 +5663,11 @@ Perl_parse_unicode_opts(pTHX_ const char **popt)
            opt = (U32) atoi(p);
            while (isDIGIT(*p))
                p++;
            opt = (U32) atoi(p);
            while (isDIGIT(*p))
                p++;

-           if (*p && *p != '\n' && *p != '\r')
+           if (*p && *p != '\n' && *p != '\r') {
+            if(isSPACE(*p)) goto the_end_of_the_opts_parser;
+            else

                 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
                 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);

+           }

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


@@ -5598,9 +5693,12 @@ Perl_parse_unicode_opts(pTHX_ const char **popt)
                 case PERL_UNICODE_UTF8CACHEASSERT:
                      opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
                 default:
                 case PERL_UNICODE_UTF8CACHEASSERT:
                      opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
                 default:

-                     if (*p != '\n' && *p != '\r')
+                     if (*p != '\n' && *p != '\r') {
+                       if(isSPACE(*p)) goto the_end_of_the_opts_parser;
+                       else

                          Perl_croak(aTHX_
                                     "Unknown Unicode option letter '%c'", *p);
                          Perl_croak(aTHX_
                                     "Unknown Unicode option letter '%c'", *p);

+                     }

                 }
            }
        }
                 }
            }
        }


@@ -5608,6 +5706,8 @@ Perl_parse_unicode_opts(pTHX_ const char **popt)
   else
        opt = PERL_UNICODE_DEFAULT_FLAGS;
 
   else
        opt = PERL_UNICODE_DEFAULT_FLAGS;
 

+  the_end_of_the_opts_parser:
+

   if (opt & ~PERL_UNICODE_ALL_FLAGS)
        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
                  (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
   if (opt & ~PERL_UNICODE_ALL_FLAGS)
        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
                  (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));


@@ -5742,16 +5842,28 @@ Perl_get_hash_seed(pTHX)
 bool
 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
 {
 bool
 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 * stashpv = CopSTASHPV(c);
+    const char * name    = HvNAME_get(hv);

     PERL_UNUSED_CONTEXT;
     PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH;
 
     PERL_UNUSED_CONTEXT;
     PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH;
 

-    if (stashpv == name)
-       return TRUE;
-    if (stashpv && name)
-       if (strEQ(stashpv, name))
-           return TRUE;
+    if (!stashpv || !name)
+       return stashpv == name;
+    if ( HvNAMEUTF8(hv) && !(CopSTASH_flags(c) & SVf_UTF8 ? 1 : 0) ) {
+        if (CopSTASH_flags(c) & SVf_UTF8) {
+            return (bytes_cmp_utf8(
+                        (const U8*)stashpv, strlen(stashpv),
+                        (const U8*)name, HEK_LEN(HvNAME_HEK(hv))) == 0);
+        } else {
+            return (bytes_cmp_utf8(
+                        (const U8*)name, HEK_LEN(HvNAME_HEK(hv)),
+                        (const U8*)stashpv, strlen(stashpv)) == 0);
+        }
+    }
+    else
+        return (stashpv == name
+                    || strEQ(stashpv, name));
+    /*NOTREACHED*/

     return FALSE;
 }
 #endif
     return FALSE;
 }
 #endif


@@ -5781,18 +5893,15 @@ Perl_init_global_struct(pTHX)
 #  undef PERLVARA
 #  undef PERLVARI
 #  undef PERLVARIC
 #  undef PERLVARA
 #  undef PERLVARI
 #  undef PERLVARIC

-#  undef PERLVARISC
-#  define PERLVAR(var,type) /**/
-#  define PERLVARA(var,n,type) /**/
-#  define PERLVARI(var,type,init) plvarsp->var = init;
-#  define PERLVARIC(var,type,init) plvarsp->var = init;
-#  define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
+#  define PERLVAR(prefix,var,type) /**/
+#  define PERLVARA(prefix,var,n,type) /**/
+#  define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init;
+#  define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init;

 #  include "perlvars.h"
 #  undef PERLVAR
 #  undef PERLVARA
 #  undef PERLVARI
 #  undef PERLVARIC
 #  include "perlvars.h"
 #  undef PERLVAR
 #  undef PERLVARA
 #  undef PERLVARI
 #  undef PERLVARIC

-#  undef PERLVARISC

 #  ifdef PERL_GLOBAL_STRUCT
     plvarsp->Gppaddr =
        (Perl_ppaddr_t*)
 #  ifdef PERL_GLOBAL_STRUCT
     plvarsp->Gppaddr =
        (Perl_ppaddr_t*)


@@ -5968,7 +6077,7 @@ S_mem_log_common(enum mem_log_type mlt, const UV n,
     mem_log_common   (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
 #else
 /* this is suboptimal, but bug compatible.  User is providing their
     mem_log_common   (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
 #else
 /* this is suboptimal, but bug compatible.  User is providing their

-   own implemenation, but is getting these functions anyway, and they
+   own implementation, but is getting these functions anyway, and they

    do nothing. But _NOIMPL users should be able to cope or fix */
 # define \
     mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
    do nothing. But _NOIMPL users should be able to cope or fix */
 # define \
     mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \


@@ -6077,8 +6186,14 @@ Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
     retval = vsprintf(buffer, format, ap);
 #endif
     va_end(ap);
     retval = vsprintf(buffer, format, ap);
 #endif
     va_end(ap);

-    /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
-    if (retval < 0 || (len > 0 && (Size_t)retval >= len))
+    /* vsprintf() shows failure with < 0 */
+    if (retval < 0
+#ifdef HAS_VSNPRINTF
+    /* vsnprintf() shows failure with >= len */
+        ||
+        (len > 0 && (Size_t)retval >= len) 
+#endif
+    )

        Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
     return retval;
 }
        Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
     return retval;
 }


@@ -6117,8 +6232,14 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap
     retval = vsprintf(buffer, format, ap);
 # endif
 #endif /* #ifdef NEED_VA_COPY */
     retval = vsprintf(buffer, format, ap);
 # endif
 #endif /* #ifdef NEED_VA_COPY */

-    /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
-    if (retval < 0 || (len > 0 && (Size_t)retval >= len))
+    /* vsprintf() shows failure with < 0 */
+    if (retval < 0
+#ifdef HAS_VSNPRINTF
+    /* vsnprintf() shows failure with >= len */
+        ||
+        (len > 0 && (Size_t)retval >= len) 
+#endif
+    )

        Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
     return retval;
 }
        Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
     return retval;
 }


@@ -6296,6 +6417,84 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
 #endif /* PERL_IMPLICIT_CONTEXT */
 
 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
 #endif /* PERL_IMPLICIT_CONTEXT */
 

+void
+Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
+                         STRLEN xs_len)
+{
+    SV *sv;
+    const char *vn = NULL;
+    SV *const module = PL_stack_base[ax];
+
+    PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
+
+    if (items >= 2)     /* version supplied as bootstrap arg */
+       sv = PL_stack_base[ax + 1];
+    else {
+       /* XXX GV_ADDWARN */
+       vn = "XS_VERSION";
+       sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
+       if (!sv || !SvOK(sv)) {
+           vn = "VERSION";
+           sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
+       }
+    }
+    if (sv) {
+       SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
+       SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version")
+           ? sv : sv_2mortal(new_version(sv));
+       xssv = upg_version(xssv, 0);
+       if ( vcmp(pmsv,xssv) ) {
+           SV *string = vstringify(xssv);
+           SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
+                                   " does not match ", module, string);
+
+           SvREFCNT_dec(string);
+           string = vstringify(pmsv);
+
+           if (vn) {
+               Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn,
+                              string);
+           } else {
+               Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string);
+           }
+           SvREFCNT_dec(string);
+
+           Perl_sv_2mortal(aTHX_ xpt);
+           Perl_croak_sv(aTHX_ xpt);
+       }
+    }
+}
+
+void
+Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
+                            STRLEN api_len)
+{
+    SV *xpt = NULL;
+    SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
+    SV *runver;
+
+    PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
+
+    /* This might croak  */
+    compver = upg_version(compver, 0);
+    /* This should never croak */
+    runver = new_version(PL_apiversion);
+    if (vcmp(compver, runver)) {
+       SV *compver_string = vstringify(compver);
+       SV *runver_string = vstringify(runver);
+       xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
+                           " of %"SVf" does not match %"SVf,
+                           compver_string, module, runver_string);
+       Perl_sv_2mortal(aTHX_ xpt);
+
+       SvREFCNT_dec(compver_string);
+       SvREFCNT_dec(runver_string);
+    }
+    SvREFCNT_dec(runver);
+    if (xpt)
+       Perl_croak_sv(aTHX_ xpt);
+}
+

 #ifndef HAS_STRLCAT
 Size_t
 Perl_my_strlcat(char *dst, const char *src, Size_t size)
 #ifndef HAS_STRLCAT
 Size_t
 Perl_my_strlcat(char *dst, const char *src, Size_t size)


@@ -6335,34 +6534,65 @@ long _ftol( double ); /* Defined by VC6 C libs. */
 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
 #endif
 
 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
 #endif
 

+PERL_STATIC_INLINE bool
+S_gv_has_usable_name(pTHX_ GV *gv)
+{
+    GV **gvp;
+    return GvSTASH(gv)
+       && HvENAME(GvSTASH(gv))
+       && (gvp = (GV **)hv_fetch(
+                       GvSTASH(gv), GvNAME(gv),
+                       GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0
+          ))
+       && *gvp == gv;
+}
+

 void
 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
 {
     dVAR;
     SV * const dbsv = GvSVn(PL_DBsub);
 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;
+    const bool save_taint = PL_tainted;
+
+    /* When we are called from pp_goto (svp is null),
+     * we do not care about using dbsv to call CV;

      * it's for informational purposes only.
      */
 
     PERL_ARGS_ASSERT_GET_DB_SUB;
 
      * it's for informational purposes only.
      */
 
     PERL_ARGS_ASSERT_GET_DB_SUB;
 

+    PL_tainted = FALSE;

     save_item(dbsv);
     if (!PERLDB_SUB_NN) {
     save_item(dbsv);
     if (!PERLDB_SUB_NN) {

-       GV * const gv = CvGV(cv);
+       GV *gv = CvGV(cv);

 
 

-       if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
+       if (!svp) {
+           gv_efullname3(dbsv, gv, NULL);
+       }
+       else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))

             || strEQ(GvNAME(gv), "END")
             || strEQ(GvNAME(gv), "END")

-            || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
+            || ( /* Could be imported, and old sub redefined. */
+                (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
+                &&

                 !( (SvTYPE(*svp) == SVt_PVGV)
                 !( (SvTYPE(*svp) == SVt_PVGV)

-                   && (GvCV((const GV *)*svp) == cv) )))) {
-           /* Use GV from the stack as a fallback. */
+                   && (GvCV((const GV *)*svp) == cv)
+                   /* Use GV from the stack as a fallback. */
+                   && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp) 
+                 )
+               )
+       ) {

            /* GV is potentially non-unique, or contain different CV. */
            SV * const tmp = newRV(MUTABLE_SV(cv));
            sv_setsv(dbsv, tmp);
            SvREFCNT_dec(tmp);
        }
        else {
            /* GV is potentially non-unique, or contain different CV. */
            SV * const tmp = newRV(MUTABLE_SV(cv));
            sv_setsv(dbsv, tmp);
            SvREFCNT_dec(tmp);
        }
        else {

-           gv_efullname3(dbsv, gv, NULL);
+           sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
+           sv_catpvs(dbsv, "::");
+           sv_catpvn_flags(
+             dbsv, GvNAME(gv), GvNAMELEN(gv),
+             GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
+           );

        }
     }
     else {
        }
     }
     else {


@@ -6372,6 +6602,7 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
        (void)SvIOK_on(dbsv);
        SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
     }
        (void)SvIOK_on(dbsv);
        SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
     }

+    TAINT_IF(save_taint);

 }
 
 int
 }
 
 int