This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Merge the implementations of {end,set}{gr,pw}ent with endhostent.
[perl5.git] / util.c
diff --git a/util.c b/util.c
index 67d0a13..e9bd742 100644 (file)
--- a/util.c
+++ b/util.c
@@ -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) {
@@ -93,7 +99,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
@@ -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();
@@ -213,10 +226,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 +244,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;
@@ -268,7 +286,9 @@ 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;
     MEM_SIZE total_size = 0;
 
     Malloc_t ptr;
     MEM_SIZE total_size = 0;
 
@@ -330,9 +350,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
@@ -369,10 +394,9 @@ Free_t   Perl_mfree (Malloc_t where)
 /* copy a string up to some (non-backslashed) delimiter, if any */
 
 char *
 /* copy a string up to some (non-backslashed) delimiter, if any */
 
 char *
-Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
+Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
 {
     register I32 tolen;
 {
     register I32 tolen;
-    PERL_UNUSED_CONTEXT;
 
     PERL_ARGS_ASSERT_DELIMCPY;
 
 
     PERL_ARGS_ASSERT_DELIMCPY;
 
@@ -400,10 +424,9 @@ Perl_delimcpy(pTHX_ register char *to, register const char *toend, register cons
 /* This routine was donated by Corey Satten. */
 
 char *
 /* This routine was donated by Corey Satten. */
 
 char *
-Perl_instr(pTHX_ register const char *big, register const char *little)
+Perl_instr(register const char *big, register const char *little)
 {
     register I32 first;
 {
     register I32 first;
-    PERL_UNUSED_CONTEXT;
 
     PERL_ARGS_ASSERT_INSTR;
 
 
     PERL_ARGS_ASSERT_INSTR;
 
@@ -435,10 +458,9 @@ Perl_instr(pTHX_ register const char *big, register const char *little)
 /* same as instr but allow embedded nulls */
 
 char *
 /* same as instr but allow embedded nulls */
 
 char *
-Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend)
+Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
 {
     PERL_ARGS_ASSERT_NINSTR;
 {
     PERL_ARGS_ASSERT_NINSTR;
-    PERL_UNUSED_CONTEXT;
     if (little >= lend)
         return (char*)big;
     {
     if (little >= lend)
         return (char*)big;
     {
@@ -462,12 +484,11 @@ Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const
 /* reverse of the above--find last substring */
 
 char *
 /* reverse of the above--find last substring */
 
 char *
-Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
+Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend)
 {
     register const char *bigbeg;
     register const I32 first = *little;
     register const char * const littleend = lend;
 {
     register const char *bigbeg;
     register const I32 first = *little;
     register const char * const littleend = lend;
-    PERL_UNUSED_CONTEXT;
 
     PERL_ARGS_ASSERT_RNINSTR;
 
 
     PERL_ARGS_ASSERT_RNINSTR;
 
@@ -882,39 +903,79 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
     return NULL;
 }
 
     return NULL;
 }
 
+/*
+=for apidoc foldEQ
+
+Returns true if the leading len bytes of the strings s1 and s2 are the same
+case-insensitively; false otherwise.  Uppercase and lowercase ASCII range bytes
+match themselves and their opposite case counterparts.  Non-cased and non-ASCII
+range bytes match only themselves.
+
+=cut
+*/
+
+
 I32
 I32
-Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
+Perl_foldEQ(const char *s1, const char *s2, register I32 len)
 {
     register const U8 *a = (const U8 *)s1;
     register const U8 *b = (const U8 *)s2;
 {
     register const U8 *a = (const U8 *)s1;
     register const U8 *b = (const U8 *)s2;
-    PERL_UNUSED_CONTEXT;
 
 
-    PERL_ARGS_ASSERT_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(pTHX_ const char *s1, const char *s2, register I32 len)
+Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len)
 {
     dVAR;
     register const U8 *a = (const U8 *)s1;
     register const U8 *b = (const U8 *)s2;
 {
     dVAR;
     register const U8 *a = (const U8 *)s1;
     register const U8 *b = (const U8 *)s2;
-    PERL_UNUSED_CONTEXT;
 
 
-    PERL_ARGS_ASSERT_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 */
@@ -1047,6 +1108,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 */
 
@@ -1057,7 +1137,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)
@@ -1130,6 +1210,21 @@ Perl_vform(pTHX_ const char *pat, va_list *args)
     return SvPVX(sv);
 }
 
     return SvPVX(sv);
 }
 
+/*
+=for apidoc Am|SV *|mess|const char *pat|...
+
+Take a sprintf-style format pattern and argument list.  These are used to
+generate a string message.  If the message does not end with a newline,
+then it will be extended with some indication of the current location
+in the code, as described for L</mess_sv>.
+
+Normally, the resulting message is returned in a new mortal SV.
+During global destruction a single SV may be shared between uses of
+this function.
+
+=cut
+*/
+
 #if defined(PERL_IMPLICIT_CONTEXT)
 SV *
 Perl_mess_nocontext(const char *pat, ...)
 #if defined(PERL_IMPLICIT_CONTEXT)
 SV *
 Perl_mess_nocontext(const char *pat, ...)
@@ -1192,15 +1287,57 @@ S_closest_cop(pTHX_ const COP *cop, const OP *o)
     return NULL;
 }
 
     return NULL;
 }
 
+/*
+=for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
+
+Expands a message, intended for the user, to include an indication of
+the current location in the code, if the message does not already appear
+to be complete.
+
+C<basemsg> is the initial message or object.  If it is a reference, it
+will be used as-is and will be the result of this function.  Otherwise it
+is used as a string, and if it already ends with a newline, it is taken
+to be complete, and the result of this function will be the same string.
+If the message does not end with a newline, then a segment such as C<at
+foo.pl line 37> will be appended, and possibly other clauses indicating
+the current state of execution.  The resulting message will end with a
+dot and a newline.
+
+Normally, the resulting message is returned in a new mortal SV.
+During global destruction a single SV may be shared between uses of this
+function.  If C<consume> is true, then the function is permitted (but not
+required) to modify and return C<basemsg> instead of allocating a new SV.
+
+=cut
+*/
+
 SV *
 SV *
-Perl_vmess(pTHX_ const char *pat, va_list *args)
+Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
 {
     dVAR;
 {
     dVAR;
-    SV * const sv = mess_alloc();
+    SV *sv;
 
 
-    PERL_ARGS_ASSERT_VMESS;
+    PERL_ARGS_ASSERT_MESS_SV;
+
+    if (SvROK(basemsg)) {
+       if (consume) {
+           sv = basemsg;
+       }
+       else {
+           sv = mess_alloc();
+           sv_setsv(sv, basemsg);
+       }
+       return sv;
+    }
+
+    if (SvPOK(basemsg) && consume) {
+       sv = basemsg;
+    }
+    else {
+       sv = mess_alloc();
+       sv_copypv(sv, basemsg);
+    }
 
 
-    sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
        /*
         * Try and find the file and line for PL_op.  This will usually be
     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
        /*
         * Try and find the file and line for PL_op.  This will usually be
@@ -1227,15 +1364,43 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
                           line_mode ? "line" : "chunk",
                           (IV)IoLINES(GvIOp(PL_last_in_gv)));
        }
                           line_mode ? "line" : "chunk",
                           (IV)IoLINES(GvIOp(PL_last_in_gv)));
        }
-       if (PL_dirty)
+       if (PL_phase == PERL_PHASE_DESTRUCT)
            sv_catpvs(sv, " during global destruction");
        sv_catpvs(sv, ".\n");
     }
     return sv;
 }
 
            sv_catpvs(sv, " during global destruction");
        sv_catpvs(sv, ".\n");
     }
     return sv;
 }
 
+/*
+=for apidoc Am|SV *|vmess|const char *pat|va_list *args
+
+C<pat> and C<args> are a sprintf-style format pattern and encapsulated
+argument list.  These are used to generate a string message.  If the
+message does not end with a newline, then it will be extended with
+some indication of the current location in the code, as described for
+L</mess_sv>.
+
+Normally, the resulting message is returned in a new mortal SV.
+During global destruction a single SV may be shared between uses of
+this function.
+
+=cut
+*/
+
+SV *
+Perl_vmess(pTHX_ const char *pat, va_list *args)
+{
+    dVAR;
+    SV * const sv = mess_alloc();
+
+    PERL_ARGS_ASSERT_VMESS;
+
+    sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
+    return mess_sv(sv, 1);
+}
+
 void
 void
-Perl_write_to_stderr(pTHX_ const char* message, int msglen)
+Perl_write_to_stderr(pTHX_ SV* msv)
 {
     dVAR;
     IO *io;
 {
     dVAR;
     IO *io;
@@ -1260,9 +1425,9 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
        PUSHMARK(SP);
        EXTEND(SP,2);
        PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
        PUSHMARK(SP);
        EXTEND(SP,2);
        PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
-       mPUSHp(message, msglen);
+       PUSHs(msv);
        PUTBACK;
        PUTBACK;
-       call_method("PRINT", G_SCALAR);
+       call_method("PRINT", G_SCALAR | G_DISCARD);
 
        POPSTACK;
        FREETMPS;
 
        POPSTACK;
        FREETMPS;
@@ -1271,22 +1436,38 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
     else {
 #ifdef USE_SFIO
        /* SFIO can really mess with your errno */
     else {
 #ifdef USE_SFIO
        /* SFIO can really mess with your errno */
-       const int e = errno;
+       dSAVED_ERRNO;
 #endif
        PerlIO * const serr = Perl_error_log;
 
 #endif
        PerlIO * const serr = Perl_error_log;
 
-       PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
+       do_print(msv, serr);
        (void)PerlIO_flush(serr);
 #ifdef USE_SFIO
        (void)PerlIO_flush(serr);
 #ifdef USE_SFIO
-       errno = e;
+       RESTORE_ERRNO;
 #endif
     }
 }
 
 #endif
     }
 }
 
-/* Common code used by vcroak, vdie, vwarn and vwarner  */
+/*
+=head1 Warning and Dieing
+*/
+
+/* Common code used in dieing and warning */
+
+STATIC SV *
+S_with_queued_errors(pTHX_ SV *ex)
+{
+    PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
+    if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
+       sv_catsv(PL_errors, ex);
+       ex = sv_mortalcopy(PL_errors);
+       SvCUR_set(PL_errors, 0);
+    }
+    return ex;
+}
 
 STATIC bool
 
 STATIC bool
-S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
+S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
 {
     dVAR;
     HV *stash;
 {
     dVAR;
     HV *stash;
@@ -1296,7 +1477,8 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
     /* sv_2cv might call Perl_croak() or Perl_warner() */
     SV * const oldhook = *hook;
 
     /* sv_2cv might call Perl_croak() or Perl_warner() */
     SV * const oldhook = *hook;
 
-    assert(oldhook);
+    if (!oldhook)
+       return FALSE;
 
     ENTER;
     SAVESPTR(*hook);
 
     ENTER;
     SAVESPTR(*hook);
@@ -1305,7 +1487,7 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
     LEAVE;
     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
        dSP;
     LEAVE;
     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
        dSP;
-       SV *msg;
+       SV *exarg;
 
        ENTER;
        save_re_context();
 
        ENTER;
        save_re_context();
@@ -1313,18 +1495,13 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
            SAVESPTR(*hook);
            *hook = NULL;
        }
            SAVESPTR(*hook);
            *hook = NULL;
        }
-       if (warn || message) {
-           msg = newSVpvn_flags(message, msglen, utf8);
-           SvREADONLY_on(msg);
-           SAVEFREESV(msg);
-       }
-       else {
-           msg = ERRSV;
-       }
+       exarg = newSVsv(ex);
+       SvREADONLY_on(exarg);
+       SAVEFREESV(exarg);
 
        PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
        PUSHMARK(SP);
 
        PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
        PUSHMARK(SP);
-       XPUSHs(msg);
+       XPUSHs(exarg);
        PUTBACK;
        call_sv(MUTABLE_SV(cv), G_DISCARD);
        POPSTACK;
        PUTBACK;
        call_sv(MUTABLE_SV(cv), G_DISCARD);
        POPSTACK;
@@ -1334,100 +1511,147 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
     return FALSE;
 }
 
     return FALSE;
 }
 
-STATIC const char *
-S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
-                   I32* utf8)
-{
-    dVAR;
-    const char *message;
+/*
+=for apidoc Am|OP *|die_sv|SV *baseex
 
 
-    if (pat) {
-       SV * const msv = vmess(pat, args);
-       if (PL_errors && SvCUR(PL_errors)) {
-           sv_catsv(PL_errors, msv);
-           message = SvPV_const(PL_errors, *msglen);
-           SvCUR_set(PL_errors, 0);
-       }
-       else
-           message = SvPV_const(msv,*msglen);
-       *utf8 = SvUTF8(msv);
-    }
-    else {
-       message = NULL;
-    }
+Behaves the same as L</croak_sv>, except for the return type.
+It should be used only where the C<OP *> return type is required.
+The function never actually returns.
 
 
-    if (PL_diehook) {
-       S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
-    }
-    return message;
-}
+=cut
+*/
 
 
-static OP *
-S_vdie(pTHX_ const char* pat, va_list *args)
+OP *
+Perl_die_sv(pTHX_ SV *baseex)
 {
 {
-    dVAR;
-    const char *message;
-    const int was_in_eval = PL_in_eval;
-    STRLEN msglen;
-    I32 utf8 = 0;
+    PERL_ARGS_ASSERT_DIE_SV;
+    croak_sv(baseex);
+    /* NOTREACHED */
+    return NULL;
+}
 
 
-    message = vdie_croak_common(pat, args, &msglen, &utf8);
+/*
+=for apidoc Am|OP *|die|const char *pat|...
 
 
-    PL_restartop = die_where(message, msglen);
-    SvFLAGS(ERRSV) |= utf8;
-    if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
-       JMPENV_JUMP(3);
-    return PL_restartop;
-}
+Behaves the same as L</croak>, except for the return type.
+It should be used only where the C<OP *> return type is required.
+The function never actually returns.
+
+=cut
+*/
 
 #if defined(PERL_IMPLICIT_CONTEXT)
 OP *
 Perl_die_nocontext(const char* pat, ...)
 {
     dTHX;
 
 #if defined(PERL_IMPLICIT_CONTEXT)
 OP *
 Perl_die_nocontext(const char* pat, ...)
 {
     dTHX;
-    OP *o;
     va_list args;
     va_list args;
-    PERL_ARGS_ASSERT_DIE_NOCONTEXT;
     va_start(args, pat);
     va_start(args, pat);
-    o = vdie(pat, &args);
+    vcroak(pat, &args);
+    /* NOTREACHED */
     va_end(args);
     va_end(args);
-    return o;
+    return NULL;
 }
 #endif /* PERL_IMPLICIT_CONTEXT */
 
 OP *
 Perl_die(pTHX_ const char* pat, ...)
 {
 }
 #endif /* PERL_IMPLICIT_CONTEXT */
 
 OP *
 Perl_die(pTHX_ const char* pat, ...)
 {
-    OP *o;
     va_list args;
     va_start(args, pat);
     va_list args;
     va_start(args, pat);
-    o = vdie(pat, &args);
+    vcroak(pat, &args);
+    /* NOTREACHED */
     va_end(args);
     va_end(args);
-    return o;
+    return NULL;
 }
 
 }
 
+/*
+=for apidoc Am|void|croak_sv|SV *baseex
+
+This is an XS interface to Perl's C<die> function.
+
+C<baseex> is the error message or object.  If it is a reference, it
+will be used as-is.  Otherwise it is used as a string, and if it does
+not end with a newline then it will be extended with some indication of
+the current location in the code, as described for L</mess_sv>.
+
+The error message or object will be used as an exception, by default
+returning control to the nearest enclosing C<eval>, but subject to
+modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak_sv>
+function never returns normally.
+
+To die with a simple string message, the L</croak> function may be
+more convenient.
+
+=cut
+*/
+
 void
 void
-Perl_vcroak(pTHX_ const char* pat, va_list *args)
+Perl_croak_sv(pTHX_ SV *baseex)
 {
 {
-    dVAR;
-    const char *message;
-    STRLEN msglen;
-    I32 utf8 = 0;
+    SV *ex = with_queued_errors(mess_sv(baseex, 0));
+    PERL_ARGS_ASSERT_CROAK_SV;
+    invoke_exception_hook(ex, FALSE);
+    die_unwind(ex);
+}
 
 
-    message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
+/*
+=for apidoc Am|void|vcroak|const char *pat|va_list *args
 
 
-    if (PL_in_eval) {
-       PL_restartop = die_where(message, msglen);
-       SvFLAGS(ERRSV) |= utf8;
-       JMPENV_JUMP(3);
-    }
-    else if (!message)
-       message = SvPVx_const(ERRSV, msglen);
+This is an XS interface to Perl's C<die> function.
+
+C<pat> and C<args> are a sprintf-style format pattern and encapsulated
+argument list.  These are used to generate a string message.  If the
+message does not end with a newline, then it will be extended with
+some indication of the current location in the code, as described for
+L</mess_sv>.
+
+The error message will be used as an exception, by default
+returning control to the nearest enclosing C<eval>, but subject to
+modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak>
+function never returns normally.
+
+For historical reasons, if C<pat> is null then the contents of C<ERRSV>
+(C<$@>) will be used as an error message or object instead of building an
+error message from arguments.  If you want to throw a non-string object,
+or build an error message in an SV yourself, it is preferable to use
+the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
+
+=cut
+*/
 
 
-    write_to_stderr(message, msglen);
-    my_failure_exit();
+void
+Perl_vcroak(pTHX_ const char* pat, va_list *args)
+{
+    SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
+    invoke_exception_hook(ex, FALSE);
+    die_unwind(ex);
 }
 
 }
 
+/*
+=for apidoc Am|void|croak|const char *pat|...
+
+This is an XS interface to Perl's C<die> function.
+
+Take a sprintf-style format pattern and argument list.  These are used to
+generate a string message.  If the message does not end with a newline,
+then it will be extended with some indication of the current location
+in the code, as described for L</mess_sv>.
+
+The error message will be used as an exception, by default
+returning control to the nearest enclosing C<eval>, but subject to
+modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak>
+function never returns normally.
+
+For historical reasons, if C<pat> is null then the contents of C<ERRSV>
+(C<$@>) will be used as an error message or object instead of building an
+error message from arguments.  If you want to throw a non-string object,
+or build an error message in an SV yourself, it is preferable to use
+the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
+
+=cut
+*/
+
 #if defined(PERL_IMPLICIT_CONTEXT)
 void
 Perl_croak_nocontext(const char *pat, ...)
 #if defined(PERL_IMPLICIT_CONTEXT)
 void
 Perl_croak_nocontext(const char *pat, ...)
@@ -1441,54 +1665,105 @@ Perl_croak_nocontext(const char *pat, ...)
 }
 #endif /* PERL_IMPLICIT_CONTEXT */
 
 }
 #endif /* PERL_IMPLICIT_CONTEXT */
 
+void
+Perl_croak(pTHX_ const char *pat, ...)
+{
+    va_list args;
+    va_start(args, pat);
+    vcroak(pat, &args);
+    /* NOTREACHED */
+    va_end(args);
+}
+
 /*
 /*
-=head1 Warning and Dieing
+=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
+*/
 
 
-=for apidoc croak
+void
+Perl_croak_no_modify(pTHX)
+{
+    Perl_croak(aTHX_ "%s", PL_no_modify);
+}
 
 
-This is the XSUB-writer's interface to Perl's C<die> function.
-Normally call this function the same way you call the C C<printf>
-function.  Calling C<croak> returns control directly to Perl,
-sidestepping the normal C order of execution. See C<warn>.
+/*
+=for apidoc Am|void|warn_sv|SV *baseex
 
 
-If you want to throw an exception object, assign the object to
-C<$@> and then pass C<NULL> to croak():
+This is an XS interface to Perl's C<warn> function.
 
 
-   errsv = get_sv("@", TRUE);
-   sv_setsv(errsv, exception_object);
-   croak(NULL);
+C<baseex> is the error message or object.  If it is a reference, it
+will be used as-is.  Otherwise it is used as a string, and if it does
+not end with a newline then it will be extended with some indication of
+the current location in the code, as described for L</mess_sv>.
+
+The error message or object will by default be written to standard error,
+but this is subject to modification by a C<$SIG{__WARN__}> handler.
+
+To warn with a simple string message, the L</warn> function may be
+more convenient.
 
 =cut
 */
 
 void
 
 =cut
 */
 
 void
-Perl_croak(pTHX_ const char *pat, ...)
+Perl_warn_sv(pTHX_ SV *baseex)
 {
 {
-    va_list args;
-    va_start(args, pat);
-    vcroak(pat, &args);
-    /* NOTREACHED */
-    va_end(args);
+    SV *ex = mess_sv(baseex, 0);
+    PERL_ARGS_ASSERT_WARN_SV;
+    if (!invoke_exception_hook(ex, TRUE))
+       write_to_stderr(ex);
 }
 
 }
 
+/*
+=for apidoc Am|void|vwarn|const char *pat|va_list *args
+
+This is an XS interface to Perl's C<warn> function.
+
+C<pat> and C<args> are a sprintf-style format pattern and encapsulated
+argument list.  These are used to generate a string message.  If the
+message does not end with a newline, then it will be extended with
+some indication of the current location in the code, as described for
+L</mess_sv>.
+
+The error message or object will by default be written to standard error,
+but this is subject to modification by a C<$SIG{__WARN__}> handler.
+
+Unlike with L</vcroak>, C<pat> is not permitted to be null.
+
+=cut
+*/
+
 void
 Perl_vwarn(pTHX_ const char* pat, va_list *args)
 {
 void
 Perl_vwarn(pTHX_ const char* pat, va_list *args)
 {
-    dVAR;
-    STRLEN msglen;
-    SV * const msv = vmess(pat, args);
-    const I32 utf8 = SvUTF8(msv);
-    const char * const message = SvPV_const(msv, msglen);
-
+    SV *ex = vmess(pat, args);
     PERL_ARGS_ASSERT_VWARN;
     PERL_ARGS_ASSERT_VWARN;
+    if (!invoke_exception_hook(ex, TRUE))
+       write_to_stderr(ex);
+}
 
 
-    if (PL_warnhook) {
-       if (vdie_common(message, msglen, utf8, TRUE))
-           return;
-    }
+/*
+=for apidoc Am|void|warn|const char *pat|...
 
 
-    write_to_stderr(message, msglen);
-}
+This is an XS interface to Perl's C<warn> function.
+
+Take a sprintf-style format pattern and argument list.  These are used to
+generate a string message.  If the message does not end with a newline,
+then it will be extended with some indication of the current location
+in the code, as described for L</mess_sv>.
+
+The error message or object will by default be written to standard error,
+but this is subject to modification by a C<$SIG{__WARN__}> handler.
+
+Unlike with L</croak>, C<pat> is not permitted to be null.
+
+=cut
+*/
 
 #if defined(PERL_IMPLICIT_CONTEXT)
 void
 
 #if defined(PERL_IMPLICIT_CONTEXT)
 void
@@ -1503,15 +1778,6 @@ Perl_warn_nocontext(const char *pat, ...)
 }
 #endif /* PERL_IMPLICIT_CONTEXT */
 
 }
 #endif /* PERL_IMPLICIT_CONTEXT */
 
-/*
-=for apidoc warn
-
-This is the XSUB-writer's interface to Perl's C<warn> function.  Call this
-function the same way you call the C C<printf> function.  See C<croak>.
-
-=cut
-*/
-
 void
 Perl_warn(pTHX_ const char *pat, ...)
 {
 void
 Perl_warn(pTHX_ const char *pat, ...)
 {
@@ -1536,6 +1802,32 @@ Perl_warner_nocontext(U32 err, const char *pat, ...)
 #endif /* PERL_IMPLICIT_CONTEXT */
 
 void
 #endif /* PERL_IMPLICIT_CONTEXT */
 
 void
+Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
+{
+    PERL_ARGS_ASSERT_CK_WARNER_D;
+
+    if (Perl_ckwarn_d(aTHX_ err)) {
+       va_list args;
+       va_start(args, pat);
+       vwarner(err, pat, &args);
+       va_end(args);
+    }
+}
+
+void
+Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
+{
+    PERL_ARGS_ASSERT_CK_WARNER;
+
+    if (Perl_ckwarn(aTHX_ err)) {
+       va_list args;
+       va_start(args, pat);
+       vwarner(err, pat, &args);
+       va_end(args);
+    }
+}
+
+void
 Perl_warner(pTHX_ U32  err, const char* pat,...)
 {
     va_list args;
 Perl_warner(pTHX_ U32  err, const char* pat,...)
 {
     va_list args;
@@ -1552,21 +1844,9 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
     PERL_ARGS_ASSERT_VWARNER;
     if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
        SV * const msv = vmess(pat, args);
     PERL_ARGS_ASSERT_VWARNER;
     if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
        SV * const msv = vmess(pat, args);
-       STRLEN msglen;
-       const char * const message = SvPV_const(msv, msglen);
-       const I32 utf8 = SvUTF8(msv);
 
 
-       if (PL_diehook) {
-           assert(message);
-           S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
-       }
-       if (PL_in_eval) {
-           PL_restartop = die_where(message, msglen);
-           SvFLAGS(ERRSV) |= utf8;
-           JMPENV_JUMP(3);
-       }
-       write_to_stderr(message, msglen);
-       my_failure_exit();
+       invoke_exception_hook(msv, FALSE);
+       die_unwind(msv);
     }
     else {
        Perl_vwarn(aTHX_ pat, args);
     }
     else {
        Perl_vwarn(aTHX_ pat, args);
@@ -1579,26 +1859,11 @@ bool
 Perl_ckwarn(pTHX_ U32 w)
 {
     dVAR;
 Perl_ckwarn(pTHX_ U32 w)
 {
     dVAR;
-    return
-       (
-              isLEXWARN_on
-           && PL_curcop->cop_warnings != pWARN_NONE
-           && (
-                  PL_curcop->cop_warnings == pWARN_ALL
-               || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
-               || (unpackWARN2(w) &&
-                    isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
-               || (unpackWARN3(w) &&
-                    isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
-               || (unpackWARN4(w) &&
-                    isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
-               )
-       )
-       ||
-       (
-           isLEXWARN_off && PL_dowarn & G_WARN_ON
-       )
-       ;
+    /* If lexical warnings have not been set, use $^W.  */
+    if (isLEXWARN_off)
+       return PL_dowarn & G_WARN_ON;
+
+    return ckwarn_common(w);
 }
 
 /* implements the ckWARN?_d macro */
 }
 
 /* implements the ckWARN?_d macro */
@@ -1607,22 +1872,42 @@ bool
 Perl_ckwarn_d(pTHX_ U32 w)
 {
     dVAR;
 Perl_ckwarn_d(pTHX_ U32 w)
 {
     dVAR;
-    return
-          isLEXWARN_off
-       || PL_curcop->cop_warnings == pWARN_ALL
-       || (
-             PL_curcop->cop_warnings != pWARN_NONE 
-          && (
-                  isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
-             || (unpackWARN2(w) &&
-                  isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
-             || (unpackWARN3(w) &&
-                  isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
-             || (unpackWARN4(w) &&
-                  isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
-             )
-          )
-       ;
+    /* If lexical warnings have not been set then default classes warn.  */
+    if (isLEXWARN_off)
+       return TRUE;
+
+    return ckwarn_common(w);
+}
+
+static bool
+S_ckwarn_common(pTHX_ U32 w)
+{
+    if (PL_curcop->cop_warnings == pWARN_ALL)
+       return TRUE;
+
+    if (PL_curcop->cop_warnings == pWARN_NONE)
+       return FALSE;
+
+    /* Check the assumption that at least the first slot is non-zero.  */
+    assert(unpackWARN1(w));
+
+    /* Check the assumption that it is valid to stop as soon as a zero slot is
+       seen.  */
+    if (!unpackWARN2(w)) {
+       assert(!unpackWARN3(w));
+       assert(!unpackWARN4(w));
+    } else if (!unpackWARN3(w)) {
+       assert(!unpackWARN4(w));
+    }
+       
+    /* Right, dealt with all the special cases, which are implemented as non-
+       pointers, so there is a pointer to a real warnings mask.  */
+    do {
+       if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
+           return TRUE;
+    } while (w >>= WARNshift);
+
+    return FALSE;
 }
 
 /* Set buffer=NULL to get a new one.  */
 }
 
 /* Set buffer=NULL to get a new one.  */
@@ -1667,9 +1952,16 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
 #ifndef PERL_USE_SAFE_PUTENV
     if (!PL_use_safe_putenv) {
     /* most putenv()s leak, so we manipulate environ directly */
 #ifndef PERL_USE_SAFE_PUTENV
     if (!PL_use_safe_putenv) {
     /* most putenv()s leak, so we manipulate environ directly */
-    register I32 i=setenv_getix(nam);          /* where does it go? */
+    register I32 i;
+    register const I32 len = strlen(nam);
     int nlen, vlen;
 
     int nlen, vlen;
 
+    /* where does it go? */
+    for (i = 0; environ[i]; i++) {
+        if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
+            break;
+    }
+
     if (environ == PL_origenviron) {   /* need we copy environment? */
        I32 j;
        I32 max;
     if (environ == PL_origenviron) {   /* need we copy environment? */
        I32 j;
        I32 max;
@@ -1770,32 +2062,8 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
     (void)PerlEnv_putenv(envstr);
     Safefree(envstr);
 }
     (void)PerlEnv_putenv(envstr);
     Safefree(envstr);
 }
-
-#endif /* WIN32 || NETWARE */
-
-#ifndef PERL_MICRO
-static I32
-S_setenv_getix(pTHX_ const char *nam)
-{
-    register I32 i;
-    register const I32 len = strlen(nam);
-
-    PERL_ARGS_ASSERT_SETENV_GETIX;
-    PERL_UNUSED_CONTEXT;
-
-    for (i = 0; environ[i]; i++) {
-       if (
-#ifdef WIN32
-           strnicmp(environ[i],nam,len) == 0
-#else
-           strnEQ(environ[i],nam,len)
-#endif
-           && environ[i][len] == '=')
-           break;                      /* strnEQ must come first to avoid */
-    }                                  /* potential SEGV's */
-    return i;
-}
-#endif /* !PERL_MICRO */
+
+#endif /* WIN32 || NETWARE */
 
 #endif /* !VMS && !EPOC*/
 
 
 #endif /* !VMS && !EPOC*/
 
@@ -2272,7 +2540,7 @@ Perl_my_swabn(void *ptr, int n)
 PerlIO *
 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
 {
 PerlIO *
 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
 {
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
     dVAR;
     int p[2];
     register I32 This, that;
     dVAR;
     int p[2];
     register I32 This, that;
@@ -2305,6 +2573,7 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
            }
            return NULL;
        }
            }
            return NULL;
        }
+       Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
        sleep(5);
     }
     if (pid == 0) {
        sleep(5);
     }
     if (pid == 0) {
@@ -2362,9 +2631,7 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
     else
        PerlLIO_close(p[that]);         /* close child's end of pipe */
 
     else
        PerlLIO_close(p[that]);         /* close child's end of pipe */
 
-    LOCK_FDPID_MUTEX;
     sv = *av_fetch(PL_fdpid,p[This],TRUE);
     sv = *av_fetch(PL_fdpid,p[This],TRUE);
-    UNLOCK_FDPID_MUTEX;
     SvUPGRADE(sv,SVt_IV);
     SvIV_set(sv, pid);
     PL_forkprocess = pid;
     SvUPGRADE(sv,SVt_IV);
     SvIV_set(sv, pid);
     PL_forkprocess = pid;
@@ -2410,7 +2677,7 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
 }
 
     /* VMS' my_popen() is in VMS.c, same with OS/2. */
 }
 
     /* VMS' my_popen() is in VMS.c, same with OS/2. */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
 PerlIO *
 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 {
 PerlIO *
 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 {
@@ -2450,9 +2717,10 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
                PerlLIO_close(pp[1]);
            }
            if (!doexec)
                PerlLIO_close(pp[1]);
            }
            if (!doexec)
-               Perl_croak(aTHX_ "Can't fork");
+               Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
            return NULL;
        }
            return NULL;
        }
+       Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
        sleep(5);
     }
     if (pid == 0) {
        sleep(5);
     }
     if (pid == 0) {
@@ -2530,9 +2798,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
     else
        PerlLIO_close(p[that]);
 
     else
        PerlLIO_close(p[that]);
 
-    LOCK_FDPID_MUTEX;
     sv = *av_fetch(PL_fdpid,p[This],TRUE);
     sv = *av_fetch(PL_fdpid,p[This],TRUE);
-    UNLOCK_FDPID_MUTEX;
     SvUPGRADE(sv,SVt_IV);
     SvIV_set(sv, pid);
     PL_forkprocess = pid;
     SvUPGRADE(sv,SVt_IV);
     SvIV_set(sv, pid);
     PL_forkprocess = pid;
@@ -2713,11 +2979,6 @@ dup2(int oldfd, int newfd)
 #ifndef PERL_MICRO
 #ifdef HAS_SIGACTION
 
 #ifndef PERL_MICRO
 #ifdef HAS_SIGACTION
 
-#ifdef MACOS_TRADITIONAL
-/* We don't want restart behavior on MacOS */
-#undef SA_RESTART
-#endif
-
 Sighandler_t
 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
 {
 Sighandler_t
 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
 {
@@ -2868,7 +3129,7 @@ Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
 #endif /* !PERL_MICRO */
 
     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
 #endif /* !PERL_MICRO */
 
     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
 I32
 Perl_my_pclose(pTHX_ PerlIO *ptr)
 {
 I32
 Perl_my_pclose(pTHX_ PerlIO *ptr)
 {
@@ -2879,14 +3140,9 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
     Pid_t pid;
     Pid_t pid2;
     bool close_failed;
     Pid_t pid;
     Pid_t pid2;
     bool close_failed;
-    int saved_errno = 0;
-#ifdef WIN32
-    int saved_win32_errno;
-#endif
+    dSAVEDERRNO;
 
 
-    LOCK_FDPID_MUTEX;
     svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
     svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
-    UNLOCK_FDPID_MUTEX;
     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
     SvREFCNT_dec(*svp);
     *svp = &PL_sv_undef;
     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
     SvREFCNT_dec(*svp);
     *svp = &PL_sv_undef;
@@ -2895,12 +3151,8 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
        return my_syspclose(ptr);
     }
 #endif
        return my_syspclose(ptr);
     }
 #endif
-    if ((close_failed = (PerlIO_close(ptr) == EOF))) {
-       saved_errno = errno;
-#ifdef WIN32
-       saved_win32_errno = GetLastError();
-#endif
-    }
+    close_failed = (PerlIO_close(ptr) == EOF);
+    SAVE_ERRNO;
 #ifdef UTS
     if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
 #endif
 #ifdef UTS
     if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
 #endif
@@ -2918,7 +3170,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
     rsignal_restore(SIGQUIT, &qstat);
 #endif
     if (close_failed) {
     rsignal_restore(SIGQUIT, &qstat);
 #endif
     if (close_failed) {
-       SETERRNO(saved_errno, 0);
+       RESTORE_ERRNO;
        return -1;
     }
     return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
        return -1;
     }
     return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
@@ -2933,7 +3185,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
 #endif
 #endif /* !DOSISH */
 
 #endif
 #endif /* !DOSISH */
 
-#if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
+#if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
 I32
 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 {
 I32
 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 {
@@ -3064,26 +3316,36 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
 }
 #endif
 
 }
 #endif
 
+#define PERL_REPEATCPY_LINEAR 4
 void
 void
-Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
+Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
 {
 {
-    register I32 todo;
-    register const char * const frombase = from;
-    PERL_UNUSED_CONTEXT;
-
     PERL_ARGS_ASSERT_REPEATCPY;
 
     PERL_ARGS_ASSERT_REPEATCPY;
 
-    if (len == 1) {
-       register const char c = *from;
-       while (count-- > 0)
-           *to++ = c;
-       return;
-    }
-    while (count-- > 0) {
-       for (todo = len; todo > 0; todo--) {
-           *to++ = *from++;
+    if (len == 1)
+       memset(to, *from, count);
+    else if (count) {
+       register char *p = to;
+       I32 items, linear, half;
+
+       linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
+       for (items = 0; items < linear; ++items) {
+           register const char *q = from;
+           I32 todo;
+           for (todo = len; todo > 0; todo--)
+               *p++ = *q++;
+        }
+
+       half = count / 2;
+       while (items <= half) {
+           I32 size = items * len;
+           memcpy(p, to, size);
+           p     += size;
+           items *= 2;
        }
        }
-       from = frombase;
+
+       if (count > items)
+           memcpy(p, to, (count - items) * len);
     }
 }
 
     }
 }
 
@@ -3251,26 +3513,16 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
     }
 #endif
 
     }
 #endif
 
-#ifdef MACOS_TRADITIONAL
-    if (dosearch && !strchr(scriptname, ':') &&
-       (s = PerlEnv_getenv("Commands")))
-#else
     if (dosearch && !strchr(scriptname, '/')
 #ifdef DOSISH
                 && !strchr(scriptname, '\\')
 #endif
                 && (s = PerlEnv_getenv("PATH")))
     if (dosearch && !strchr(scriptname, '/')
 #ifdef DOSISH
                 && !strchr(scriptname, '\\')
 #endif
                 && (s = PerlEnv_getenv("PATH")))
-#endif
     {
        bool seen_dot = 0;
 
        bufend = s + strlen(s);
        while (s < bufend) {
     {
        bool seen_dot = 0;
 
        bufend = s + strlen(s);
        while (s < bufend) {
-#ifdef MACOS_TRADITIONAL
-           s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
-                       ',',
-                       &len);
-#else
 #if defined(atarist) || defined(DOSISH)
            for (len = 0; *s
 #  ifdef atarist
 #if defined(atarist) || defined(DOSISH)
            for (len = 0; *s
 #  ifdef atarist
@@ -3287,17 +3539,12 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
                        ':',
                        &len);
 #endif /* ! (atarist || DOSISH) */
                        ':',
                        &len);
 #endif /* ! (atarist || DOSISH) */
-#endif /* MACOS_TRADITIONAL */
            if (s < bufend)
                s++;
            if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
                continue;       /* don't search dir with too-long name */
            if (s < bufend)
                s++;
            if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
                continue;       /* don't search dir with too-long name */
-#ifdef MACOS_TRADITIONAL
-           if (len && tmpbuf[len - 1] != ':')
-               tmpbuf[len++] = ':';
-#else
            if (len
            if (len
-#  if defined(atarist) || defined(__MINT__) || defined(DOSISH)
+#  if defined(atarist) || defined(DOSISH)
                && tmpbuf[len - 1] != '/'
                && tmpbuf[len - 1] != '\\'
 #  endif
                && tmpbuf[len - 1] != '/'
                && tmpbuf[len - 1] != '\\'
 #  endif
@@ -3305,7 +3552,6 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
                tmpbuf[len++] = '/';
            if (len == 2 && tmpbuf[0] == '.')
                seen_dot = 1;
                tmpbuf[len++] = '/';
            if (len == 2 && tmpbuf[0] == '.')
                seen_dot = 1;
-#endif
            (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
 #endif  /* !VMS */
 
            (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
 #endif  /* !VMS */
 
@@ -3330,7 +3576,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
                continue;
            if (S_ISREG(PL_statbuf.st_mode)
                && cando(S_IRUSR,TRUE,&PL_statbuf)
                continue;
            if (S_ISREG(PL_statbuf.st_mode)
                && cando(S_IRUSR,TRUE,&PL_statbuf)
-#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
+#if !defined(DOSISH)
                && cando(S_IXUSR,TRUE,&PL_statbuf)
 #endif
                )
                && cando(S_IXUSR,TRUE,&PL_statbuf)
 #endif
                )
@@ -3618,113 +3864,196 @@ 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);
-       }
+Perl_report_wrongway_fh(pTHX_ const GV *gv, 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 (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;
+}
+
+void
+Perl_report_evil_fh(pTHX_ const GV *gv)
+{
+    const IO *io = gv ? GvIO(gv) : NULL;
+    const PERL_BITFIELD16 op = PL_op->op_type;
+    const char *vile;
+    I32 warn_type;
 
 
-       if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
-           vile = "closed";
-           warn_type = WARN_CLOSED;
+    if (io && IoTYPE(io) == IoTYPE_CLOSED) {
+       vile = "closed";
+       warn_type = WARN_CLOSED;
+    }
+    else {
+       vile = "unopened";
+       warn_type = WARN_UNOPENED;
+    }
+
+    if (ckWARN(warn_type)) {
+       const char * const name
+           = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
+       const char * const pars =
+           (const char *)(OP_IS_FILETEST(op) ? "" : "()");
+       const char * const func =
+           (const char *)
+           (op == OP_READLINE   ? "readline"  :        /* "<HANDLE>" not nice */
+            op == OP_LEAVEWRITE ? "write" :            /* "write exit" not nice */
+            PL_op_desc[op]);
+       const char * const type =
+           (const char *)
+           (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
+            ? "socket" : "filehandle");
+       if (name && *name) {
+           Perl_warner(aTHX_ packWARN(warn_type),
+                       "%s%s on %s %s %s", func, pars, vile, type, name);
+           if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+               Perl_warner(
+                           aTHX_ packWARN(warn_type),
+                           "\t(Are you trying to call %s%s on dirhandle %s?)\n",
+                           func, pars, name
+                           );
        }
        else {
        }
        else {
-           vile = "unopened";
-           warn_type = WARN_UNOPENED;
+           Perl_warner(aTHX_ packWARN(warn_type),
+                       "%s%s on %s %s", func, pars, vile, type);
+           if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+               Perl_warner(
+                           aTHX_ packWARN(warn_type),
+                           "\t(Are you trying to call %s%s on dirhandle?)\n",
+                           func, pars
+                           );
        }
        }
+    }
+}
 
 
-       if (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
-                   );
+/* 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)
+{
+
+    U8 result;
+
+    if (! isASCII(source)) {
+       Perl_croak(aTHX_ "Character following \"\\c\" must be ASCII");
+    }
+
+    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) {
+           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);
        }
     }
        }
     }
+
+    return result;
 }
 
 }
 
-#ifdef EBCDIC
-/* in ASCII order, not that it matters */
-static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
+bool
+Perl_grok_bslash_o(pTHX_ const char *s,
+                        UV *uv,
+                        STRLEN *len,
+                        const char** error_msg,
+                        const bool output_warning)
+{
+
+/*  Documentation to be supplied when interface nailed down finally
+ *  This returns FALSE if there is an error which the caller need not recover
+ *  from; , otherwise TRUE.  In either case the caller should look at *len
+ *  On input:
+ *     s   points to a string that begins with 'o', and the previous character
+ *         was a backslash.
+ *     uv  points to a UV that will hold the output value, valid only if the
+ *         return from the function is TRUE
+ *     len on success will point to the next character in the string past the
+ *                    end of this construct.
+ *         on failure, it will point to the failure
+ *      error_msg is a pointer that will be set to an internal buffer giving an
+ *         error message upon failure (the return is FALSE).  Untouched if
+ *         function succeeds
+ *     output_warning says whether to output any warning messages, or suppress
+ *         them
+ */
+    const char* e;
+    STRLEN numbers_len;
+    I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
+               | PERL_SCAN_DISALLOW_PREFIX
+               /* XXX Until the message is improved in grok_oct, handle errors
+                * ourselves */
+               | PERL_SCAN_SILENT_ILLDIGIT;
 
 
-int
-Perl_ebcdic_control(pTHX_ int ch)
-{
-    if (ch > 'a') {
-       const char *ctlp;
+    PERL_ARGS_ASSERT_GROK_BSLASH_O;
 
 
-       if (islower(ch))
-           ch = toupper(ch);
 
 
-       if ((ctlp = strchr(controllablechars, ch)) == 0) {
-           Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
-       }
+    assert(*s == 'o');
+    s++;
 
 
-       if (ctlp == controllablechars)
-           return('\177'); /* DEL */
-       else
-           return((unsigned char)(ctlp - controllablechars - 1));
-    } else { /* Want uncontrol */
-       if (ch == '\177' || ch == -1)
-           return('?');
-       else if (ch == '\157')
-           return('\177');
-       else if (ch == '\174')
-           return('\000');
-       else if (ch == '^')    /* '\137' in 1047, '\260' in 819 */
-           return('\036');
-       else if (ch == '\155')
-           return('\037');
-       else if (0 < ch && ch < (sizeof(controllablechars) - 1))
-           return(controllablechars[ch+1]);
-       else
-           Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
+    if (*s != '{') {
+       *len = 1;       /* Move past the o */
+       *error_msg = "Missing braces on \\o{}";
+       return FALSE;
+    }
+
+    e = strchr(s, '}');
+    if (!e) {
+       *len = 2;       /* Move past the o{ */
+       *error_msg = "Missing right brace on \\o{";
+       return FALSE;
+    }
+
+    /* Return past the '}' no matter what is inside the braces */
+    *len = e - s + 2;  /* 2 = 1 for the o + 1 for the '}' */
+
+    s++;    /* Point to first digit */
+
+    numbers_len = e - s;
+    if (numbers_len == 0) {
+       *error_msg = "Number with no digits";
+       return FALSE;
+    }
+
+    *uv = NATIVE_TO_UNI(grok_oct(s, &numbers_len, &flags, NULL));
+    /* Note that if has non-octal, will ignore everything starting with that up
+     * to the '}' */
+
+    if (output_warning && numbers_len != (STRLEN) (e - s)) {
+       Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
+       /* diag_listed_as: Non-octal character '%c'.  Resolved as "%s" */
+                      "Non-octal character '%c'.  Resolved as \"\\o{%.*s}\"",
+                      *(s + numbers_len),
+                      (int) numbers_len,
+                      s);
     }
     }
+
+    return TRUE;
 }
 }
-#endif
 
 /* To workaround core dumps from the uninitialised tm_zone we get the
  * system to give us a reasonable struct to copy.  This fix means that
 
 /* To workaround core dumps from the uninitialised tm_zone we get the
  * system to give us a reasonable struct to copy.  This fix means that
@@ -3846,7 +4175,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
@@ -4025,7 +4354,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)
@@ -4122,6 +4451,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 
     for (;;) {
        DIR *dir;
 
     for (;;) {
        DIR *dir;
+       int namelen;
        odev = cdev;
        oino = cino;
 
        odev = cdev;
        oino = cino;
 
@@ -4144,9 +4474,9 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 
        while ((dp = PerlDir_read(dir)) != NULL) {
 #ifdef DIRNAMLEN
 
        while ((dp = PerlDir_read(dir)) != NULL) {
 #ifdef DIRNAMLEN
-           const int namelen = dp->d_namlen;
+           namelen = dp->d_namlen;
 #else
 #else
-           const int namelen = strlen(dp->d_name);
+           namelen = strlen(dp->d_name);
 #endif
            /* skip . and .. */
            if (SV_CWD_ISDOT(dp)) {
 #endif
            /* skip . and .. */
            if (SV_CWD_ISDOT(dp)) {
@@ -4223,6 +4553,215 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 }
 
 #define VERSION_MAX 0x7FFFFFFF
 }
 
 #define VERSION_MAX 0x7FFFFFFF
+
+/*
+=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 *
+Perl_prescan_version(pTHX_ const char *s, bool strict,
+                    const char **errstr,
+                    bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
+    bool qv = (sqv ? *sqv : FALSE);
+    int width = 3;
+    int saw_decimal = 0;
+    bool alpha = FALSE;
+    const char *d = s;
+
+    PERL_ARGS_ASSERT_PRESCAN_VERSION;
+
+    if (qv && isDIGIT(*d))
+       goto dotted_decimal_version;
+
+    if (*d == 'v') { /* explicit v-string */
+       d++;
+       if (isDIGIT(*d)) {
+           qv = TRUE;
+       }
+       else { /* degenerate v-string */
+           /* requires v1.2.3 */
+           BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+       }
+
+dotted_decimal_version:
+       if (strict && d[0] == '0' && isDIGIT(d[1])) {
+           /* no leading zeros allowed */
+           BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
+       }
+
+       while (isDIGIT(*d))     /* integer part */
+           d++;
+
+       if (*d == '.')
+       {
+           saw_decimal++;
+           d++;                /* decimal point */
+       }
+       else
+       {
+           if (strict) {
+               /* require v1.2.3 */
+               BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+           }
+           else {
+               goto version_prescan_finish;
+           }
+       }
+
+       {
+           int i = 0;
+           int j = 0;
+           while (isDIGIT(*d)) {       /* just keep reading */
+               i++;
+               while (isDIGIT(*d)) {
+                   d++; j++;
+                   /* maximum 3 digits between decimal */
+                   if (strict && j > 3) {
+                       BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
+                   }
+               }
+               if (*d == '_') {
+                   if (strict) {
+                       BADVERSION(s,errstr,"Invalid version format (no underscores)");
+                   }
+                   if ( alpha ) {
+                       BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
+                   }
+                   d++;
+                   alpha = TRUE;
+               }
+               else if (*d == '.') {
+                   if (alpha) {
+                       BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
+                   }
+                   saw_decimal++;
+                   d++;
+               }
+               else if (!isDIGIT(*d)) {
+                   break;
+               }
+               j = 0;
+           }
+
+           if (strict && i < 2) {
+               /* requires v1.2.3 */
+               BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+           }
+       }
+    }                                  /* end if dotted-decimal */
+    else
+    {                                  /* decimal versions */
+       /* special strict case for leading '.' or '0' */
+       if (strict) {
+           if (*d == '.') {
+               BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
+           }
+           if (*d == '0' && isDIGIT(d[1])) {
+               BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
+           }
+       }
+
+       /* consume all of the integer part */
+       while (isDIGIT(*d))
+           d++;
+
+       /* look for a fractional part */
+       if (*d == '.') {
+           /* we found it, so consume it */
+           saw_decimal++;
+           d++;
+       }
+       else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
+           if ( d == s ) {
+               /* found nothing */
+               BADVERSION(s,errstr,"Invalid version format (version required)");
+           }
+           /* found just an integer */
+           goto version_prescan_finish;
+       }
+       else if ( d == s ) {
+           /* didn't find either integer or period */
+           BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+       }
+       else if (*d == '_') {
+           /* underscore can't come after integer part */
+           if (strict) {
+               BADVERSION(s,errstr,"Invalid version format (no underscores)");
+           }
+           else if (isDIGIT(d[1])) {
+               BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
+           }
+           else {
+               BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
+           }
+       }
+       else {
+           /* anything else after integer part is just invalid data */
+           BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+       }
+
+       /* scan the fractional part after the decimal point*/
+
+       if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
+               /* strict or lax-but-not-the-end */
+               BADVERSION(s,errstr,"Invalid version format (fractional part required)");
+       }
+
+       while (isDIGIT(*d)) {
+           d++;
+           if (*d == '.' && isDIGIT(d[-1])) {
+               if (alpha) {
+                   BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
+               }
+               if (strict) {
+                   BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
+               }
+               d = (char *)s;          /* start all over again */
+               qv = TRUE;
+               goto dotted_decimal_version;
+           }
+           if (*d == '_') {
+               if (strict) {
+                   BADVERSION(s,errstr,"Invalid version format (no underscores)");
+               }
+               if ( alpha ) {
+                   BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
+               }
+               if ( ! isDIGIT(d[1]) ) {
+                   BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
+               }
+               d++;
+               alpha = TRUE;
+           }
+       }
+    }
+
+version_prescan_finish:
+    while (isSPACE(*d))
+       d++;
+
+    if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
+       /* trailing non-numeric data */
+       BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+    }
+
+    if (sqv)
+       *sqv = qv;
+    if (swidth)
+       *swidth = width;
+    if (ssaw_decimal)
+       *ssaw_decimal = saw_decimal;
+    if (salpha)
+       *salpha = alpha;
+    return d;
+}
+
 /*
 =for apidoc scan_version
 
 /*
 =for apidoc scan_version
 
@@ -4251,9 +4790,10 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     const char *start;
     const char *pos;
     const char *last;
     const char *start;
     const char *pos;
     const char *last;
-    int saw_period = 0;
-    int alpha = 0;
+    const char *errstr = NULL;
+    int saw_decimal = 0;
     int width = 3;
     int width = 3;
+    bool alpha = FALSE;
     bool vinf = FALSE;
     AV * const av = newAV();
     SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
     bool vinf = FALSE;
     AV * const av = newAV();
     SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
@@ -4262,48 +4802,24 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
 
     (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
 
 
     (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
 
+#ifndef NODEFAULT_SHAREKEYS
+    HvSHAREKEYS_on(hv);         /* key-sharing on by default */
+#endif
+
     while (isSPACE(*s)) /* leading whitespace is OK */
        s++;
 
     while (isSPACE(*s)) /* leading whitespace is OK */
        s++;
 
-    start = last = s;
-
-    if (*s == 'v') {
-       s++;  /* get past 'v' */
-       qv = 1; /* force quoted version processing */
-    }
-
-    pos = s;
-
-    /* pre-scan the input string to check for decimals/underbars */
-    while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
-    {
-       if ( *pos == '.' )
-       {
-           if ( alpha )
-               Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
-           saw_period++ ;
-           last = pos;
+    last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
+    if (errstr) {
+       /* "undef" is a special case and not an error */
+       if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
+           Perl_croak(aTHX_ "%s", errstr);
        }
        }
-       else if ( *pos == '_' )
-       {
-           if ( alpha )
-               Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
-           alpha = 1;
-           width = pos - last - 1; /* natural width of sub-version */
-       }
-       pos++;
     }
 
     }
 
-    if ( alpha && !saw_period )
-       Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
-
-    if ( alpha && saw_period && width == 0 )
-       Perl_croak(aTHX_ "Invalid version format (misplaced _ in number)");
-
-    if ( saw_period > 1 )
-       qv = 1; /* force quoted version processing */
-
-    last = pos;
+    start = s;
+    if (*s == 'v')
+       s++;
     pos = s;
 
     if ( qv )
     pos = s;
 
     if ( qv )
@@ -4330,7 +4846,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
                 * point of a version originally created with a bare
                 * floating point number, i.e. not quoted in any way
                 */
                 * point of a version originally created with a bare
                 * floating point number, i.e. not quoted in any way
                 */
-               if ( !qv && s > start && saw_period == 1 ) {
+               if ( !qv && s > start && saw_decimal == 1 ) {
                    mult *= 100;
                    while ( s < end ) {
                        orev = rev;
                    mult *= 100;
                    while ( s < end ) {
                        orev = rev;
@@ -4338,9 +4854,8 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
                        mult /= 10;
                        if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
                            || (PERL_ABS(rev) > VERSION_MAX )) {
                        mult /= 10;
                        if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
                            || (PERL_ABS(rev) > VERSION_MAX )) {
-                           if(ckWARN(WARN_OVERFLOW))
-                               Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), 
-                               "Integer overflow in version %d",VERSION_MAX);
+                           Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
+                                          "Integer overflow in version %d",VERSION_MAX);
                            s = end - 1;
                            rev = VERSION_MAX;
                            vinf = 1;
                            s = end - 1;
                            rev = VERSION_MAX;
                            vinf = 1;
@@ -4357,9 +4872,8 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
                        mult *= 10;
                        if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
                            || (PERL_ABS(rev) > VERSION_MAX )) {
                        mult *= 10;
                        if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
                            || (PERL_ABS(rev) > VERSION_MAX )) {
-                           if(ckWARN(WARN_OVERFLOW))
-                               Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), 
-                               "Integer overflow in version");
+                           Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
+                                          "Integer overflow in version");
                            end = s - 1;
                            rev = VERSION_MAX;
                            vinf = 1;
                            end = s - 1;
                            rev = VERSION_MAX;
                            vinf = 1;
@@ -4378,6 +4892,8 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
                s = ++pos;
            else if ( *pos == '_' && isDIGIT(pos[1]) )
                s = ++pos;
                s = ++pos;
            else if ( *pos == '_' && isDIGIT(pos[1]) )
                s = ++pos;
+           else if ( *pos == ',' && isDIGIT(pos[1]) )
+               s = ++pos;
            else if ( isDIGIT(*pos) )
                s = pos;
            else {
            else if ( isDIGIT(*pos) )
                s = pos;
            else {
@@ -4420,7 +4936,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     }
     else if ( s > start ) {
        SV * orig = newSVpvn(start,s-start);
     }
     else if ( s > start ) {
        SV * orig = newSVpvn(start,s-start);
-       if ( qv && saw_period == 1 && *start != 'v' ) {
+       if ( qv && saw_decimal == 1 && *start != 'v' ) {
            /* need to insert a v to be consistent */
            sv_insert(orig, 0, 0, "v", 1);
        }
            /* need to insert a v to be consistent */
            sv_insert(orig, 0, 0, "v", 1);
        }
@@ -4469,6 +4985,9 @@ Perl_new_version(pTHX_ SV *ver)
        /* This will get reblessed later if a derived class*/
        SV * const hv = newSVrv(rv, "version"); 
        (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
        /* This will get reblessed later if a derived class*/
        SV * const hv = newSVrv(rv, "version"); 
        (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
+#ifndef NODEFAULT_SHAREKEYS
+       HvSHAREKEYS_on(hv);         /* key-sharing on by default */
+#endif
 
        if ( SvROK(ver) )
            ver = SvRV(ver);
 
        if ( SvROK(ver) )
            ver = SvRV(ver);
@@ -4511,7 +5030,7 @@ Perl_new_version(pTHX_ SV *ver)
            char * const version = savepvn( (const char*)mg->mg_ptr, len);
            sv_setpvn(rv,version,len);
            /* this is for consistency with the pure Perl class */
            char * const version = savepvn( (const char*)mg->mg_ptr, len);
            sv_setpvn(rv,version,len);
            /* this is for consistency with the pure Perl class */
-           if ( *version != 'v' ) 
+           if ( isDIGIT(*version) )
                sv_insert(rv, 0, 0, "v", 1);
            Safefree(version);
        }
                sv_insert(rv, 0, 0, "v", 1);
            Safefree(version);
        }
@@ -4566,7 +5085,7 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 #ifdef SvVOK
     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
        version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
 #ifdef SvVOK
     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
        version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
-       qv = 1;
+       qv = TRUE;
     }
 #endif
     else /* must be a string or something like a string */
     }
 #endif
     else /* must be a string or something like a string */
@@ -4576,27 +5095,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,"_") ) {
+       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_period = 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_period++ ;
-               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_period == 2 ) {    
-               Safefree(version);
-               version = nver;
+                   /* is definitely a v-string */
+                   if ( saw_decimal >= 2 ) {   
+                       Safefree(version);
+                       version = nver;
+                   }
+                   break;
+               }
            }
        }
 #  endif
            }
        }
 #  endif
@@ -4605,10 +5132,9 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 
     s = scan_version(version, ver, qv);
     if ( *s != '\0' ) 
 
     s = scan_version(version, ver, qv);
     if ( *s != '\0' ) 
-       if(ckWARN(WARN_MISC))
-           Perl_warner(aTHX_ packWARN(WARN_MISC), 
-               "Version string '%s' contains invalid data; "
-               "ignoring: '%s'", version, s);
+       Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 
+                      "Version string '%s' contains invalid data; "
+                      "ignoring: '%s'", version, s);
     Safefree(version);
     return ver;
 }
     Safefree(version);
     return ver;
 }
@@ -4616,27 +5142,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;
@@ -4651,9 +5180,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;
 }
 
 /*
 }
 
 /*
@@ -4667,6 +5196,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
 */
 
@@ -4676,15 +5207,14 @@ Perl_vnumify(pTHX_ SV *vs)
     I32 i, len, digit;
     int width;
     bool alpha = FALSE;
     I32 i, len, digit;
     int width;
     bool alpha = FALSE;
-    SV * const sv = newSV(0);
+    SV *sv;
     AV *av;
 
     PERL_ARGS_ASSERT_VNUMIFY;
 
     AV *av;
 
     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 */
@@ -4698,19 +5228,17 @@ Perl_vnumify(pTHX_ SV *vs)
 
     /* attempt to retrieve the version array */
     if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
 
     /* attempt to retrieve the version array */
     if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
-       sv_catpvs(sv,"0");
-       return sv;
+       return newSVpvs("0");
     }
 
     len = av_len(av);
     if ( len == -1 )
     {
     }
 
     len = av_len(av);
     if ( len == -1 )
     {
-       sv_catpvs(sv,"0");
-       return sv;
+       return newSVpvs("0");
     }
 
     digit = SvIV(*av_fetch(av, 0, 0));
     }
 
     digit = SvIV(*av_fetch(av, 0, 0));
-    Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
+    sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
     for ( i = 1 ; i < len ; i++ )
     {
        digit = SvIV(*av_fetch(av, i, 0));
     for ( i = 1 ; i < len ; i++ )
     {
        digit = SvIV(*av_fetch(av, i, 0));
@@ -4749,6 +5277,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
 */
 
@@ -4757,15 +5287,14 @@ Perl_vnormal(pTHX_ SV *vs)
 {
     I32 i, len, digit;
     bool alpha = FALSE;
 {
     I32 i, len, digit;
     bool alpha = FALSE;
-    SV * const sv = newSV(0);
+    SV *sv;
     AV *av;
 
     PERL_ARGS_ASSERT_VNORMAL;
 
     AV *av;
 
     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 ) )
@@ -4775,11 +5304,10 @@ Perl_vnormal(pTHX_ SV *vs)
     len = av_len(av);
     if ( len == -1 )
     {
     len = av_len(av);
     if ( len == -1 )
     {
-       sv_catpvs(sv,"");
-       return sv;
+       return newSVpvs("");
     }
     digit = SvIV(*av_fetch(av, 0, 0));
     }
     digit = SvIV(*av_fetch(av, 0, 0));
-    Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
+    sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
     for ( i = 1 ; i < len ; i++ ) {
        digit = SvIV(*av_fetch(av, i, 0));
        Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
     for ( i = 1 ; i < len ; i++ ) {
        digit = SvIV(*av_fetch(av, i, 0));
        Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
@@ -4808,7 +5336,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
 */
@@ -4818,10 +5348,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)) {
@@ -4861,15 +5390,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 */
@@ -5069,12 +5593,12 @@ S_socketpair_udp (int fd[2]) {
     errno = ECONNABORTED;
   tidy_up_and_fail:
     {
     errno = ECONNABORTED;
   tidy_up_and_fail:
     {
-       const int save_errno = errno;
+       dSAVE_ERRNO;
        if (sockets[0] != -1)
            PerlLIO_close(sockets[0]);
        if (sockets[1] != -1)
            PerlLIO_close(sockets[1]);
        if (sockets[0] != -1)
            PerlLIO_close(sockets[0]);
        if (sockets[1] != -1)
            PerlLIO_close(sockets[1]);
-       errno = save_errno;
+       RESTORE_ERRNO;
        return -1;
     }
 }
        return -1;
     }
 }
@@ -5173,14 +5697,14 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
 #endif
   tidy_up_and_fail:
     {
 #endif
   tidy_up_and_fail:
     {
-       const int save_errno = errno;
+       dSAVE_ERRNO;
        if (listener != -1)
            PerlLIO_close(listener);
        if (connector != -1)
            PerlLIO_close(connector);
        if (acceptor != -1)
            PerlLIO_close(acceptor);
        if (listener != -1)
            PerlLIO_close(listener);
        if (connector != -1)
            PerlLIO_close(connector);
        if (acceptor != -1)
            PerlLIO_close(acceptor);
-       errno = save_errno;
+       RESTORE_ERRNO;
        return -1;
     }
 }
        return -1;
     }
 }
@@ -5249,8 +5773,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++) {
@@ -5276,9 +5803,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);
+                     }
                 }
            }
        }
                 }
            }
        }
@@ -5286,6 +5816,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));
@@ -5403,7 +5935,7 @@ Perl_get_hash_seed(pTHX)
           * help.  Sum in another random number that will
           * fill in the low bits. */
          myseed +=
           * help.  Sum in another random number that will
           * fill in the low bits. */
          myseed +=
-              (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
+              (UV)(Drand01() * (NV)((((UV)1) << ((UVSIZE * 8 - RANDBITS))) - 1));
 #endif /* RANDBITS < (UVSIZE * 8) */
          if (myseed == 0) { /* Superparanoia. */
              myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
 #endif /* RANDBITS < (UVSIZE * 8) */
          if (myseed == 0) { /* Superparanoia. */
              myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
@@ -5517,38 +6049,35 @@ Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
 
 #ifdef PERL_MEM_LOG
 
 
 #ifdef PERL_MEM_LOG
 
-/*
- * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled.
+/* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
+ * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
+ * given, and you supply your own implementation.
  *
  *
- * PERL_MEM_LOG_ENV: if defined, during run time the environment
- * variables PERL_MEM_LOG and PERL_SV_LOG will be consulted, and
- * if the integer value of that is true, the logging will happen.
- * (The default is to always log if the PERL_MEM_LOG define was
- * in effect.)
+ * The default implementation reads a single env var, PERL_MEM_LOG,
+ * expecting one or more of the following:
  *
  *
- * PERL_MEM_LOG_TIMESTAMP: if defined, a timestamp will be logged
- * before every memory logging entry. This can be turned off at run
- * time by setting the environment variable PERL_MEM_LOG_TIMESTAMP
- * to zero.
+ *    \d+ - fd         fd to write to          : must be 1st (atoi)
+ *    'm' - memlog     was PERL_MEM_LOG=1
+ *    's' - svlog      was PERL_SV_LOG=1
+ *    't' - timestamp  was PERL_MEM_LOG_TIMESTAMP=1
+ *
+ * This makes the logger controllable enough that it can reasonably be
+ * added to the system perl.
  */
 
  */
 
-/*
- * PERL_MEM_LOG_SPRINTF_BUF_SIZE: size of a (stack-allocated) buffer
+/* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
  * the Perl_mem_log_...() will use (either via sprintf or snprintf).
  */
 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
 
  * the Perl_mem_log_...() will use (either via sprintf or snprintf).
  */
 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
 
-/*
- * PERL_MEM_LOG_FD: the file descriptor the Perl_mem_log_...() will
- * log to.  You can also define in compile time PERL_MEM_LOG_ENV_FD,
- * in which case the environment variable PERL_MEM_LOG_FD will be
- * consulted for the file descriptor number to use.
+/* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
+ * writes to.  In the default logger, this is settable at runtime.
  */
 #ifndef PERL_MEM_LOG_FD
 #  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
 #endif
 
  */
 #ifndef PERL_MEM_LOG_FD
 #  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
 #endif
 
-#ifdef PERL_MEM_LOG_STDERR
+#ifndef PERL_MEM_LOG_NOIMPL
 
 # ifdef DEBUG_LEAKING_SCALARS
 #   define SV_LOG_SERIAL_FMT       " [%lu]"
 
 # ifdef DEBUG_LEAKING_SCALARS
 #   define SV_LOG_SERIAL_FMT       " [%lu]"
@@ -5559,23 +6088,25 @@ Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
 # endif
 
 static void
 # endif
 
 static void
-S_mem_log_common(enum mem_log_type mlt, const UV n, const UV typesize, const char *type_name, const SV *sv, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
+S_mem_log_common(enum mem_log_type mlt, const UV n, 
+                const UV typesize, const char *type_name, const SV *sv,
+                Malloc_t oldalloc, Malloc_t newalloc,
+                const char *filename, const int linenumber,
+                const char *funcname)
 {
 {
-# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
-    const char *s;
-# endif
+    const char *pmlenv;
 
     PERL_ARGS_ASSERT_MEM_LOG_COMMON;
 
 
     PERL_ARGS_ASSERT_MEM_LOG_COMMON;
 
-# ifdef PERL_MEM_LOG_ENV
-    s = PerlEnv_getenv(mlt < MLT_NEW_SV ? "PERL_MEM_LOG" : "PERL_SV_LOG");
-    if (s ? atoi(s) : 0)
-# endif
+    pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
+    if (!pmlenv)
+       return;
+    if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
     {
        /* We can't use SVs or PerlIO for obvious reasons,
         * so we'll use stdio and low-level IO instead. */
        char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
     {
        /* We can't use SVs or PerlIO for obvious reasons,
         * so we'll use stdio and low-level IO instead. */
        char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
-# ifdef PERL_MEM_LOG_TIMESTAMP
+
 #   ifdef HAS_GETTIMEOFDAY
 #     define MEM_LOG_TIME_FMT  "%10d.%06d: "
 #     define MEM_LOG_TIME_ARG  (int)tv.tv_sec, (int)tv.tv_usec
 #   ifdef HAS_GETTIMEOFDAY
 #     define MEM_LOG_TIME_FMT  "%10d.%06d: "
 #     define MEM_LOG_TIME_ARG  (int)tv.tv_sec, (int)tv.tv_usec
@@ -5588,27 +6119,20 @@ S_mem_log_common(enum mem_log_type mlt, const UV n, const UV typesize, const cha
         (void)time(&when);
 #   endif
        /* If there are other OS specific ways of hires time than
         (void)time(&when);
 #   endif
        /* If there are other OS specific ways of hires time than
-        * gettimeofday() (see ext/Time/HiRes), the easiest way is
+        * gettimeofday() (see ext/Time-HiRes), the easiest way is
         * probably that they would be used to fill in the struct
         * timeval. */
         * probably that they would be used to fill in the struct
         * timeval. */
-# endif
        {
        {
-           int fd = PERL_MEM_LOG_FD;
            STRLEN len;
            STRLEN len;
+           int fd = atoi(pmlenv);
+           if (!fd)
+               fd = PERL_MEM_LOG_FD;
 
 
-# ifdef PERL_MEM_LOG_ENV_FD
-           if ((s = PerlEnv_getenv("PERL_MEM_LOG_FD"))) {
-               fd = atoi(s);
-           }
-# endif
-# ifdef PERL_MEM_LOG_TIMESTAMP
-           s = PerlEnv_getenv("PERL_MEM_LOG_TIMESTAMP");
-           if (!s || atoi(s)) {
+           if (strchr(pmlenv, 't')) {
                len = my_snprintf(buf, sizeof(buf),
                                MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
                PerlLIO_write(fd, buf, len);
            }
                len = my_snprintf(buf, sizeof(buf),
                                MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
                PerlLIO_write(fd, buf, len);
            }
-# endif
            switch (mlt) {
            case MLT_ALLOC:
                len = my_snprintf(buf, sizeof(buf),
            switch (mlt) {
            case MLT_ALLOC:
                len = my_snprintf(buf, sizeof(buf),
@@ -5639,54 +6163,78 @@ S_mem_log_common(enum mem_log_type mlt, const UV n, const UV typesize, const cha
                        filename, linenumber, funcname,
                        PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
                break;
                        filename, linenumber, funcname,
                        PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
                break;
+           default:
+               len = 0;
            }
            PerlLIO_write(fd, buf, len);
        }
     }
 }
            }
            PerlLIO_write(fd, buf, len);
        }
     }
 }
+#endif /* !PERL_MEM_LOG_NOIMPL */
+
+#ifndef PERL_MEM_LOG_NOIMPL
+# define \
+    mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
+    mem_log_common   (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
+#else
+/* this is suboptimal, but bug compatible.  User is providing their
+   own implementation, but is getting these functions anyway, and they
+   do nothing. But _NOIMPL users should be able to cope or fix */
+# define \
+    mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
+    /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
 #endif
 
 Malloc_t
 #endif
 
 Malloc_t
-Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
-{
-#ifdef PERL_MEM_LOG_STDERR
-    mem_log_common(MLT_ALLOC, n, typesize, type_name, NULL, NULL, newalloc, filename, linenumber, funcname);
-#endif
+Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
+                  Malloc_t newalloc, 
+                  const char *filename, const int linenumber,
+                  const char *funcname)
+{
+    mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
+                     NULL, NULL, newalloc,
+                     filename, linenumber, funcname);
     return newalloc;
 }
 
 Malloc_t
     return newalloc;
 }
 
 Malloc_t
-Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
-{
-#ifdef PERL_MEM_LOG_STDERR
-    mem_log_common(MLT_REALLOC, n, typesize, type_name, NULL, oldalloc, newalloc, filename, linenumber, funcname);
-#endif
+Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
+                    Malloc_t oldalloc, Malloc_t newalloc, 
+                    const char *filename, const int linenumber, 
+                    const char *funcname)
+{
+    mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
+                     NULL, oldalloc, newalloc, 
+                     filename, linenumber, funcname);
     return newalloc;
 }
 
 Malloc_t
     return newalloc;
 }
 
 Malloc_t
-Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
+Perl_mem_log_free(Malloc_t oldalloc, 
+                 const char *filename, const int linenumber, 
+                 const char *funcname)
 {
 {
-#ifdef PERL_MEM_LOG_STDERR
-    mem_log_common(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, filename, linenumber, funcname);
-#endif
+    mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, 
+                     filename, linenumber, funcname);
     return oldalloc;
 }
 
 void
     return oldalloc;
 }
 
 void
-Perl_mem_log_new_sv(const SV *sv, const char *filename, const int linenumber, const char *funcname)
+Perl_mem_log_new_sv(const SV *sv, 
+                   const char *filename, const int linenumber,
+                   const char *funcname)
 {
 {
-#ifdef PERL_MEM_LOG_STDERR
-    mem_log_common(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL, filename, linenumber, funcname);
-#endif
+    mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
+                     filename, linenumber, funcname);
 }
 
 void
 }
 
 void
-Perl_mem_log_del_sv(const SV *sv, const char *filename, const int linenumber, const char *funcname)
+Perl_mem_log_del_sv(const SV *sv,
+                   const char *filename, const int linenumber, 
+                   const char *funcname)
 {
 {
-#ifdef PERL_MEM_LOG_STDERR
-    mem_log_common(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL, filename, linenumber, funcname);
-#endif
+    mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL, 
+                     filename, linenumber, funcname);
 }
 
 #endif /* PERL_MEM_LOG */
 }
 
 #endif /* PERL_MEM_LOG */
@@ -5858,9 +6406,13 @@ Perl_my_cxt_init(pTHX_ int *index, size_t size)
     PERL_ARGS_ASSERT_MY_CXT_INIT;
     if (*index == -1) {
        /* this module hasn't been allocated an index yet */
     PERL_ARGS_ASSERT_MY_CXT_INIT;
     if (*index == -1) {
        /* this module hasn't been allocated an index yet */
+#if defined(USE_ITHREADS)
        MUTEX_LOCK(&PL_my_ctx_mutex);
        MUTEX_LOCK(&PL_my_ctx_mutex);
+#endif
        *index = PL_my_cxt_index++;
        *index = PL_my_cxt_index++;
+#if defined(USE_ITHREADS)
        MUTEX_UNLOCK(&PL_my_ctx_mutex);
        MUTEX_UNLOCK(&PL_my_ctx_mutex);
+#endif
     }
     
     /* make sure the array is big enough */
     }
     
     /* make sure the array is big enough */
@@ -5915,9 +6467,13 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
     index = Perl_my_cxt_index(aTHX_ my_cxt_key);
     if (index == -1) {
        /* this module hasn't been allocated an index yet */
     index = Perl_my_cxt_index(aTHX_ my_cxt_key);
     if (index == -1) {
        /* this module hasn't been allocated an index yet */
+#if defined(USE_ITHREADS)
        MUTEX_LOCK(&PL_my_ctx_mutex);
        MUTEX_LOCK(&PL_my_ctx_mutex);
+#endif
        index = PL_my_cxt_index++;
        index = PL_my_cxt_index++;
+#if defined(USE_ITHREADS)
        MUTEX_UNLOCK(&PL_my_ctx_mutex);
        MUTEX_UNLOCK(&PL_my_ctx_mutex);
+#endif
     }
 
     /* make sure the array is big enough */
     }
 
     /* make sure the array is big enough */
@@ -5950,6 +6506,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)
@@ -5994,21 +6628,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));
@@ -6026,6 +6667,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
@@ -6047,17 +6689,14 @@ Perl_my_dirfd(pTHX_ DIR * dir) {
 
 REGEXP *
 Perl_get_re_arg(pTHX_ SV *sv) {
 
 REGEXP *
 Perl_get_re_arg(pTHX_ SV *sv) {
-    SV    *tmpsv;
 
     if (sv) {
         if (SvMAGICAL(sv))
             mg_get(sv);
 
     if (sv) {
         if (SvMAGICAL(sv))
             mg_get(sv);
-        if (SvROK(sv) &&
-            (tmpsv = MUTABLE_SV(SvRV(sv))) &&            /* assign deliberate */
-            SvTYPE(tmpsv) == SVt_REGEXP)
-        {
-            return (REGEXP*) tmpsv;
-        }
+        if (SvROK(sv))
+           sv = MUTABLE_SV(SvRV(sv));
+        if (SvTYPE(sv) == SVt_REGEXP)
+            return (REGEXP*) sv;
     }
  
     return NULL;
     }
  
     return NULL;
Unnamed repository; edit this file 'description' to name the repository.