X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/98fe6610b077571e54be1d655e66e1ad657a8910..500c19467028989935b081c5fb7b8b33ffb86d40:/util.c

diff --git a/util.c b/util.c
index b72f263..8d9d2e4 100644
--- a/util.c
+++ b/util.c
@@ -70,12 +70,18 @@ S_write_no_mem(pTHX)
     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)
 {
+#ifdef ALWAYS_NEED_THX
     dTHX;
+#endif
     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);
-    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
@@ -116,12 +121,18 @@ Perl_safesysmalloc(MEM_SIZE size)
 #  endif
         ptr = (Malloc_t)((char*)ptr+sTHX);
 #endif
+	DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
 	return ptr;
 }
-    else if (PL_nomemok)
-	return NULL;
     else {
-	return write_no_mem();
+#ifndef ALWAYS_NEED_THX
+	dTHX;
+#endif
+	if (PL_nomemok)
+	    return NULL;
+	else {
+	    return write_no_mem();
+	}
     }
     /*NOTREACHED*/
 }
@@ -131,7 +142,9 @@ Perl_safesysmalloc(MEM_SIZE size)
 Malloc_t
 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 {
+#ifdef ALWAYS_NEED_THX
     dTHX;
+#endif
     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;
     }
-    else if (PL_nomemok)
-	return NULL;
     else {
-	return write_no_mem();
+#ifndef ALWAYS_NEED_THX
+	dTHX;
+#endif
+	if (PL_nomemok)
+	    return NULL;
+	else {
+	    return write_no_mem();
+	}
     }
     /*NOTREACHED*/
 }
@@ -226,7 +244,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 Free_t
 Perl_safesysfree(Malloc_t where)
 {
-#if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL)
+#ifdef ALWAYS_NEED_THX
     dTHX;
 #else
     dVAR;
@@ -268,7 +286,9 @@ Perl_safesysfree(Malloc_t where)
 Malloc_t
 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 {
+#ifdef ALWAYS_NEED_THX
     dTHX;
+#endif
     Malloc_t ptr;
     MEM_SIZE total_size = 0;
 
@@ -330,9 +350,14 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 #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
@@ -878,37 +903,79 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
     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
-Perl_ibcmp(const char *s1, const char *s2, register I32 len)
+Perl_foldEQ(const char *s1, const char *s2, register I32 len)
 {
     register const U8 *a = (const U8 *)s1;
     register const U8 *b = (const U8 *)s2;
 
-    PERL_ARGS_ASSERT_IBCMP;
+    PERL_ARGS_ASSERT_FOLDEQ;
 
     while (len--) {
 	if (*a != *b && *a != PL_fold[*b])
-	    return 1;
+	    return 0;
 	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
-Perl_ibcmp_locale(const char *s1, const char *s2, register I32 len)
+Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len)
 {
     dVAR;
     register const U8 *a = (const U8 *)s1;
     register const U8 *b = (const U8 *)s2;
 
-    PERL_ARGS_ASSERT_IBCMP_LOCALE;
+    PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
 
     while (len--) {
 	if (*a != *b && *a != PL_fold_locale[*b])
-	    return 1;
+	    return 0;
 	a++,b++;
     }
-    return 0;
+    return 1;
 }
 
 /* copy a string to a safe spot */
@@ -1041,6 +1108,25 @@ Perl_savesvpv(pTHX_ SV *sv)
     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 */
 
@@ -1051,7 +1137,7 @@ S_mess_alloc(pTHX)
     SV *sv;
     XPVMG *any;
 
-    if (!PL_dirty)
+    if (PL_phase != PERL_PHASE_DESTRUCT)
 	return newSVpvs_flags("", SVs_TEMP);
 
     if (PL_mess_sv)
@@ -1124,6 +1210,21 @@ Perl_vform(pTHX_ const char *pat, va_list *args)
     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, ...)
@@ -1186,15 +1287,57 @@ S_closest_cop(pTHX_ const COP *cop, const OP *o)
     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 *
-Perl_vmess(pTHX_ const char *pat, va_list *args)
+Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
 {
     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
@@ -1221,15 +1364,43 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
 			   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;
 }
 
+/*
+=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
-Perl_write_to_stderr(pTHX_ const char* message, int msglen)
+Perl_write_to_stderr(pTHX_ SV* msv)
 {
     dVAR;
     IO *io;
@@ -1240,28 +1411,8 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
     if (PL_stderrgv && SvREFCNT(PL_stderrgv) 
 	&& (io = GvIO(PL_stderrgv))
 	&& (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) 
-    {
-	dSP;
-	ENTER;
-	SAVETMPS;
-
-	save_re_context();
-	SAVESPTR(PL_stderrgv);
-	PL_stderrgv = NULL;
-
-	PUSHSTACKi(PERLSI_MAGIC);
-
-	PUSHMARK(SP);
-	EXTEND(SP,2);
-	PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
-	mPUSHp(message, msglen);
-	PUTBACK;
-	call_method("PRINT", G_SCALAR);
-
-	POPSTACK;
-	FREETMPS;
-	LEAVE;
-    }
+	Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, "PRINT",
+			    G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
     else {
 #ifdef USE_SFIO
 	/* SFIO can really mess with your errno */
@@ -1269,7 +1420,7 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
 #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
 	RESTORE_ERRNO;
@@ -1277,10 +1428,26 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
     }
 }
 
-/* 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
-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;
@@ -1290,7 +1457,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;
 
-    assert(oldhook);
+    if (!oldhook)
+	return FALSE;
 
     ENTER;
     SAVESPTR(*hook);
@@ -1299,7 +1467,7 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
     LEAVE;
     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
 	dSP;
-	SV *msg;
+	SV *exarg;
 
 	ENTER;
 	save_re_context();
@@ -1307,18 +1475,13 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
 	    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);
-	XPUSHs(msg);
+	XPUSHs(exarg);
 	PUTBACK;
 	call_sv(MUTABLE_SV(cv), G_DISCARD);
 	POPSTACK;
@@ -1328,99 +1491,147 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
     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;
-    OP *o;
     va_list args;
     va_start(args, pat);
-    o = vdie(pat, &args);
+    vcroak(pat, &args);
+    /* NOTREACHED */
     va_end(args);
-    return o;
+    return NULL;
 }
 #endif /* PERL_IMPLICIT_CONTEXT */
 
 OP *
 Perl_die(pTHX_ const char* pat, ...)
 {
-    OP *o;
     va_list args;
     va_start(args, pat);
-    o = vdie(pat, &args);
+    vcroak(pat, &args);
+    /* NOTREACHED */
     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
-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.
 
-    write_to_stderr(message, msglen);
-    my_failure_exit();
+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
+*/
+
+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, ...)
@@ -1434,54 +1645,105 @@ Perl_croak_nocontext(const char *pat, ...)
 }
 #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
 
-=for apidoc croak
+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.
 
-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>.
+=cut
+*/
+
+void
+Perl_croak_no_modify(pTHX)
+{
+    Perl_croak(aTHX_ "%s", PL_no_modify);
+}
+
+/*
+=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("@", GV_ADD);
-   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
-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)
 {
-    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;
+    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
@@ -1496,15 +1758,6 @@ Perl_warn_nocontext(const char *pat, ...)
 }
 #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, ...)
 {
@@ -1571,21 +1824,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);
-	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);
@@ -3603,113 +3844,196 @@ Perl_my_fflush_all(pTHX)
 }
 
 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;
+}
 
-	if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
-	    vile = "closed";
-	    warn_type = WARN_CLOSED;
+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 (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 {
-	    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
@@ -3831,7 +4155,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
- * 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
@@ -4010,7 +4334,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;
 
-    Newx(buf, bufsize, char);
+    Renew(buf, bufsize, char);
     while (buf) {
       buflen = strftime(buf, bufsize, fmt, &mytm);
       if (buflen > 0 && buflen < bufsize)
@@ -4209,6 +4533,215 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 }
 
 #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
 
@@ -4237,9 +4770,10 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     const char *start;
     const char *pos;
     const char *last;
-    int saw_period = 0;
-    int alpha = 0;
+    const char *errstr = NULL;
+    int saw_decimal = 0;
     int width = 3;
+    bool alpha = FALSE;
     bool vinf = FALSE;
     AV * const av = newAV();
     SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
@@ -4248,54 +4782,24 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
 
     (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++;
 
-    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 == '_' || *pos == ',' || isDIGIT(*pos) )
-    {
-	if ( *pos == '.' )
-	{
-	    if ( alpha )
-		Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
-	    saw_period++ ;
-	    last = pos;
-	}
-	else if ( *pos == '_' )
-	{
-	    if ( alpha )
-		Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
-	    alpha = 1;
-	    width = pos - last - 1; /* natural width of sub-version */
+    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 == ',' && isDIGIT(pos[1]) )
-	{
-	    saw_period++ ;
-	    last = pos;
-	}
-
-	pos++;
     }
 
-    if ( alpha && !saw_period )
-	Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
-
-    if ( alpha && saw_period && width == 0 )
-	Perl_croak(aTHX_ "Invalid version format (misplaced _ in number)");
-
-    if ( saw_period > 1 )
-	qv = 1; /* force quoted version processing */
-
-    last = pos;
+    start = s;
+    if (*s == 'v')
+	s++;
     pos = s;
 
     if ( qv )
@@ -4322,7 +4826,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
 		 */
- 		if ( !qv && s > start && saw_period == 1 ) {
+		if ( !qv && s > start && saw_decimal == 1 ) {
 		    mult *= 100;
  		    while ( s < end ) {
 			orev = rev;
@@ -4412,7 +4916,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     }
     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);
 	}
@@ -4461,6 +4965,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 */
+#ifndef NODEFAULT_SHAREKEYS
+	HvSHAREKEYS_on(hv);         /* key-sharing on by default */
+#endif
 
 	if ( SvROK(ver) )
 	    ver = SvRV(ver);
@@ -4503,7 +5010,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 */
-	    if ( *version != 'v' ) 
+	    if ( isDIGIT(*version) )
 		sv_insert(rv, 0, 0, "v", 1);
 	    Safefree(version);
 	}
@@ -4558,7 +5065,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 );
-	qv = 1;
+	qv = TRUE;
     }
 #endif
     else /* must be a string or something like a string */
@@ -4568,27 +5075,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 */
-	if ( len == 3 && !instr(version,".") && !instr(version,"_") ) {
+	if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
 	    /* may be a v-string */
-	    SV * const nsv = sv_newmortal();
-	    const char *nver;
-	    const char *pos;
-	    int saw_period = 0;
-	    sv_setpvf(nsv,"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
@@ -4607,27 +5122,30 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 /*
 =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
 
-=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 "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
 */
 
-bool
+SV *
 Perl_vverify(pTHX_ SV *vs)
 {
     SV *sv;
@@ -4642,9 +5160,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 )
-	return TRUE;
+	return vs;
     else
-	return FALSE;
+	return NULL;
 }
 
 /*
@@ -4658,6 +5176,8 @@ point representation.  Call like:
 NOTE: you can pass either the object directly or the SV
 contained within the RV.
 
+The SV returned has a refcount of 1.
+
 =cut
 */
 
@@ -4667,15 +5187,14 @@ Perl_vnumify(pTHX_ SV *vs)
     I32 i, len, digit;
     int width;
     bool alpha = FALSE;
-    SV * const sv = newSV(0);
+    SV *sv;
     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 */
@@ -4689,19 +5208,17 @@ Perl_vnumify(pTHX_ SV *vs)
 
     /* 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 )
     {
-	sv_catpvs(sv,"0");
-	return sv;
+	return newSVpvs("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));
@@ -4740,6 +5257,8 @@ representation.  Call like:
 NOTE: you can pass either the object directly or the SV
 contained within the RV.
 
+The SV returned has a refcount of 1.
+
 =cut
 */
 
@@ -4748,15 +5267,14 @@ Perl_vnormal(pTHX_ SV *vs)
 {
     I32 i, len, digit;
     bool alpha = FALSE;
-    SV * const sv = newSV(0);
+    SV *sv;
     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 ) )
@@ -4766,11 +5284,10 @@ Perl_vnormal(pTHX_ SV *vs)
     len = av_len(av);
     if ( len == -1 )
     {
-	sv_catpvs(sv,"");
-	return sv;
+	return newSVpvs("");
     }
     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);
@@ -4799,7 +5316,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
-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
 */
@@ -4809,10 +5328,9 @@ Perl_vstringify(pTHX_ SV *vs)
 {
     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)) {
@@ -4852,15 +5370,10 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
 
     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 */
@@ -5240,8 +5753,11 @@ Perl_parse_unicode_opts(pTHX_ const char **popt)
 	    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);
+	    }
        }
        else {
 	    for (; *p; p++) {
@@ -5267,9 +5783,12 @@ Perl_parse_unicode_opts(pTHX_ const char **popt)
 		 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);
+		      }
 		 }
 	    }
        }
@@ -5277,6 +5796,8 @@ Perl_parse_unicode_opts(pTHX_ const char **popt)
   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));
@@ -5394,7 +5915,7 @@ Perl_get_hash_seed(pTHX)
 	   * 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. */
@@ -5637,7 +6158,7 @@ S_mem_log_common(enum mem_log_type mlt, const UV n,
     mem_log_common   (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
 #else
 /* this is suboptimal, but bug compatible.  User is providing their
-   own implemenation, but is getting these functions anyway, and they
+   own implementation, but is getting these functions anyway, and they
    do nothing. But _NOIMPL users should be able to cope or fix */
 # define \
     mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
@@ -5746,8 +6267,14 @@ Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
     retval = vsprintf(buffer, format, ap);
 #endif
     va_end(ap);
-    /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
-    if (retval < 0 || (len > 0 && (Size_t)retval >= len))
+    /* vsprintf() shows failure with < 0 */
+    if (retval < 0
+#ifdef HAS_VSNPRINTF
+    /* vsnprintf() shows failure with >= len */
+        ||
+        (len > 0 && (Size_t)retval >= len) 
+#endif
+    )
 	Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
     return retval;
 }
@@ -5786,8 +6313,14 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap
     retval = vsprintf(buffer, format, ap);
 # endif
 #endif /* #ifdef NEED_VA_COPY */
-    /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
-    if (retval < 0 || (len > 0 && (Size_t)retval >= len))
+    /* vsprintf() shows failure with < 0 */
+    if (retval < 0
+#ifdef HAS_VSNPRINTF
+    /* vsnprintf() shows failure with >= len */
+        ||
+        (len > 0 && (Size_t)retval >= len) 
+#endif
+    )
 	Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
     return retval;
 }
@@ -5865,9 +6398,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 */
+#if defined(USE_ITHREADS)
 	MUTEX_LOCK(&PL_my_ctx_mutex);
+#endif
 	*index = PL_my_cxt_index++;
+#if defined(USE_ITHREADS)
 	MUTEX_UNLOCK(&PL_my_ctx_mutex);
+#endif
     }
     
     /* make sure the array is big enough */
@@ -5922,9 +6459,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 */
+#if defined(USE_ITHREADS)
 	MUTEX_LOCK(&PL_my_ctx_mutex);
+#endif
 	index = PL_my_cxt_index++;
+#if defined(USE_ITHREADS)
 	MUTEX_UNLOCK(&PL_my_ctx_mutex);
+#endif
     }
 
     /* make sure the array is big enough */
@@ -5957,6 +6498,84 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
 #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)
@@ -6001,21 +6620,28 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
 {
     dVAR;
     SV * const dbsv = GvSVn(PL_DBsub);
+    const bool save_taint = PL_tainted;
+
     /* We do not care about using sv to call CV;
      * it's for informational purposes only.
      */
 
     PERL_ARGS_ASSERT_GET_DB_SUB;
 
+    PL_tainted = FALSE;
     save_item(dbsv);
     if (!PERLDB_SUB_NN) {
-	GV * 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)
-		    && (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));
@@ -6033,6 +6659,7 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
 	(void)SvIOK_on(dbsv);
 	SvIV_set(dbsv, PTR2IV(cv));	/* Do it the quickest way  */
     }
+    TAINT_IF(save_taint);
 }
 
 int
@@ -6054,17 +6681,14 @@ Perl_my_dirfd(pTHX_ DIR * dir) {
 
 REGEXP *
 Perl_get_re_arg(pTHX_ SV *sv) {
-    SV    *tmpsv;
 
     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;