Refactor Perl_get_vtbl() to a small array lookup from a large switch statement.

[perl5.git] / util.c

diff --git a/util.c b/util.c
index 652e868..19fec65 100644 (file)
--- a/util.c
+++ b/util.c
@@ -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


@@ -99,7 +103,6 @@ Perl_safesysmalloc(MEM_SIZE size)
 #endif
     ptr = (Malloc_t)PerlMem_malloc(size?size:1);       /* malloc(0) is NASTY on our system */
     PERL_ALLOC_CHECK(ptr);
 #endif
     ptr = (Malloc_t)PerlMem_malloc(size?size:1);       /* malloc(0) is NASTY on our system */
     PERL_ALLOC_CHECK(ptr);

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

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


@@ -122,6 +125,7 @@ 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;
 }
     else {
        return ptr;
 }
     else {


@@ -290,11 +294,16 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
     dTHX;
 #endif
     Malloc_t ptr;
     dTHX;
 #endif
     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


@@ -536,13 +545,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() */


@@ -552,31 +572,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++) {


@@ -585,14 +623,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. */


@@ -632,9 +669,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')


@@ -650,11 +688,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;


@@ -714,7 +748,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


@@ -752,8 +789,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 */


@@ -789,7 +826,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;


@@ -827,7 +864,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
 
     PERL_ARGS_ASSERT_SCREAMINSTR;
 
 
     PERL_ARGS_ASSERT_SCREAMINSTR;
 

-    assert(SvTYPE(littlestr) == SVt_PVGV);
+    assert(SvTYPE(littlestr) == SVt_PVMG);

     assert(SvVALID(littlestr));
 
     if (*old_posp == -1
     assert(SvVALID(littlestr));
 
     if (*old_posp == -1


@@ -930,6 +967,27 @@ Perl_foldEQ(const char *s1, const char *s2, register I32 len)
     }
     return 1;
 }
     }
     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
 
 /*
 =for apidoc foldEQ_locale


@@ -1087,6 +1145,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 */
 


@@ -1097,7 +1174,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)


@@ -1324,7 +1401,7 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
                           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");
     }


@@ -1371,38 +1448,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;


@@ -2686,7 +2741,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


@@ -2732,12 +2786,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


@@ -3100,11 +3148,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;


@@ -3123,7 +3180,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


@@ -3135,7 +3192,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__)


@@ -3675,104 +3736,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


@@ -3826,113 +3793,75 @@ Perl_my_fflush_all(pTHX)
 }
 
 void
 }
 
 void

-Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
-{
-    const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
-
-    if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
-       if (ckWARN(WARN_IO)) {
-           const char * const direction =
-               (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
-           if (name && *name)
-               Perl_warner(aTHX_ packWARN(WARN_IO),
-                           "Filehandle %s opened only for %sput",
-                           name, direction);
-           else
-               Perl_warner(aTHX_ packWARN(WARN_IO),
-                           "Filehandle opened only for %sput", direction);
-       }
-    }
-    else {
-        const char *vile;
-       I32   warn_type;
-
-       if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
-           vile = "closed";
-           warn_type = WARN_CLOSED;
-       }
-       else {
-           vile = "unopened";
-           warn_type = WARN_UNOPENED;
-       }
+Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
+{
+    if (ckWARN(WARN_IO)) {
+       const char * const name
+           = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
+       const char * const direction = have == '>' ? "out" : "in";

 
 

-       if (ckWARN(warn_type)) {
-           const char * const pars =
-               (const char *)(OP_IS_FILETEST(op) ? "" : "()");
-           const char * const func =
-               (const char *)
-               (op == OP_READLINE   ? "readline"  :    /* "<HANDLE>" not nice */
-                op == OP_LEAVEWRITE ? "write" :                /* "write exit" not nice */
-                op < 0              ? "" :              /* handle phoney cases */
-                PL_op_desc[op]);
-           const char * const type =
-               (const char *)
-               (OP_IS_SOCKET(op) ||
-                (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
-                "socket" : "filehandle");
-           if (name && *name) {
-               Perl_warner(aTHX_ packWARN(warn_type),
-                           "%s%s on %s %s %s", func, pars, vile, type, name);
-               if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
-                   Perl_warner(
-                       aTHX_ packWARN(warn_type),
-                       "\t(Are you trying to call %s%s on dirhandle %s?)\n",
-                       func, pars, name
-                   );
-           }
-           else {
-               Perl_warner(aTHX_ packWARN(warn_type),
-                           "%s%s on %s %s", func, pars, vile, type);
-               if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
-                   Perl_warner(
-                       aTHX_ packWARN(warn_type),
-                       "\t(Are you trying to call %s%s on dirhandle?)\n",
-                       func, pars
-                   );
-           }
-       }
+       if (name && *name)
+           Perl_warner(aTHX_ packWARN(WARN_IO),
+                       "Filehandle %s opened only for %sput",
+                       name, direction);
+       else
+           Perl_warner(aTHX_ packWARN(WARN_IO),
+                       "Filehandle opened only for %sput", direction);

     }
 }
 
     }
 }
 

-/* 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 {
+       vile = "unopened";
+       warn_type = WARN_UNOPENED;
+    }
+
+    if (ckWARN(warn_type)) {
+       const char * const name
+           = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
+       const char * const pars =
+           (const char *)(OP_IS_FILETEST(op) ? "" : "()");
+       const char * const func =
+           (const char *)
+           (op == OP_READLINE   ? "readline"  :        /* "<HANDLE>" not nice */
+            op == OP_LEAVEWRITE ? "write" :            /* "write exit" not nice */
+            PL_op_desc[op]);
+       const char * const type =
+           (const char *)
+           (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
+            ? "socket" : "filehandle");
+       if (name && *name) {
+           Perl_warner(aTHX_ packWARN(warn_type),
+                       "%s%s on %s %s %s", func, pars, vile, type, name);
+           if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+               Perl_warner(
+                           aTHX_ packWARN(warn_type),
+                           "\t(Are you trying to call %s%s on dirhandle %s?)\n",
+                           func, pars, name
+                           );

        }
        }

-       else if (output_warning) {
-           U8 clearer[3];
-           U8 i = 0;
-           if (! isALNUM(result)) {
-               clearer[i++] = '\\';
-           }
-           clearer[i++] = result;
-           clearer[i++] = '\0';
-
-           Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
-                           "\"\\c%c\" more clearly written simply as \"%s\"",
-                           source,
-                           clearer);
+       else {
+           Perl_warner(aTHX_ packWARN(warn_type),
+                       "%s%s on %s %s", func, pars, vile, type);
+           if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+               Perl_warner(
+                           aTHX_ packWARN(warn_type),
+                           "\t(Are you trying to call %s%s on dirhandle?)\n",
+                           func, pars
+                           );

        }
     }
        }
     }

-
-    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


@@ -4055,7 +3984,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


@@ -4234,7 +4163,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)


@@ -4437,6 +4366,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 *


@@ -4970,29 +4904,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


@@ -5011,27 +4951,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;


@@ -5046,9 +4989,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;

 }
 
 /*
 }
 
 /*


@@ -5062,6 +5005,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
 */
 


@@ -5076,10 +5021,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 */


@@ -5142,6 +5086,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
 */
 


@@ -5155,10 +5101,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 ) )


@@ -5200,7 +5145,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
 */


@@ -5210,10 +5157,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)) {


@@ -5253,15 +5199,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 */


@@ -5641,8 +5582,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++) {


@@ -5668,9 +5612,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);

+                     }

                 }
            }
        }
                 }
            }
        }


@@ -5678,6 +5625,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));


@@ -6038,7 +5987,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) \


@@ -6147,8 +6096,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;
 }


@@ -6187,8 +6142,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;
 }


@@ -6366,6 +6327,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_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)


@@ -6410,21 +6449,28 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
 {
     dVAR;
     SV * const dbsv = GvSVn(PL_DBsub);
 {
     dVAR;
     SV * const dbsv = GvSVn(PL_DBsub);

+    const bool save_taint = PL_tainted;
+

     /* We do not care about using sv to call CV;
      * it's for informational purposes only.
      */
 
     PERL_ARGS_ASSERT_GET_DB_SUB;
 
     /* We do not care about using sv to call CV;
      * it's for informational purposes only.
      */
 
     PERL_ARGS_ASSERT_GET_DB_SUB;
 

+    PL_tainted = FALSE;

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

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

 
        if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
             || strEQ(GvNAME(gv), "END")
             || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
                 !( (SvTYPE(*svp) == SVt_PVGV)
 
        if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
             || strEQ(GvNAME(gv), "END")
             || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
                 !( (SvTYPE(*svp) == SVt_PVGV)

-                   && (GvCV((const GV *)*svp) == cv) )))) {
+                   && (GvCV((const GV *)*svp) == cv)
+                   && (gv = (GV *)*svp) 
+                 )
+               )
+       )) {

            /* Use GV from the stack as a fallback. */
            /* GV is potentially non-unique, or contain different CV. */
            SV * const tmp = newRV(MUTABLE_SV(cv));
            /* Use GV from the stack as a fallback. */
            /* GV is potentially non-unique, or contain different CV. */
            SV * const tmp = newRV(MUTABLE_SV(cv));


@@ -6442,6 +6488,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