/repo: perl-5.22.2/sv.c comparison

comparison perl-5.22.2/sv.c @ 8045:a16537d2fe07

<xfix> tar xf perl-5.22.2.tar.gz # Ah, whatever, I\'m doing it anyway

author	HackBot
date	Sat, 14 May 2016 14:54:38 +0000
parents
children

comparison

equal deleted inserted replaced

-:711c038a7dce
+:a16537d2fe07
+/*    sv.c
+*
+*    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+*    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall
+*    and others
+*
+*    You may distribute under the terms of either the GNU General Public
+*    License or the Artistic License, as specified in the README file.
+*
+*/
+/*
+* 'I wonder what the Entish is for "yes" and "no",' he thought.
+*                                                      --Pippin
+*
+*     [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"]
+*/
+/*
+*
+*
+* This file contains the code that creates, manipulates and destroys
+* scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
+* structure of an SV, so their creation and destruction is handled
+* here; higher-level functions are in av.c, hv.c, and so on. Opcode
+* level functions (eg. substr, split, join) for each of the types are
+* in the pp*.c files.
+*/
+#include "EXTERN.h"
+#define PERL_IN_SV_C
+#include "perl.h"
+#include "regcomp.h"
+#ifdef __VMS
+# include <rms.h>
+#endif
+#ifdef __Lynx__
+/* Missing proto on LynxOS */
+char *gconvert(double, int, int,  char *);
+#endif
+#ifdef USE_QUADMATH
+#  define SNPRINTF_G(nv, buffer, size, ndig) \
+quadmath_snprintf(buffer, size, "%.*Qg", (int)ndig, (NV)(nv))
+#else
+#  define SNPRINTF_G(nv, buffer, size, ndig) \
+PERL_UNUSED_RESULT(Gconvert((NV)(nv), (int)ndig, 0, buffer))
+#endif
+#ifndef SV_COW_THRESHOLD
+#    define SV_COW_THRESHOLD                    0   /* COW iff len > K */
+#endif
+#ifndef SV_COWBUF_THRESHOLD
+#    define SV_COWBUF_THRESHOLD                 1250 /* COW iff len > K */
+#endif
+#ifndef SV_COW_MAX_WASTE_THRESHOLD
+#    define SV_COW_MAX_WASTE_THRESHOLD          80   /* COW iff (len - cur) < K */
+#endif
+#ifndef SV_COWBUF_WASTE_THRESHOLD
+#    define SV_COWBUF_WASTE_THRESHOLD           80   /* COW iff (len - cur) < K */
+#endif
+#ifndef SV_COW_MAX_WASTE_FACTOR_THRESHOLD
+#    define SV_COW_MAX_WASTE_FACTOR_THRESHOLD   2    /* COW iff len < (cur * K) */
+#endif
+#ifndef SV_COWBUF_WASTE_FACTOR_THRESHOLD
+#    define SV_COWBUF_WASTE_FACTOR_THRESHOLD    2    /* COW iff len < (cur * K) */
+#endif
+/* Work around compiler warnings about unsigned >= THRESHOLD when thres-
+hold is 0. */
+#if SV_COW_THRESHOLD
+# define GE_COW_THRESHOLD(cur) ((cur) >= SV_COW_THRESHOLD)
+#else
+# define GE_COW_THRESHOLD(cur) 1
+#endif
+#if SV_COWBUF_THRESHOLD
+# define GE_COWBUF_THRESHOLD(cur) ((cur) >= SV_COWBUF_THRESHOLD)
+#else
+# define GE_COWBUF_THRESHOLD(cur) 1
+#endif
+#if SV_COW_MAX_WASTE_THRESHOLD
+# define GE_COW_MAX_WASTE_THRESHOLD(cur,len) (((len)-(cur)) < SV_COW_MAX_WASTE_THRESHOLD)
+#else
+# define GE_COW_MAX_WASTE_THRESHOLD(cur,len) 1
+#endif
+#if SV_COWBUF_WASTE_THRESHOLD
+# define GE_COWBUF_WASTE_THRESHOLD(cur,len) (((len)-(cur)) < SV_COWBUF_WASTE_THRESHOLD)
+#else
+# define GE_COWBUF_WASTE_THRESHOLD(cur,len) 1
+#endif
+#if SV_COW_MAX_WASTE_FACTOR_THRESHOLD
+# define GE_COW_MAX_WASTE_FACTOR_THRESHOLD(cur,len) ((len) < SV_COW_MAX_WASTE_FACTOR_THRESHOLD * (cur))
+#else
+# define GE_COW_MAX_WASTE_FACTOR_THRESHOLD(cur,len) 1
+#endif
+#if SV_COWBUF_WASTE_FACTOR_THRESHOLD
+# define GE_COWBUF_WASTE_FACTOR_THRESHOLD(cur,len) ((len) < SV_COWBUF_WASTE_FACTOR_THRESHOLD * (cur))
+#else
+# define GE_COWBUF_WASTE_FACTOR_THRESHOLD(cur,len) 1
+#endif
+#define CHECK_COW_THRESHOLD(cur,len) (\
+GE_COW_THRESHOLD((cur)) && \
+GE_COW_MAX_WASTE_THRESHOLD((cur),(len)) && \
+GE_COW_MAX_WASTE_FACTOR_THRESHOLD((cur),(len)) \
+)
+#define CHECK_COWBUF_THRESHOLD(cur,len) (\
+GE_COWBUF_THRESHOLD((cur)) && \
+GE_COWBUF_WASTE_THRESHOLD((cur),(len)) && \
+GE_COWBUF_WASTE_FACTOR_THRESHOLD((cur),(len)) \
+)
+#ifdef PERL_UTF8_CACHE_ASSERT
+/* if adding more checks watch out for the following tests:
+*   t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
+*   lib/utf8.t lib/Unicode/Collate/t/index.t
+* --jhi
+*/
+#   define ASSERT_UTF8_CACHE(cache) \
+STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
+			      assert((cache)[2] <= (cache)[3]); \
+			      assert((cache)[3] <= (cache)[1]);} \
+			      } STMT_END
+#else
+#   define ASSERT_UTF8_CACHE(cache) NOOP
+#endif
+#ifdef PERL_OLD_COPY_ON_WRITE
+#define SV_COW_NEXT_SV(sv)	INT2PTR(SV *,SvUVX(sv))
+#define SV_COW_NEXT_SV_SET(current,next)	SvUV_set(current, PTR2UV(next))
+#endif
+/* ============================================================================
+=head1 Allocation and deallocation of SVs.
+An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
+sv, av, hv...) contains type and reference count information, and for
+many types, a pointer to the body (struct xrv, xpv, xpviv...), which
+contains fields specific to each type.  Some types store all they need
+in the head, so don't have a body.
+In all but the most memory-paranoid configurations (ex: PURIFY), heads
+and bodies are allocated out of arenas, which by default are
+approximately 4K chunks of memory parcelled up into N heads or bodies.
+Sv-bodies are allocated by their sv-type, guaranteeing size
+consistency needed to allocate safely from arrays.
+For SV-heads, the first slot in each arena is reserved, and holds a
+link to the next arena, some flags, and a note of the number of slots.
+Snaked through each arena chain is a linked list of free items; when
+this becomes empty, an extra arena is allocated and divided up into N
+items which are threaded into the free list.
+SV-bodies are similar, but they use arena-sets by default, which
+separate the link and info from the arena itself, and reclaim the 1st
+slot in the arena.  SV-bodies are further described later.
+The following global variables are associated with arenas:
+PL_sv_arenaroot     pointer to list of SV arenas
+PL_sv_root          pointer to list of free SV structures
+PL_body_arenas      head of linked-list of body arenas
+PL_body_roots[]     array of pointers to list of free bodies of svtype
+arrays are indexed by the svtype needed
+A few special SV heads are not allocated from an arena, but are
+instead directly created in the interpreter structure, eg PL_sv_undef.
+The size of arenas can be changed from the default by setting
+PERL_ARENA_SIZE appropriately at compile time.
+The SV arena serves the secondary purpose of allowing still-live SVs
+to be located and destroyed during final cleanup.
+At the lowest level, the macros new_SV() and del_SV() grab and free
+an SV head.  (If debugging with -DD, del_SV() calls the function S_del_sv()
+to return the SV to the free list with error checking.) new_SV() calls
+more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
+SVs in the free list have their SvTYPE field set to all ones.
+At the time of very final cleanup, sv_free_arenas() is called from
+perl_destruct() to physically free all the arenas allocated since the
+start of the interpreter.
+The function visit() scans the SV arenas list, and calls a specified
+function for each SV it finds which is still live - ie which has an SvTYPE
+other than all 1's, and a non-zero SvREFCNT. visit() is used by the
+following functions (specified as [function that calls visit()] / [function
+called by visit() for each SV]):
+sv_report_used() / do_report_used()
+			dump all remaining SVs (debugging aid)
+sv_clean_objs() / do_clean_objs(),do_clean_named_objs(),
+		      do_clean_named_io_objs(),do_curse()
+			Attempt to free all objects pointed to by RVs,
+			try to do the same for all objects indir-
+			ectly referenced by typeglobs too, and
+			then do a final sweep, cursing any
+			objects that remain.  Called once from
+			perl_destruct(), prior to calling sv_clean_all()
+			below.
+sv_clean_all() / do_clean_all()
+			SvREFCNT_dec(sv) each remaining SV, possibly
+			triggering an sv_free(). It also sets the
+			SVf_BREAK flag on the SV to indicate that the
+			refcnt has been artificially lowered, and thus
+			stopping sv_free() from giving spurious warnings
+			about SVs which unexpectedly have a refcnt
+			of zero.  called repeatedly from perl_destruct()
+			until there are no SVs left.
+=head2 Arena allocator API Summary
+Private API to rest of sv.c
+new_SV(),  del_SV(),
+new_XPVNV(), del_XPVGV(),
+etc
+Public API:
+sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
+=cut
+* ========================================================================= */
+/*
+* "A time to plant, and a time to uproot what was planted..."
+*/
+#ifdef PERL_MEM_LOG
+#  define MEM_LOG_NEW_SV(sv, file, line, func)	\
+	    Perl_mem_log_new_sv(sv, file, line, func)
+#  define MEM_LOG_DEL_SV(sv, file, line, func)	\
+	    Perl_mem_log_del_sv(sv, file, line, func)
+#else
+#  define MEM_LOG_NEW_SV(sv, file, line, func)	NOOP
+#  define MEM_LOG_DEL_SV(sv, file, line, func)	NOOP
+#endif
+#ifdef DEBUG_LEAKING_SCALARS
+#  define FREE_SV_DEBUG_FILE(sv) STMT_START { \
+	if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \
+} STMT_END
+#  define DEBUG_SV_SERIAL(sv)						    \
+DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n",    \
+	    PTR2UV(sv), (long)(sv)->sv_debug_serial))
+#else
+#  define FREE_SV_DEBUG_FILE(sv)
+#  define DEBUG_SV_SERIAL(sv)	NOOP
+#endif
+#ifdef PERL_POISON
+#  define SvARENA_CHAIN(sv)	((sv)->sv_u.svu_rv)
+#  define SvARENA_CHAIN_SET(sv,val)	(sv)->sv_u.svu_rv = MUTABLE_SV((val))
+/* Whilst I'd love to do this, it seems that things like to check on
+unreferenced scalars
+#  define POISON_SV_HEAD(sv)	PoisonNew(sv, 1, struct STRUCT_SV)
+*/
+#  define POISON_SV_HEAD(sv)	PoisonNew(&SvANY(sv), 1, void *), \
+				PoisonNew(&SvREFCNT(sv), 1, U32)
+#else
+#  define SvARENA_CHAIN(sv)	SvANY(sv)
+#  define SvARENA_CHAIN_SET(sv,val)	SvANY(sv) = (void *)(val)
+#  define POISON_SV_HEAD(sv)
+#endif
+/* Mark an SV head as unused, and add to free list.
+*
+* If SVf_BREAK is set, skip adding it to the free list, as this SV had
+* its refcount artificially decremented during global destruction, so
+* there may be dangling pointers to it. The last thing we want in that
+* case is for it to be reused. */
+#define plant_SV(p) \
+STMT_START {					\
+	const U32 old_flags = SvFLAGS(p);			\
+	MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__);  \
+	DEBUG_SV_SERIAL(p);				\
+	FREE_SV_DEBUG_FILE(p);				\
+	POISON_SV_HEAD(p);				\
+	SvFLAGS(p) = SVTYPEMASK;			\
+	if (!(old_flags & SVf_BREAK)) {		\
+	    SvARENA_CHAIN_SET(p, PL_sv_root);	\
+	    PL_sv_root = (p);				\
+	}						\
+	--PL_sv_count;					\
+} STMT_END
+#define uproot_SV(p) \
+STMT_START {					\
+	(p) = PL_sv_root;				\
+	PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p));		\
+	++PL_sv_count;					\
+} STMT_END
+/* make some more SVs by adding another arena */
+STATIC SV*
+S_more_sv(pTHX)
+{
+SV* sv;
+char *chunk;                /* must use New here to match call to */
+Newx(chunk,PERL_ARENA_SIZE,char);  /* Safefree() in sv_free_arenas() */
+sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
+uproot_SV(sv);
+return sv;
+}
+/* new_SV(): return a new, empty SV head */
+#ifdef DEBUG_LEAKING_SCALARS
+/* provide a real function for a debugger to play with */
+STATIC SV*
+S_new_SV(pTHX_ const char *file, int line, const char *func)
+{
+SV* sv;
+if (PL_sv_root)
+	uproot_SV(sv);
+else
+	sv = S_more_sv(aTHX);
+SvANY(sv) = 0;
+SvREFCNT(sv) = 1;
+SvFLAGS(sv) = 0;
+sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
+sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
+		? PL_parser->copline
+		:  PL_curcop
+		    ? CopLINE(PL_curcop)
+		    : 0
+	    );
+sv->sv_debug_inpad = 0;
+sv->sv_debug_parent = NULL;
+sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
+sv->sv_debug_serial = PL_sv_serial++;
+MEM_LOG_NEW_SV(sv, file, line, func);
+DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
+	    PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
+return sv;
+}
+#  define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
+#else
+#  define new_SV(p) \
+STMT_START {					\
+	if (PL_sv_root)					\
+	    uproot_SV(p);				\
+	else						\
+	    (p) = S_more_sv(aTHX);			\
+	SvANY(p) = 0;					\
+	SvREFCNT(p) = 1;				\
+	SvFLAGS(p) = 0;					\
+	MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__);  \
+} STMT_END
+#endif
+/* del_SV(): return an empty SV head to the free list */
+#ifdef DEBUGGING
+#define del_SV(p) \
+STMT_START {					\
+	if (DEBUG_D_TEST)				\
+	    del_sv(p);					\
+	else						\
+	    plant_SV(p);				\
+} STMT_END
+STATIC void
+S_del_sv(pTHX_ SV *p)
+{
+PERL_ARGS_ASSERT_DEL_SV;
+if (DEBUG_D_TEST) {
+	SV* sva;
+	bool ok = 0;
+	for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
+	    const SV * const sv = sva + 1;
+	    const SV * const svend = &sva[SvREFCNT(sva)];
+	    if (p >= sv && p < svend) {
+		ok = 1;
+		break;
+	    }
+	}
+	if (!ok) {
+	    Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
+			     "Attempt to free non-arena SV: 0x%"UVxf
+			     pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
+	    return;
+	}
+}
+plant_SV(p);
+}
+#else /* ! DEBUGGING */
+#define del_SV(p)   plant_SV(p)
+#endif /* DEBUGGING */
+/*
+* Bodyless IVs and NVs!
+*
+* Since 5.9.2, we can avoid allocating a body for SVt_IV-type SVs.
+* Since the larger IV-holding variants of SVs store their integer
+* values in their respective bodies, the family of SvIV() accessor
+* macros would  naively have to branch on the SV type to find the
+* integer value either in the HEAD or BODY. In order to avoid this
+* expensive branch, a clever soul has deployed a great hack:
+* We set up the SvANY pointer such that instead of pointing to a
+* real body, it points into the memory before the location of the
+* head. We compute this pointer such that the location of
+* the integer member of the hypothetical body struct happens to
+* be the same as the location of the integer member of the bodyless
+* SV head. This now means that the SvIV() family of accessors can
+* always read from the (hypothetical or real) body via SvANY.
+*
+* Since the 5.21 dev series, we employ the same trick for NVs
+* if the architecture can support it (NVSIZE <= IVSIZE).
+*/
+/* The following two macros compute the necessary offsets for the above
+* trick and store them in SvANY for SvIV() (and friends) to use. */
+#define SET_SVANY_FOR_BODYLESS_IV(sv) \
+	SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv))
+#define SET_SVANY_FOR_BODYLESS_NV(sv) \
+	SvANY(sv) = (XPVNV*)((char*)&(sv->sv_u.svu_nv) - STRUCT_OFFSET(XPVNV, xnv_u.xnv_nv))
+/*
+=head1 SV Manipulation Functions
+=for apidoc sv_add_arena
+Given a chunk of memory, link it to the head of the list of arenas,
+and split it into a list of free SVs.
+=cut
+*/
+static void
+S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
+{
+SV *const sva = MUTABLE_SV(ptr);
+SV* sv;
+SV* svend;
+PERL_ARGS_ASSERT_SV_ADD_ARENA;
+/* The first SV in an arena isn't an SV. */
+SvANY(sva) = (void *) PL_sv_arenaroot;		/* ptr to next arena */
+SvREFCNT(sva) = size / sizeof(SV);		/* number of SV slots */
+SvFLAGS(sva) = flags;			/* FAKE if not to be freed */
+PL_sv_arenaroot = sva;
+PL_sv_root = sva + 1;
+svend = &sva[SvREFCNT(sva) - 1];
+sv = sva + 1;
+while (sv < svend) {
+	SvARENA_CHAIN_SET(sv, (sv + 1));
+#ifdef DEBUGGING
+	SvREFCNT(sv) = 0;
+#endif
+	/* Must always set typemask because it's always checked in on cleanup
+	   when the arenas are walked looking for objects.  */
+	SvFLAGS(sv) = SVTYPEMASK;
+	sv++;
+}
+SvARENA_CHAIN_SET(sv, 0);
+#ifdef DEBUGGING
+SvREFCNT(sv) = 0;
+#endif
+SvFLAGS(sv) = SVTYPEMASK;
+}
+/* visit(): call the named function for each non-free SV in the arenas
+* whose flags field matches the flags/mask args. */
+STATIC I32
+S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
+{
+SV* sva;
+I32 visited = 0;
+PERL_ARGS_ASSERT_VISIT;
+for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
+	const SV * const svend = &sva[SvREFCNT(sva)];
+	SV* sv;
+	for (sv = sva + 1; sv < svend; ++sv) {
+	    if (SvTYPE(sv) != (svtype)SVTYPEMASK
+		    && (sv->sv_flags & mask) == flags
+		    && SvREFCNT(sv))
+	    {
+		(*f)(aTHX_ sv);
+		++visited;
+	    }
+	}
+}
+return visited;
+}
+#ifdef DEBUGGING
+/* called by sv_report_used() for each live SV */
+static void
+do_report_used(pTHX_ SV *const sv)
+{
+if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
+	PerlIO_printf(Perl_debug_log, "****\n");
+	sv_dump(sv);
+}
+}
+#endif
+/*
+=for apidoc sv_report_used
+Dump the contents of all SVs not yet freed (debugging aid).
+=cut
+*/
+void
+Perl_sv_report_used(pTHX)
+{
+#ifdef DEBUGGING
+visit(do_report_used, 0, 0);
+#else
+PERL_UNUSED_CONTEXT;
+#endif
+}
+/* called by sv_clean_objs() for each live SV */
+static void
+do_clean_objs(pTHX_ SV *const ref)
+{
+assert (SvROK(ref));
+{
+	SV * const target = SvRV(ref);
+	if (SvOBJECT(target)) {
+	    DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
+	    if (SvWEAKREF(ref)) {
+		sv_del_backref(target, ref);
+		SvWEAKREF_off(ref);
+		SvRV_set(ref, NULL);
+	    } else {
+		SvROK_off(ref);
+		SvRV_set(ref, NULL);
+		SvREFCNT_dec_NN(target);
+	    }
+	}
+}
+}
+/* clear any slots in a GV which hold objects - except IO;
+* called by sv_clean_objs() for each live GV */
+static void
+do_clean_named_objs(pTHX_ SV *const sv)
+{
+SV *obj;
+assert(SvTYPE(sv) == SVt_PVGV);
+assert(isGV_with_GP(sv));
+if (!GvGP(sv))
+	return;
+/* freeing GP entries may indirectly free the current GV;
+* hold onto it while we mess with the GP slots */
+SvREFCNT_inc(sv);
+if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) {
+	DEBUG_D((PerlIO_printf(Perl_debug_log,
+		"Cleaning named glob SV object:\n "), sv_dump(obj)));
+	GvSV(sv) = NULL;
+	SvREFCNT_dec_NN(obj);
+}
+if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
+	DEBUG_D((PerlIO_printf(Perl_debug_log,
+		"Cleaning named glob AV object:\n "), sv_dump(obj)));
+	GvAV(sv) = NULL;
+	SvREFCNT_dec_NN(obj);
+}
+if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
+	DEBUG_D((PerlIO_printf(Perl_debug_log,
+		"Cleaning named glob HV object:\n "), sv_dump(obj)));
+	GvHV(sv) = NULL;
+	SvREFCNT_dec_NN(obj);
+}
+if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
+	DEBUG_D((PerlIO_printf(Perl_debug_log,
+		"Cleaning named glob CV object:\n "), sv_dump(obj)));
+	GvCV_set(sv, NULL);
+	SvREFCNT_dec_NN(obj);
+}
+SvREFCNT_dec_NN(sv); /* undo the inc above */
+}
+/* clear any IO slots in a GV which hold objects (except stderr, defout);
+* called by sv_clean_objs() for each live GV */
+static void
+do_clean_named_io_objs(pTHX_ SV *const sv)
+{
+SV *obj;
+assert(SvTYPE(sv) == SVt_PVGV);
+assert(isGV_with_GP(sv));
+if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
+	return;
+SvREFCNT_inc(sv);
+if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) {
+	DEBUG_D((PerlIO_printf(Perl_debug_log,
+		"Cleaning named glob IO object:\n "), sv_dump(obj)));
+	GvIOp(sv) = NULL;
+	SvREFCNT_dec_NN(obj);
+}
+SvREFCNT_dec_NN(sv); /* undo the inc above */
+}
+/* Void wrapper to pass to visit() */
+static void
+do_curse(pTHX_ SV * const sv) {
+if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
+|| (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv))
+	return;
+(void)curse(sv, 0);
+}
+/*
+=for apidoc sv_clean_objs
+Attempt to destroy all objects not yet freed.
+=cut
+*/
+void
+Perl_sv_clean_objs(pTHX)
+{
+GV *olddef, *olderr;
+PL_in_clean_objs = TRUE;
+visit(do_clean_objs, SVf_ROK, SVf_ROK);
+/* Some barnacles may yet remain, clinging to typeglobs.
+* Run the non-IO destructors first: they may want to output
+* error messages, close files etc */
+visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
+visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
+/* And if there are some very tenacious barnacles clinging to arrays,
+closures, or what have you.... */
+visit(do_curse, SVs_OBJECT, SVs_OBJECT);
+olddef = PL_defoutgv;
+PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
+if (olddef && isGV_with_GP(olddef))
+	do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
+olderr = PL_stderrgv;
+PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
+if (olderr && isGV_with_GP(olderr))
+	do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
+SvREFCNT_dec(olddef);
+PL_in_clean_objs = FALSE;
+}
+/* called by sv_clean_all() for each live SV */
+static void
+do_clean_all(pTHX_ SV *const sv)
+{
+if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
+	/* don't clean pid table and strtab */
+	return;
+}
+DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
+SvFLAGS(sv) |= SVf_BREAK;
+SvREFCNT_dec_NN(sv);
+}
+/*
+=for apidoc sv_clean_all
+Decrement the refcnt of each remaining SV, possibly triggering a
+cleanup.  This function may have to be called multiple times to free
+SVs which are in complex self-referential hierarchies.
+=cut
+*/
+I32
+Perl_sv_clean_all(pTHX)
+{
+I32 cleaned;
+PL_in_clean_all = TRUE;
+cleaned = visit(do_clean_all, 0,0);
+return cleaned;
+}
+/*
+ARENASETS: a meta-arena implementation which separates arena-info
+into struct arena_set, which contains an array of struct
+arena_descs, each holding info for a single arena.  By separating
+the meta-info from the arena, we recover the 1st slot, formerly
+borrowed for list management.  The arena_set is about the size of an
+arena, avoiding the needless malloc overhead of a naive linked-list.
+The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
+memory in the last arena-set (1/2 on average).  In trade, we get
+back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
+smaller types).  The recovery of the wasted space allows use of
+small arenas for large, rare body types, by changing array* fields
+in body_details_by_type[] below.
+*/
+struct arena_desc {
+char       *arena;		/* the raw storage, allocated aligned */
+size_t      size;		/* its size ~4k typ */
+svtype	utype;		/* bodytype stored in arena */
+};
+struct arena_set;
+/* Get the maximum number of elements in set[] such that struct arena_set
+will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
+therefore likely to be 1 aligned memory page.  */
+#define ARENAS_PER_SET  ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
+			  - 2 * sizeof(int)) / sizeof (struct arena_desc))
+struct arena_set {
+struct arena_set* next;
+unsigned int   set_size;	/* ie ARENAS_PER_SET */
+unsigned int   curr;	/* index of next available arena-desc */
+struct arena_desc set[ARENAS_PER_SET];
+};
+/*
+=for apidoc sv_free_arenas
+Deallocate the memory used by all arenas.  Note that all the individual SV
+heads and bodies within the arenas must already have been freed.
+=cut
+*/
+void
+Perl_sv_free_arenas(pTHX)
+{
+SV* sva;
+SV* svanext;
+unsigned int i;
+/* Free arenas here, but be careful about fake ones.  (We assume
+contiguity of the fake ones with the corresponding real ones.) */
+for (sva = PL_sv_arenaroot; sva; sva = svanext) {
+	svanext = MUTABLE_SV(SvANY(sva));
+	while (svanext && SvFAKE(svanext))
+	    svanext = MUTABLE_SV(SvANY(svanext));
+	if (!SvFAKE(sva))
+	    Safefree(sva);
+}
+{
+	struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
+	while (aroot) {
+	    struct arena_set *current = aroot;
+	    i = aroot->curr;
+	    while (i--) {
+		assert(aroot->set[i].arena);
+		Safefree(aroot->set[i].arena);
+	    }
+	    aroot = aroot->next;
+	    Safefree(current);
+	}
+}
+PL_body_arenas = 0;
+i = PERL_ARENA_ROOTS_SIZE;
+while (i--)
+	PL_body_roots[i] = 0;
+PL_sv_arenaroot = 0;
+PL_sv_root = 0;
+}
+/*
+Here are mid-level routines that manage the allocation of bodies out
+of the various arenas.  There are 5 kinds of arenas:
+1. SV-head arenas, which are discussed and handled above
+2. regular body arenas
+3. arenas for reduced-size bodies
+4. Hash-Entry arenas
+Arena types 2 & 3 are chained by body-type off an array of
+arena-root pointers, which is indexed by svtype.  Some of the
+larger/less used body types are malloced singly, since a large
+unused block of them is wasteful.  Also, several svtypes dont have
+bodies; the data fits into the sv-head itself.  The arena-root
+pointer thus has a few unused root-pointers (which may be hijacked
+later for arena types 4,5)
+3 differs from 2 as an optimization; some body types have several
+unused fields in the front of the structure (which are kept in-place
+for consistency).  These bodies can be allocated in smaller chunks,
+because the leading fields arent accessed.  Pointers to such bodies
+are decremented to point at the unused 'ghost' memory, knowing that
+the pointers are used with offsets to the real memory.
+=head1 SV-Body Allocation
+=cut
+Allocation of SV-bodies is similar to SV-heads, differing as follows;
+the allocation mechanism is used for many body types, so is somewhat
+more complicated, it uses arena-sets, and has no need for still-live
+SV detection.
+At the outermost level, (new|del)_X*V macros return bodies of the
+appropriate type.  These macros call either (new|del)_body_type or
+(new|del)_body_allocated macro pairs, depending on specifics of the
+type.  Most body types use the former pair, the latter pair is used to
+allocate body types with "ghost fields".
+"ghost fields" are fields that are unused in certain types, and
+consequently don't need to actually exist.  They are declared because
+they're part of a "base type", which allows use of functions as
+methods.  The simplest examples are AVs and HVs, 2 aggregate types
+which don't use the fields which support SCALAR semantics.
+For these types, the arenas are carved up into appropriately sized
+chunks, we thus avoid wasted memory for those unaccessed members.
+When bodies are allocated, we adjust the pointer back in memory by the
+size of the part not allocated, so it's as if we allocated the full
+structure.  (But things will all go boom if you write to the part that
+is "not there", because you'll be overwriting the last members of the
+preceding structure in memory.)
+We calculate the correction using the STRUCT_OFFSET macro on the first
+member present.  If the allocated structure is smaller (no initial NV
+actually allocated) then the net effect is to subtract the size of the NV
+from the pointer, to return a new pointer as if an initial NV were actually
+allocated.  (We were using structures named *_allocated for this, but
+this turned out to be a subtle bug, because a structure without an NV
+could have a lower alignment constraint, but the compiler is allowed to
+optimised accesses based on the alignment constraint of the actual pointer
+to the full structure, for example, using a single 64 bit load instruction
+because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
+This is the same trick as was used for NV and IV bodies.  Ironically it
+doesn't need to be used for NV bodies any more, because NV is now at
+the start of the structure.  IV bodies, and also in some builds NV bodies,
+don't need it either, because they are no longer allocated.
+In turn, the new_body_* allocators call S_new_body(), which invokes
+new_body_inline macro, which takes a lock, and takes a body off the
+linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
+necessary to refresh an empty list.  Then the lock is released, and
+the body is returned.
+Perl_more_bodies allocates a new arena, and carves it up into an array of N
+bodies, which it strings into a linked list.  It looks up arena-size
+and body-size from the body_details table described below, thus
+supporting the multiple body-types.
+If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
+the (new|del)_X*V macros are mapped directly to malloc/free.
+For each sv-type, struct body_details bodies_by_type[] carries
+parameters which control these aspects of SV handling:
+Arena_size determines whether arenas are used for this body type, and if
+so, how big they are.  PURIFY or PERL_ARENA_SIZE=0 set this field to
+zero, forcing individual mallocs and frees.
+Body_size determines how big a body is, and therefore how many fit into
+each arena.  Offset carries the body-pointer adjustment needed for
+"ghost fields", and is used in *_allocated macros.
+But its main purpose is to parameterize info needed in
+Perl_sv_upgrade().  The info here dramatically simplifies the function
+vs the implementation in 5.8.8, making it table-driven.  All fields
+are used for this, except for arena_size.
+For the sv-types that have no bodies, arenas are not used, so those
+PL_body_roots[sv_type] are unused, and can be overloaded.  In
+something of a special case, SVt_NULL is borrowed for HE arenas;
+PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
+bodies_by_type[SVt_NULL] slot is not used, as the table is not
+available in hv.c.
+*/
+struct body_details {
+U8 body_size;	/* Size to allocate  */
+U8 copy;		/* Size of structure to copy (may be shorter)  */
+U8 offset;		/* Size of unalloced ghost fields to first alloced field*/
+PERL_BITFIELD8 type : 4;        /* We have space for a sanity check. */
+PERL_BITFIELD8 cant_upgrade : 1;/* Cannot upgrade this type */
+PERL_BITFIELD8 zero_nv : 1;     /* zero the NV when upgrading from this */
+PERL_BITFIELD8 arena : 1;       /* Allocated from an arena */
+U32 arena_size;                 /* Size of arena to allocate */
+};
+#define HADNV FALSE
+#define NONV TRUE
+#ifdef PURIFY
+/* With -DPURFIY we allocate everything directly, and don't use arenas.
+This seems a rather elegant way to simplify some of the code below.  */
+#define HASARENA FALSE
+#else
+#define HASARENA TRUE
+#endif
+#define NOARENA FALSE
+/* Size the arenas to exactly fit a given number of bodies.  A count
+of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
+simplifying the default.  If count > 0, the arena is sized to fit
+only that many bodies, allowing arenas to be used for large, rare
+bodies (XPVFM, XPVIO) without undue waste.  The arena size is
+limited by PERL_ARENA_SIZE, so we can safely oversize the
+declarations.
+*/
+#define FIT_ARENA0(body_size)				\
+((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
+#define FIT_ARENAn(count,body_size)			\
+( count * body_size <= PERL_ARENA_SIZE)		\
+? count * body_size					\
+: FIT_ARENA0 (body_size)
+#define FIT_ARENA(count,body_size)			\
+(U32)(count 						\
+? FIT_ARENAn (count, body_size)			\
+: FIT_ARENA0 (body_size))
+/* Calculate the length to copy. Specifically work out the length less any
+final padding the compiler needed to add.  See the comment in sv_upgrade
+for why copying the padding proved to be a bug.  */
+#define copy_length(type, last_member) \
+	STRUCT_OFFSET(type, last_member) \
+	+ sizeof (((type*)SvANY((const SV *)0))->last_member)
+static const struct body_details bodies_by_type[] = {
+/* HEs use this offset for their arena.  */
+{ 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
+/* IVs are in the head, so the allocation size is 0.  */
+{ 0,
+sizeof(IV), /* This is used to copy out the IV body.  */
+STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
+NOARENA /* IVS don't need an arena  */, 0
+},
+#if NVSIZE <= IVSIZE
+{ 0, sizeof(NV),
+STRUCT_OFFSET(XPVNV, xnv_u),
+SVt_NV, FALSE, HADNV, NOARENA, 0 },
+#else
+{ sizeof(NV), sizeof(NV),
+STRUCT_OFFSET(XPVNV, xnv_u),
+SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
+#endif
+{ sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
+copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
++ STRUCT_OFFSET(XPV, xpv_cur),
+SVt_PV, FALSE, NONV, HASARENA,
+FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
+{ sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur),
+copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur),
++ STRUCT_OFFSET(XPV, xpv_cur),
+SVt_INVLIST, TRUE, NONV, HASARENA,
+FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) },
+{ sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
+copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
++ STRUCT_OFFSET(XPV, xpv_cur),
+SVt_PVIV, FALSE, NONV, HASARENA,
+FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
+{ sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
+copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
++ STRUCT_OFFSET(XPV, xpv_cur),
+SVt_PVNV, FALSE, HADNV, HASARENA,
+FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
+{ sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
+HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
+{ sizeof(regexp),
+sizeof(regexp),
+0,
+SVt_REGEXP, TRUE, NONV, HASARENA,
+FIT_ARENA(0, sizeof(regexp))
+},
+{ sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
+HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
+{ sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
+HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
+{ sizeof(XPVAV),
+copy_length(XPVAV, xav_alloc),
+0,
+SVt_PVAV, TRUE, NONV, HASARENA,
+FIT_ARENA(0, sizeof(XPVAV)) },
+{ sizeof(XPVHV),
+copy_length(XPVHV, xhv_max),
+0,
+SVt_PVHV, TRUE, NONV, HASARENA,
+FIT_ARENA(0, sizeof(XPVHV)) },
+{ sizeof(XPVCV),
+sizeof(XPVCV),
+0,
+SVt_PVCV, TRUE, NONV, HASARENA,
+FIT_ARENA(0, sizeof(XPVCV)) },
+{ sizeof(XPVFM),
+sizeof(XPVFM),
+0,
+SVt_PVFM, TRUE, NONV, NOARENA,
+FIT_ARENA(20, sizeof(XPVFM)) },
+{ sizeof(XPVIO),
+sizeof(XPVIO),
+0,
+SVt_PVIO, TRUE, NONV, HASARENA,
+FIT_ARENA(24, sizeof(XPVIO)) },
+};
+#define new_body_allocated(sv_type)		\
+(void *)((char *)S_new_body(aTHX_ sv_type)	\
+	     - bodies_by_type[sv_type].offset)
+/* return a thing to the free list */
+#define del_body(thing, root)				\
+STMT_START {					\
+	void ** const thing_copy = (void **)thing;	\
+	*thing_copy = *root;				\
+	*root = (void*)thing_copy;			\
+} STMT_END
+#ifdef PURIFY
+#if !(NVSIZE <= IVSIZE)
+#  define new_XNV()	safemalloc(sizeof(XPVNV))
+#endif
+#define new_XPVNV()	safemalloc(sizeof(XPVNV))
+#define new_XPVMG()	safemalloc(sizeof(XPVMG))
+#define del_XPVGV(p)	safefree(p)
+#else /* !PURIFY */
+#if !(NVSIZE <= IVSIZE)
+#  define new_XNV()	new_body_allocated(SVt_NV)
+#endif
+#define new_XPVNV()	new_body_allocated(SVt_PVNV)
+#define new_XPVMG()	new_body_allocated(SVt_PVMG)
+#define del_XPVGV(p)	del_body(p + bodies_by_type[SVt_PVGV].offset,	\
+				 &PL_body_roots[SVt_PVGV])
+#endif /* PURIFY */
+/* no arena for you! */
+#define new_NOARENA(details) \
+	safemalloc((details)->body_size + (details)->offset)
+#define new_NOARENAZ(details) \
+	safecalloc((details)->body_size + (details)->offset, 1)
+void *
+Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
+		  const size_t arena_size)
+{
+void ** const root = &PL_body_roots[sv_type];
+struct arena_desc *adesc;
+struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
+unsigned int curr;
+char *start;
+const char *end;
+const size_t good_arena_size = Perl_malloc_good_size(arena_size);
+#if defined(DEBUGGING) && defined(PERL_GLOBAL_STRUCT)
+dVAR;
+#endif
+#if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
+static bool done_sanity_check;
+/* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
+* variables like done_sanity_check. */
+if (!done_sanity_check) {
+	unsigned int i = SVt_LAST;
+	done_sanity_check = TRUE;
+	while (i--)
+	    assert (bodies_by_type[i].type == i);
+}
+#endif
+assert(arena_size);
+/* may need new arena-set to hold new arena */
+if (!aroot || aroot->curr >= aroot->set_size) {
+	struct arena_set *newroot;
+	Newxz(newroot, 1, struct arena_set);
+	newroot->set_size = ARENAS_PER_SET;
+	newroot->next = aroot;
+	aroot = newroot;
+	PL_body_arenas = (void *) newroot;
+	DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
+}
+/* ok, now have arena-set with at least 1 empty/available arena-desc */
+curr = aroot->curr++;
+adesc = &(aroot->set[curr]);
+assert(!adesc->arena);
+Newx(adesc->arena, good_arena_size, char);
+adesc->size = good_arena_size;
+adesc->utype = sv_type;
+DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
+			  curr, (void*)adesc->arena, (UV)good_arena_size));
+start = (char *) adesc->arena;
+/* Get the address of the byte after the end of the last body we can fit.
+Remember, this is integer division:  */
+end = start + good_arena_size / body_size * body_size;
+/* computed count doesn't reflect the 1st slot reservation */
+#if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
+DEBUG_m(PerlIO_printf(Perl_debug_log,
+			  "arena %p end %p arena-size %d (from %d) type %d "
+			  "size %d ct %d\n",
+			  (void*)start, (void*)end, (int)good_arena_size,
+			  (int)arena_size, sv_type, (int)body_size,
+			  (int)good_arena_size / (int)body_size));
+#else
+DEBUG_m(PerlIO_printf(Perl_debug_log,
+			  "arena %p end %p arena-size %d type %d size %d ct %d\n",
+			  (void*)start, (void*)end,
+			  (int)arena_size, sv_type, (int)body_size,
+			  (int)good_arena_size / (int)body_size));
+#endif
+*root = (void *)start;
+while (1) {
+	/* Where the next body would start:  */
+	char * const next = start + body_size;
+	if (next >= end) {
+	    /* This is the last body:  */
+	    assert(next == end);
+	    *(void **)start = 0;
+	    return *root;
+	}
+	*(void**) start = (void *)next;
+	start = next;
+}
+}
+/* grab a new thing from the free list, allocating more if necessary.
+The inline version is used for speed in hot routines, and the
+function using it serves the rest (unless PURIFY).
+*/
+#define new_body_inline(xpv, sv_type) \
+STMT_START { \
+	void ** const r3wt = &PL_body_roots[sv_type]; \
+	xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt))      \
+	  ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \
+					     bodies_by_type[sv_type].body_size,\
+					     bodies_by_type[sv_type].arena_size)); \
+	*(r3wt) = *(void**)(xpv); \
+} STMT_END
+#ifndef PURIFY
+STATIC void *
+S_new_body(pTHX_ const svtype sv_type)
+{
+void *xpv;
+new_body_inline(xpv, sv_type);
+return xpv;
+}
+#endif
+static const struct body_details fake_rv =
+{ 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
+/*
+=for apidoc sv_upgrade
+Upgrade an SV to a more complex form.  Generally adds a new body type to the
+SV, then copies across as much information as possible from the old body.
+It croaks if the SV is already in a more complex form than requested.  You
+generally want to use the C<SvUPGRADE> macro wrapper, which checks the type
+before calling C<sv_upgrade>, and hence does not croak.  See also
+C<svtype>.
+=cut
+*/
+void
+Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
+{
+void*	old_body;
+void*	new_body;
+const svtype old_type = SvTYPE(sv);
+const struct body_details *new_type_details;
+const struct body_details *old_type_details
+	= bodies_by_type + old_type;
+SV *referant = NULL;
+PERL_ARGS_ASSERT_SV_UPGRADE;
+if (old_type == new_type)
+	return;
+/* This clause was purposefully added ahead of the early return above to
+the shared string hackery for (sort {$a <=> $b} keys %hash), with the
+inference by Nick I-S that it would fix other troublesome cases. See
+changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
+Given that shared hash key scalars are no longer PVIV, but PV, there is
+no longer need to unshare so as to free up the IVX slot for its proper
+purpose. So it's safe to move the early return earlier.  */
+if (new_type > SVt_PVMG && SvIsCOW(sv)) {
+	sv_force_normal_flags(sv, 0);
+}
+old_body = SvANY(sv);
+/* Copying structures onto other structures that have been neatly zeroed
+has a subtle gotcha. Consider XPVMG
++------+------+------+------+------+-------+-------+
+|     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |
++------+------+------+------+------+-------+-------+
+0      4      8     12     16     20      24      28
+where NVs are aligned to 8 bytes, so that sizeof that structure is
+actually 32 bytes long, with 4 bytes of padding at the end:
++------+------+------+------+------+-------+-------+------+
+|     NV      | CUR  | LEN  |  IV  | MAGIC | STASH | ???  |
++------+------+------+------+------+-------+-------+------+
+0      4      8     12     16     20      24      28     32
+so what happens if you allocate memory for this structure:
++------+------+------+------+------+-------+-------+------+------+...
+|     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |  GP  | NAME |
++------+------+------+------+------+-------+-------+------+------+...
+0      4      8     12     16     20      24      28     32     36
+zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
+expect, because you copy the area marked ??? onto GP. Now, ??? may have
+started out as zero once, but it's quite possible that it isn't. So now,
+rather than a nicely zeroed GP, you have it pointing somewhere random.
+Bugs ensue.
+(In fact, GP ends up pointing at a previous GP structure, because the
+principle cause of the padding in XPVMG getting garbage is a copy of
+sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
+this happens to be moot because XPVGV has been re-ordered, with GP
+no longer after STASH)
+So we are careful and work out the size of used parts of all the
+structures.  */
+switch (old_type) {
+case SVt_NULL:
+	break;
+case SVt_IV:
+	if (SvROK(sv)) {
+	    referant = SvRV(sv);
+	    old_type_details = &fake_rv;
+	    if (new_type == SVt_NV)
+		new_type = SVt_PVNV;
+	} else {
+	    if (new_type < SVt_PVIV) {
+		new_type = (new_type == SVt_NV)
+		    ? SVt_PVNV : SVt_PVIV;
+	    }
+	}
+	break;
+case SVt_NV:
+	if (new_type < SVt_PVNV) {
+	    new_type = SVt_PVNV;
+	}
+	break;
+case SVt_PV:
+	assert(new_type > SVt_PV);
+	STATIC_ASSERT_STMT(SVt_IV < SVt_PV);
+	STATIC_ASSERT_STMT(SVt_NV < SVt_PV);
+	break;
+case SVt_PVIV:
+	break;
+case SVt_PVNV:
+	break;
+case SVt_PVMG:
+	/* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
+	   there's no way that it can be safely upgraded, because perl.c
+	   expects to Safefree(SvANY(PL_mess_sv))  */
+	assert(sv != PL_mess_sv);
+	break;
+default:
+	if (UNLIKELY(old_type_details->cant_upgrade))
+	    Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
+		       sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
+}
+if (UNLIKELY(old_type > new_type))
+	Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
+		(int)old_type, (int)new_type);
+new_type_details = bodies_by_type + new_type;
+SvFLAGS(sv) &= ~SVTYPEMASK;
+SvFLAGS(sv) |= new_type;
+/* This can't happen, as SVt_NULL is <= all values of new_type, so one of
+the return statements above will have triggered.  */
+assert (new_type != SVt_NULL);
+switch (new_type) {
+case SVt_IV:
+	assert(old_type == SVt_NULL);
+	SET_SVANY_FOR_BODYLESS_IV(sv);
+	SvIV_set(sv, 0);
+	return;
+case SVt_NV:
+	assert(old_type == SVt_NULL);
+#if NVSIZE <= IVSIZE
+	SET_SVANY_FOR_BODYLESS_NV(sv);
+#else
+	SvANY(sv) = new_XNV();
+#endif
+	SvNV_set(sv, 0);
+	return;
+case SVt_PVHV:
+case SVt_PVAV:
+	assert(new_type_details->body_size);
+#ifndef PURIFY
+	assert(new_type_details->arena);
+	assert(new_type_details->arena_size);
+	/* This points to the start of the allocated area.  */
+	new_body_inline(new_body, new_type);
+	Zero(new_body, new_type_details->body_size, char);
+	new_body = ((char *)new_body) - new_type_details->offset;
+#else
+	/* We always allocated the full length item with PURIFY. To do this
+	   we fake things so that arena is false for all 16 types..  */
+	new_body = new_NOARENAZ(new_type_details);
+#endif
+	SvANY(sv) = new_body;
+	if (new_type == SVt_PVAV) {
+	    AvMAX(sv)	= -1;
+	    AvFILLp(sv)	= -1;
+	    AvREAL_only(sv);
+	    if (old_type_details->body_size) {
+		AvALLOC(sv) = 0;
+	    } else {
+		/* It will have been zeroed when the new body was allocated.
+		   Lets not write to it, in case it confuses a write-back
+		   cache.  */
+	    }
+	} else {
+	    assert(!SvOK(sv));
+	    SvOK_off(sv);
+#ifndef NODEFAULT_SHAREKEYS
+	    HvSHAREKEYS_on(sv);         /* key-sharing on by default */
+#endif
+/* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
+	    HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
+	}
+	/* SVt_NULL isn't the only thing upgraded to AV or HV.
+	   The target created by newSVrv also is, and it can have magic.
+	   However, it never has SvPVX set.
+	*/
+	if (old_type == SVt_IV) {
+	    assert(!SvROK(sv));
+	} else if (old_type >= SVt_PV) {
+	    assert(SvPVX_const(sv) == 0);
+	}
+	if (old_type >= SVt_PVMG) {
+	    SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
+	    SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
+	} else {
+	    sv->sv_u.svu_array = NULL; /* or svu_hash  */
+	}
+	break;
+case SVt_PVIV:
+	/* XXX Is this still needed?  Was it ever needed?   Surely as there is
+	   no route from NV to PVIV, NOK can never be true  */
+	assert(!SvNOKp(sv));
+	assert(!SvNOK(sv));
+/* FALLTHROUGH */
+case SVt_PVIO:
+case SVt_PVFM:
+case SVt_PVGV:
+case SVt_PVCV:
+case SVt_PVLV:
+case SVt_INVLIST:
+case SVt_REGEXP:
+case SVt_PVMG:
+case SVt_PVNV:
+case SVt_PV:
+	assert(new_type_details->body_size);
+	/* We always allocated the full length item with PURIFY. To do this
+	   we fake things so that arena is false for all 16 types..  */
+	if(new_type_details->arena) {
+	    /* This points to the start of the allocated area.  */
+	    new_body_inline(new_body, new_type);
+	    Zero(new_body, new_type_details->body_size, char);
+	    new_body = ((char *)new_body) - new_type_details->offset;
+	} else {
+	    new_body = new_NOARENAZ(new_type_details);
+	}
+	SvANY(sv) = new_body;
+	if (old_type_details->copy) {
+	    /* There is now the potential for an upgrade from something without
+	       an offset (PVNV or PVMG) to something with one (PVCV, PVFM)  */
+	    int offset = old_type_details->offset;
+	    int length = old_type_details->copy;
+	    if (new_type_details->offset > old_type_details->offset) {
+		const int difference
+		    = new_type_details->offset - old_type_details->offset;
+		offset += difference;
+		length -= difference;
+	    }
+	    assert (length >= 0);
+	    Copy((char *)old_body + offset, (char *)new_body + offset, length,
+		 char);
+	}
+#ifndef NV_ZERO_IS_ALLBITS_ZERO
+	/* If NV 0.0 is stores as all bits 0 then Zero() already creates a
+	 * correct 0.0 for us.  Otherwise, if the old body didn't have an
+	 * NV slot, but the new one does, then we need to initialise the
+	 * freshly created NV slot with whatever the correct bit pattern is
+	 * for 0.0  */
+	if (old_type_details->zero_nv && !new_type_details->zero_nv
+	    && !isGV_with_GP(sv))
+	    SvNV_set(sv, 0);
+#endif
+	if (UNLIKELY(new_type == SVt_PVIO)) {
+	    IO * const io = MUTABLE_IO(sv);
+	    GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
+	    SvOBJECT_on(io);
+	    /* Clear the stashcache because a new IO could overrule a package
+	       name */
+DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
+	    hv_clear(PL_stashcache);
+	    SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
+	    IoPAGE_LEN(sv) = 60;
+	}
+	if (UNLIKELY(new_type == SVt_REGEXP))
+	    sv->sv_u.svu_rx = (regexp *)new_body;
+	else if (old_type < SVt_PV) {
+	    /* referant will be NULL unless the old type was SVt_IV emulating
+	       SVt_RV */
+	    sv->sv_u.svu_rv = referant;
+	}
+	break;
+default:
+	Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
+		   (unsigned long)new_type);
+}
+/* if this is zero, this is a body-less SVt_NULL, SVt_IV/SVt_RV,
+and sometimes SVt_NV */
+if (old_type_details->body_size) {
+#ifdef PURIFY
+	safefree(old_body);
+#else
+	/* Note that there is an assumption that all bodies of types that
+	   can be upgraded came from arenas. Only the more complex non-
+	   upgradable types are allowed to be directly malloc()ed.  */
+	assert(old_type_details->arena);
+	del_body((void*)((char*)old_body + old_type_details->offset),
+		 &PL_body_roots[old_type]);
+#endif
+}
+}
+/*
+=for apidoc sv_backoff
+Remove any string offset.  You should normally use the C<SvOOK_off> macro
+wrapper instead.
+=cut
+*/
+int
+Perl_sv_backoff(SV *const sv)
+{
+STRLEN delta;
+const char * const s = SvPVX_const(sv);
+PERL_ARGS_ASSERT_SV_BACKOFF;
+assert(SvOOK(sv));
+assert(SvTYPE(sv) != SVt_PVHV);
+assert(SvTYPE(sv) != SVt_PVAV);
+SvOOK_offset(sv, delta);
+SvLEN_set(sv, SvLEN(sv) + delta);
+SvPV_set(sv, SvPVX(sv) - delta);
+Move(s, SvPVX(sv), SvCUR(sv)+1, char);
+SvFLAGS(sv) &= ~SVf_OOK;
+return 0;
+}
+/*
+=for apidoc sv_grow
+Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
+upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
+Use the C<SvGROW> wrapper instead.
+=cut
+*/
+static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags);
+char *
+Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
+{
+char *s;
+PERL_ARGS_ASSERT_SV_GROW;
+if (SvROK(sv))
+	sv_unref(sv);
+if (SvTYPE(sv) < SVt_PV) {
+	sv_upgrade(sv, SVt_PV);
+	s = SvPVX_mutable(sv);
+}
+else if (SvOOK(sv)) {	/* pv is offset? */
+	sv_backoff(sv);
+	s = SvPVX_mutable(sv);
+	if (newlen > SvLEN(sv))
+	    newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
+}
+else
+{
+	if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0);
+	s = SvPVX_mutable(sv);
+}
+#ifdef PERL_NEW_COPY_ON_WRITE
+/* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
+* to store the COW count. So in general, allocate one more byte than
+* asked for, to make it likely this byte is always spare: and thus
+* make more strings COW-able.
+* If the new size is a big power of two, don't bother: we assume the
+* caller wanted a nice 2^N sized block and will be annoyed at getting
+* 2^N+1.
+* Only increment if the allocation isn't MEM_SIZE_MAX,
+* otherwise it will wrap to 0.
+*/
+if (newlen & 0xff && newlen != MEM_SIZE_MAX)
+newlen++;
+#endif
+#if defined(PERL_USE_MALLOC_SIZE) && defined(Perl_safesysmalloc_size)
+#define PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
+#endif
+if (newlen > SvLEN(sv)) {		/* need more room? */
+	STRLEN minlen = SvCUR(sv);
+	minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
+	if (newlen < minlen)
+	    newlen = minlen;
+#ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
+/* Don't round up on the first allocation, as odds are pretty good that
+* the initial request is accurate as to what is really needed */
+if (SvLEN(sv)) {
+STRLEN rounded = PERL_STRLEN_ROUNDUP(newlen);
+if (rounded > newlen)
+newlen = rounded;
+}
+#endif
+	if (SvLEN(sv) && s) {
+	    s = (char*)saferealloc(s, newlen);
+	}
+	else {
+	    s = (char*)safemalloc(newlen);
+	    if (SvPVX_const(sv) && SvCUR(sv)) {
+	        Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
+	    }
+	}
+	SvPV_set(sv, s);
+#ifdef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
+	/* Do this here, do it once, do it right, and then we will never get
+	   called back into sv_grow() unless there really is some growing
+	   needed.  */
+	SvLEN_set(sv, Perl_safesysmalloc_size(s));
+#else
+SvLEN_set(sv, newlen);
+#endif
+}
+return s;
+}
+/*
+=for apidoc sv_setiv
+Copies an integer into the given SV, upgrading first if necessary.
+Does not handle 'set' magic.  See also C<sv_setiv_mg>.
+=cut
+*/
+void
+Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
+{
+PERL_ARGS_ASSERT_SV_SETIV;
+SV_CHECK_THINKFIRST_COW_DROP(sv);
+switch (SvTYPE(sv)) {
+case SVt_NULL:
+case SVt_NV:
+	sv_upgrade(sv, SVt_IV);
+	break;
+case SVt_PV:
+	sv_upgrade(sv, SVt_PVIV);
+	break;
+case SVt_PVGV:
+	if (!isGV_with_GP(sv))
+	    break;
+case SVt_PVAV:
+case SVt_PVHV:
+case SVt_PVCV:
+case SVt_PVFM:
+case SVt_PVIO:
+	/* diag_listed_as: Can't coerce %s to %s in %s */
+	Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
+		   OP_DESC(PL_op));
+default: NOOP;
+}
+(void)SvIOK_only(sv);			/* validate number */
+SvIV_set(sv, i);
+SvTAINT(sv);
+}
+/*
+=for apidoc sv_setiv_mg
+Like C<sv_setiv>, but also handles 'set' magic.
+=cut
+*/
+void
+Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i)
+{
+PERL_ARGS_ASSERT_SV_SETIV_MG;
+sv_setiv(sv,i);
+SvSETMAGIC(sv);
+}
+/*
+=for apidoc sv_setuv
+Copies an unsigned integer into the given SV, upgrading first if necessary.
+Does not handle 'set' magic.  See also C<sv_setuv_mg>.
+=cut
+*/
+void
+Perl_sv_setuv(pTHX_ SV *const sv, const UV u)
+{
+PERL_ARGS_ASSERT_SV_SETUV;
+/* With the if statement to ensure that integers are stored as IVs whenever
+possible:
+u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
+without
+u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
+If you wish to remove the following if statement, so that this routine
+(and its callers) always return UVs, please benchmark to see what the
+effect is. Modern CPUs may be different. Or may not :-)
+*/
+if (u <= (UV)IV_MAX) {
+sv_setiv(sv, (IV)u);
+return;
+}
+sv_setiv(sv, 0);
+SvIsUV_on(sv);
+SvUV_set(sv, u);
+}
+/*
+=for apidoc sv_setuv_mg
+Like C<sv_setuv>, but also handles 'set' magic.
+=cut
+*/
+void
+Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u)
+{
+PERL_ARGS_ASSERT_SV_SETUV_MG;
+sv_setuv(sv,u);
+SvSETMAGIC(sv);
+}
+/*
+=for apidoc sv_setnv
+Copies a double into the given SV, upgrading first if necessary.
+Does not handle 'set' magic.  See also C<sv_setnv_mg>.
+=cut
+*/
+void
+Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
+{
+PERL_ARGS_ASSERT_SV_SETNV;
+SV_CHECK_THINKFIRST_COW_DROP(sv);
+switch (SvTYPE(sv)) {
+case SVt_NULL:
+case SVt_IV:
+	sv_upgrade(sv, SVt_NV);
+	break;
+case SVt_PV:
+case SVt_PVIV:
+	sv_upgrade(sv, SVt_PVNV);
+	break;
+case SVt_PVGV:
+	if (!isGV_with_GP(sv))
+	    break;
+case SVt_PVAV:
+case SVt_PVHV:
+case SVt_PVCV:
+case SVt_PVFM:
+case SVt_PVIO:
+	/* diag_listed_as: Can't coerce %s to %s in %s */
+	Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
+		   OP_DESC(PL_op));
+default: NOOP;
+}
+SvNV_set(sv, num);
+(void)SvNOK_only(sv);			/* validate number */
+SvTAINT(sv);
+}
+/*
+=for apidoc sv_setnv_mg
+Like C<sv_setnv>, but also handles 'set' magic.
+=cut
+*/
+void
+Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
+{
+PERL_ARGS_ASSERT_SV_SETNV_MG;
+sv_setnv(sv,num);
+SvSETMAGIC(sv);
+}
+/* Return a cleaned-up, printable version of sv, for non-numeric, or
+* not incrementable warning display.
+* Originally part of S_not_a_number().
+* The return value may be != tmpbuf.
+*/
+STATIC const char *
+S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) {
+const char *pv;
+PERL_ARGS_ASSERT_SV_DISPLAY;
+if (DO_UTF8(sv)) {
+SV *dsv = newSVpvs_flags("", SVs_TEMP);
+pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT);
+} else {
+	  char *d = tmpbuf;
+	  const char * const limit = tmpbuf + tmpbuf_size - 8;
+	  /* each *s can expand to 4 chars + "...\0",
+	     i.e. need room for 8 chars */
+	  const char *s = SvPVX_const(sv);
+	  const char * const end = s + SvCUR(sv);
+	  for ( ; s < end && d < limit; s++ ) {
+	       int ch = *s & 0xFF;
+	       if (! isASCII(ch) && !isPRINT_LC(ch)) {
+		    *d++ = 'M';
+		    *d++ = '-';
+/* Map to ASCII "equivalent" of Latin1 */
+		    ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127);
+	       }
+	       if (ch == '\n') {
+		    *d++ = '\\';
+		    *d++ = 'n';
+	       }
+	       else if (ch == '\r') {
+		    *d++ = '\\';
+		    *d++ = 'r';
+	       }
+	       else if (ch == '\f') {
+		    *d++ = '\\';
+		    *d++ = 'f';
+	       }
+	       else if (ch == '\\') {
+		    *d++ = '\\';
+		    *d++ = '\\';
+	       }
+	       else if (ch == '\0') {
+		    *d++ = '\\';
+		    *d++ = '0';
+	       }
+	       else if (isPRINT_LC(ch))
+		    *d++ = ch;
+	       else {
+		    *d++ = '^';
+		    *d++ = toCTRL(ch);
+	       }
+	  }
+	  if (s < end) {
+	       *d++ = '.';
+	       *d++ = '.';
+	       *d++ = '.';
+	  }
+	  *d = '\0';
+	  pv = tmpbuf;
+}
+return pv;
+}
+/* Print an "isn't numeric" warning, using a cleaned-up,
+* printable version of the offending string
+*/
+STATIC void
+S_not_a_number(pTHX_ SV *const sv)
+{
+char tmpbuf[64];
+const char *pv;
+PERL_ARGS_ASSERT_NOT_A_NUMBER;
+pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
+if (PL_op)
+	Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
+		    /* diag_listed_as: Argument "%s" isn't numeric%s */
+		    "Argument \"%s\" isn't numeric in %s", pv,
+		    OP_DESC(PL_op));
+else
+	Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
+		    /* diag_listed_as: Argument "%s" isn't numeric%s */
+		    "Argument \"%s\" isn't numeric", pv);
+}
+STATIC void
+S_not_incrementable(pTHX_ SV *const sv) {
+char tmpbuf[64];
+const char *pv;
+PERL_ARGS_ASSERT_NOT_INCREMENTABLE;
+pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
+Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
+"Argument \"%s\" treated as 0 in increment (++)", pv);
+}
+/*
+=for apidoc looks_like_number
+Test if the content of an SV looks like a number (or is a number).
+C<Inf> and C<Infinity> are treated as numbers (so will not issue a
+non-numeric warning), even if your atof() doesn't grok them.  Get-magic is
+ignored.
+=cut
+*/
+I32
+Perl_looks_like_number(pTHX_ SV *const sv)
+{
+const char *sbegin;
+STRLEN len;
+int numtype;
+PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
+if (SvPOK(sv) || SvPOKp(sv)) {
+	sbegin = SvPV_nomg_const(sv, len);
+}
+else
+	return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
+numtype = grok_number(sbegin, len, NULL);
+return ((numtype & IS_NUMBER_TRAILING)) ? 0 : numtype;
+}
+STATIC bool
+S_glob_2number(pTHX_ GV * const gv)
+{
+PERL_ARGS_ASSERT_GLOB_2NUMBER;
+/* We know that all GVs stringify to something that is not-a-number,
+	so no need to test that.  */
+if (ckWARN(WARN_NUMERIC))
+{
+	SV *const buffer = sv_newmortal();
+	gv_efullname3(buffer, gv, "*");
+	not_a_number(buffer);
+}
+/* We just want something true to return, so that S_sv_2iuv_common
+	can tail call us and return true.  */
+return TRUE;
+}
+/* Actually, ISO C leaves conversion of UV to IV undefined, but
+until proven guilty, assume that things are not that bad... */
+/*
+NV_PRESERVES_UV:
+As 64 bit platforms often have an NV that doesn't preserve all bits of
+an IV (an assumption perl has been based on to date) it becomes necessary
+to remove the assumption that the NV always carries enough precision to
+recreate the IV whenever needed, and that the NV is the canonical form.
+Instead, IV/UV and NV need to be given equal rights. So as to not lose
+precision as a side effect of conversion (which would lead to insanity
+and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
+1) to distinguish between IV/UV/NV slots that have a valid conversion cached
+where precision was lost, and IV/UV/NV slots that have a valid conversion
+which has lost no precision
+2) to ensure that if a numeric conversion to one form is requested that
+would lose precision, the precise conversion (or differently
+imprecise conversion) is also performed and cached, to prevent
+requests for different numeric formats on the same SV causing
+lossy conversion chains. (lossless conversion chains are perfectly
+acceptable (still))
+flags are used:
+SvIOKp is true if the IV slot contains a valid value
+SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
+SvNOKp is true if the NV slot contains a valid value
+SvNOK  is true only if the NV value is accurate
+so
+while converting from PV to NV, check to see if converting that NV to an
+IV(or UV) would lose accuracy over a direct conversion from PV to
+IV(or UV). If it would, cache both conversions, return NV, but mark
+SV as IOK NOKp (ie not NOK).
+While converting from PV to IV, check to see if converting that IV to an
+NV would lose accuracy over a direct conversion from PV to NV. If it
+would, cache both conversions, flag similarly.
+Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
+correctly because if IV & NV were set NV *always* overruled.
+Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
+changes - now IV and NV together means that the two are interchangeable:
+SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
+The benefit of this is that operations such as pp_add know that if
+SvIOK is true for both left and right operands, then integer addition
+can be used instead of floating point (for cases where the result won't
+overflow). Before, floating point was always used, which could lead to
+loss of precision compared with integer addition.
+* making IV and NV equal status should make maths accurate on 64 bit
+platforms
+* may speed up maths somewhat if pp_add and friends start to use
+integers when possible instead of fp. (Hopefully the overhead in
+looking for SvIOK and checking for overflow will not outweigh the
+fp to integer speedup)
+* will slow down integer operations (callers of SvIV) on "inaccurate"
+values, as the change from SvIOK to SvIOKp will cause a call into
+sv_2iv each time rather than a macro access direct to the IV slot
+* should speed up number->string conversion on integers as IV is
+favoured when IV and NV are equally accurate
+####################################################################
+You had better be using SvIOK_notUV if you want an IV for arithmetic:
+SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
+On the other hand, SvUOK is true iff UV.
+####################################################################
+Your mileage will vary depending your CPU's relative fp to integer
+performance ratio.
+*/
+#ifndef NV_PRESERVES_UV
+#  define IS_NUMBER_UNDERFLOW_IV 1
+#  define IS_NUMBER_UNDERFLOW_UV 2
+#  define IS_NUMBER_IV_AND_UV    2
+#  define IS_NUMBER_OVERFLOW_IV  4
+#  define IS_NUMBER_OVERFLOW_UV  5
+/* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
+/* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
+STATIC int
+S_sv_2iuv_non_preserve(pTHX_ SV *const sv
+#  ifdef DEBUGGING
+		       , I32 numtype
+#  endif
+		       )
+{
+PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
+PERL_UNUSED_CONTEXT;
+DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
+if (SvNVX(sv) < (NV)IV_MIN) {
+	(void)SvIOKp_on(sv);
+	(void)SvNOK_on(sv);
+	SvIV_set(sv, IV_MIN);
+	return IS_NUMBER_UNDERFLOW_IV;
+}
+if (SvNVX(sv) > (NV)UV_MAX) {
+	(void)SvIOKp_on(sv);
+	(void)SvNOK_on(sv);
+	SvIsUV_on(sv);
+	SvUV_set(sv, UV_MAX);
+	return IS_NUMBER_OVERFLOW_UV;
+}
+(void)SvIOKp_on(sv);
+(void)SvNOK_on(sv);
+/* Can't use strtol etc to convert this string.  (See truth table in
+sv_2iv  */
+if (SvNVX(sv) <= (UV)IV_MAX) {
+SvIV_set(sv, I_V(SvNVX(sv)));
+if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
+SvIOK_on(sv); /* Integer is precise. NOK, IOK */
+} else {
+/* Integer is imprecise. NOK, IOKp */
+}
+return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
+}
+SvIsUV_on(sv);
+SvUV_set(sv, U_V(SvNVX(sv)));
+if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
+if (SvUVX(sv) == UV_MAX) {
+/* As we know that NVs don't preserve UVs, UV_MAX cannot
+possibly be preserved by NV. Hence, it must be overflow.
+NOK, IOKp */
+return IS_NUMBER_OVERFLOW_UV;
+}
+SvIOK_on(sv); /* Integer is precise. NOK, UOK */
+} else {
+/* Integer is imprecise. NOK, IOKp */
+}
+return IS_NUMBER_OVERFLOW_IV;
+}
+#endif /* !NV_PRESERVES_UV*/
+/* If numtype is infnan, set the NV of the sv accordingly.
+* If numtype is anything else, try setting the NV using Atof(PV). */
+#ifdef USING_MSVC6
+#  pragma warning(push)
+#  pragma warning(disable:4756;disable:4056)
+#endif
+static void
+S_sv_setnv(pTHX_ SV* sv, int numtype)
+{
+bool pok = cBOOL(SvPOK(sv));
+bool nok = FALSE;
+if ((numtype & IS_NUMBER_INFINITY)) {
+SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
+nok = TRUE;
+}
+else if ((numtype & IS_NUMBER_NAN)) {
+SvNV_set(sv, NV_NAN);
+nok = TRUE;
+}
+else if (pok) {
+SvNV_set(sv, Atof(SvPVX_const(sv)));
+/* Purposefully no true nok here, since we don't want to blow
+* away the possible IOK/UV of an existing sv. */
+}
+if (nok) {
+SvNOK_only(sv); /* No IV or UV please, this is pure infnan. */
+if (pok)
+SvPOK_on(sv); /* PV is okay, though. */
+}
+}
+#ifdef USING_MSVC6
+#  pragma warning(pop)
+#endif
+STATIC bool
+S_sv_2iuv_common(pTHX_ SV *const sv)
+{
+PERL_ARGS_ASSERT_SV_2IUV_COMMON;
+if (SvNOKp(sv)) {
+	/* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
+	 * without also getting a cached IV/UV from it at the same time
+	 * (ie PV->NV conversion should detect loss of accuracy and cache
+	 * IV or UV at same time to avoid this. */
+	/* IV-over-UV optimisation - choose to cache IV if possible */
+	if (SvTYPE(sv) == SVt_NV)
+	    sv_upgrade(sv, SVt_PVNV);
+	(void)SvIOKp_on(sv);	/* Must do this first, to clear any SvOOK */
+	/* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
+	   certainly cast into the IV range at IV_MAX, whereas the correct
+	   answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
+	   cases go to UV */
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+	if (Perl_isnan(SvNVX(sv))) {
+	    SvUV_set(sv, 0);
+	    SvIsUV_on(sv);
+	    return FALSE;
+	}
+#endif
+	if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
+	    SvIV_set(sv, I_V(SvNVX(sv)));
+	    if (SvNVX(sv) == (NV) SvIVX(sv)
+#ifndef NV_PRESERVES_UV
+&& SvIVX(sv) != IV_MIN /* avoid negating IV_MIN below */
+		&& (((UV)1 << NV_PRESERVES_UV_BITS) >
+		    (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
+		/* Don't flag it as "accurately an integer" if the number
+		   came from a (by definition imprecise) NV operation, and
+		   we're outside the range of NV integer precision */
+#endif
+		) {
+		if (SvNOK(sv))
+		    SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
+		else {
+		    /* scalar has trailing garbage, eg "42a" */
+		}
+		DEBUG_c(PerlIO_printf(Perl_debug_log,
+				      "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
+				      PTR2UV(sv),
+				      SvNVX(sv),
+				      SvIVX(sv)));
+	    } else {
+		/* IV not precise.  No need to convert from PV, as NV
+		   conversion would already have cached IV if it detected
+		   that PV->IV would be better than PV->NV->IV
+		   flags already correct - don't set public IOK.  */
+		DEBUG_c(PerlIO_printf(Perl_debug_log,
+				      "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
+				      PTR2UV(sv),
+				      SvNVX(sv),
+				      SvIVX(sv)));
+	    }
+	    /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
+	       but the cast (NV)IV_MIN rounds to a the value less (more
+	       negative) than IV_MIN which happens to be equal to SvNVX ??
+	       Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
+	       NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
+	       (NV)UVX == NVX are both true, but the values differ. :-(
+	       Hopefully for 2s complement IV_MIN is something like
+	       0x8000000000000000 which will be exact. NWC */
+	}
+	else {
+	    SvUV_set(sv, U_V(SvNVX(sv)));
+	    if (
+		(SvNVX(sv) == (NV) SvUVX(sv))
+#ifndef  NV_PRESERVES_UV
+		/* Make sure it's not 0xFFFFFFFFFFFFFFFF */
+		/*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
+		&& (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
+		/* Don't flag it as "accurately an integer" if the number
+		   came from a (by definition imprecise) NV operation, and
+		   we're outside the range of NV integer precision */
+#endif
+		&& SvNOK(sv)
+		)
+		SvIOK_on(sv);
+	    SvIsUV_on(sv);
+	    DEBUG_c(PerlIO_printf(Perl_debug_log,
+				  "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
+				  PTR2UV(sv),
+				  SvUVX(sv),
+				  SvUVX(sv)));
+	}
+}
+else if (SvPOKp(sv)) {
+	UV value;
+	const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
+	/* We want to avoid a possible problem when we cache an IV/ a UV which
+	   may be later translated to an NV, and the resulting NV is not
+	   the same as the direct translation of the initial string
+	   (eg 123.456 can shortcut to the IV 123 with atol(), but we must
+	   be careful to ensure that the value with the .456 is around if the
+	   NV value is requested in the future).
+	   This means that if we cache such an IV/a UV, we need to cache the
+	   NV as well.  Moreover, we trade speed for space, and do not
+	   cache the NV if we are sure it's not needed.
+	 */
+	/* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
+	if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
+	     == IS_NUMBER_IN_UV) {
+	    /* It's definitely an integer, only upgrade to PVIV */
+	    if (SvTYPE(sv) < SVt_PVIV)
+		sv_upgrade(sv, SVt_PVIV);
+	    (void)SvIOK_on(sv);
+	} else if (SvTYPE(sv) < SVt_PVNV)
+	    sv_upgrade(sv, SVt_PVNV);
+if ((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN))) {
+if (ckWARN(WARN_NUMERIC) && ((numtype & IS_NUMBER_TRAILING)))
+		not_a_number(sv);
+S_sv_setnv(aTHX_ sv, numtype);
+return FALSE;
+}
+	/* If NVs preserve UVs then we only use the UV value if we know that
+	   we aren't going to call atof() below. If NVs don't preserve UVs
+	   then the value returned may have more precision than atof() will
+	   return, even though value isn't perfectly accurate.  */
+	if ((numtype & (IS_NUMBER_IN_UV
+#ifdef NV_PRESERVES_UV
+			| IS_NUMBER_NOT_INT
+#endif
+	    )) == IS_NUMBER_IN_UV) {
+	    /* This won't turn off the public IOK flag if it was set above  */
+	    (void)SvIOKp_on(sv);
+	    if (!(numtype & IS_NUMBER_NEG)) {
+		/* positive */;
+		if (value <= (UV)IV_MAX) {
+		    SvIV_set(sv, (IV)value);
+		} else {
+		    /* it didn't overflow, and it was positive. */
+		    SvUV_set(sv, value);
+		    SvIsUV_on(sv);
+		}
+	    } else {
+		/* 2s complement assumption  */
+		if (value <= (UV)IV_MIN) {
+		    SvIV_set(sv, value == (UV)IV_MIN
+? IV_MIN : -(IV)value);
+		} else {
+		    /* Too negative for an IV.  This is a double upgrade, but
+		       I'm assuming it will be rare.  */
+		    if (SvTYPE(sv) < SVt_PVNV)
+			sv_upgrade(sv, SVt_PVNV);
+		    SvNOK_on(sv);
+		    SvIOK_off(sv);
+		    SvIOKp_on(sv);
+		    SvNV_set(sv, -(NV)value);
+		    SvIV_set(sv, IV_MIN);
+		}
+	    }
+	}
+	/* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
+will be in the previous block to set the IV slot, and the next
+block to set the NV slot.  So no else here.  */
+	if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
+	    != IS_NUMBER_IN_UV) {
+	    /* It wasn't an (integer that doesn't overflow the UV). */
+S_sv_setnv(aTHX_ sv, numtype);
+	    if (! numtype && ckWARN(WARN_NUMERIC))
+		not_a_number(sv);
+	    DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" NVgf ")\n",
+				  PTR2UV(sv), SvNVX(sv)));
+#ifdef NV_PRESERVES_UV
+(void)SvIOKp_on(sv);
+(void)SvNOK_on(sv);
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+if (Perl_isnan(SvNVX(sv))) {
+SvUV_set(sv, 0);
+SvIsUV_on(sv);
+return FALSE;
+}
+#endif
+if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
+SvIV_set(sv, I_V(SvNVX(sv)));
+if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
+SvIOK_on(sv);
+} else {
+		    NOOP;  /* Integer is imprecise. NOK, IOKp */
+}
+/* UV will not work better than IV */
+} else {
+if (SvNVX(sv) > (NV)UV_MAX) {
+SvIsUV_on(sv);
+/* Integer is inaccurate. NOK, IOKp, is UV */
+SvUV_set(sv, UV_MAX);
+} else {
+SvUV_set(sv, U_V(SvNVX(sv)));
+/* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
+NV preservse UV so can do correct comparison.  */
+if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
+SvIOK_on(sv);
+} else {
+			NOOP;   /* Integer is imprecise. NOK, IOKp, is UV */
+}
+}
+		SvIsUV_on(sv);
+}
+#else /* NV_PRESERVES_UV */
+if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
+== (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
+/* The IV/UV slot will have been set from value returned by
+grok_number above.  The NV slot has just been set using
+Atof.  */
+	        SvNOK_on(sv);
+assert (SvIOKp(sv));
+} else {
+if (((UV)1 << NV_PRESERVES_UV_BITS) >
+U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
+/* Small enough to preserve all bits. */
+(void)SvIOKp_on(sv);
+SvNOK_on(sv);
+SvIV_set(sv, I_V(SvNVX(sv)));
+if ((NV)(SvIVX(sv)) == SvNVX(sv))
+SvIOK_on(sv);
+/* Assumption: first non-preserved integer is < IV_MAX,
+this NV is in the preserved range, therefore: */
+if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
+< (UV)IV_MAX)) {
+Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
+}
+} else {
+/* IN_UV NOT_INT
+0      0	already failed to read UV.
+0      1       already failed to read UV.
+1      0       you won't get here in this case. IV/UV
+	        slot set, public IOK, Atof() unneeded.
+1      1       already read UV.
+so there's no point in sv_2iuv_non_preserve() attempting
+to use atol, strtol, strtoul etc.  */
+#  ifdef DEBUGGING
+sv_2iuv_non_preserve (sv, numtype);
+#  else
+sv_2iuv_non_preserve (sv);
+#  endif
+}
+}
+#endif /* NV_PRESERVES_UV */
+	/* It might be more code efficient to go through the entire logic above
+	   and conditionally set with SvIOKp_on() rather than SvIOK(), but it
+	   gets complex and potentially buggy, so more programmer efficient
+	   to do it this way, by turning off the public flags:  */
+	if (!numtype)
+	    SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
+	}
+}
+else  {
+	if (isGV_with_GP(sv))
+	    return glob_2number(MUTABLE_GV(sv));
+	if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
+		report_uninit(sv);
+	if (SvTYPE(sv) < SVt_IV)
+	    /* Typically the caller expects that sv_any is not NULL now.  */
+	    sv_upgrade(sv, SVt_IV);
+	/* Return 0 from the caller.  */
+	return TRUE;
+}
+return FALSE;
+}
+/*
+=for apidoc sv_2iv_flags
+Return the integer value of an SV, doing any necessary string
+conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
+Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
+=cut
+*/
+IV
+Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
+{
+PERL_ARGS_ASSERT_SV_2IV_FLAGS;
+assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
+	 && SvTYPE(sv) != SVt_PVFM);
+if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
+	mg_get(sv);
+if (SvROK(sv)) {
+	if (SvAMAGIC(sv)) {
+	    SV * tmpstr;
+	    if (flags & SV_SKIP_OVERLOAD)
+		return 0;
+	    tmpstr = AMG_CALLunary(sv, numer_amg);
+	    if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+		return SvIV(tmpstr);
+	    }
+	}
+	return PTR2IV(SvRV(sv));
+}
+if (SvVALID(sv) || isREGEXP(sv)) {
+	/* FBMs use the space for SvIVX and SvNVX for other purposes, and use
+	   the same flag bit as SVf_IVisUV, so must not let them cache IVs.
+	   In practice they are extremely unlikely to actually get anywhere
+	   accessible by user Perl code - the only way that I'm aware of is when
+	   a constant subroutine which is used as the second argument to index.
+	   Regexps have no SvIVX and SvNVX fields.
+	*/
+	assert(isREGEXP(sv) || SvPOKp(sv));
+	{
+	    UV value;
+	    const char * const ptr =
+		isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
+	    const int numtype
+		= grok_number(ptr, SvCUR(sv), &value);
+	    if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
+		== IS_NUMBER_IN_UV) {
+		/* It's definitely an integer */
+		if (numtype & IS_NUMBER_NEG) {
+		    if (value < (UV)IV_MIN)
+			return -(IV)value;
+		} else {
+		    if (value < (UV)IV_MAX)
+			return (IV)value;
+		}
+	    }
+/* Quite wrong but no good choices. */
+if ((numtype & IS_NUMBER_INFINITY)) {
+return (numtype & IS_NUMBER_NEG) ? IV_MIN : IV_MAX;
+} else if ((numtype & IS_NUMBER_NAN)) {
+return 0; /* So wrong. */
+}
+	    if (!numtype) {
+		if (ckWARN(WARN_NUMERIC))
+		    not_a_number(sv);
+	    }
+	    return I_V(Atof(ptr));
+	}
+}
+if (SvTHINKFIRST(sv)) {
+#ifdef PERL_OLD_COPY_ON_WRITE
+	if (SvIsCOW(sv)) {
+	    sv_force_normal_flags(sv, 0);
+	}
+#endif
+	if (SvREADONLY(sv) && !SvOK(sv)) {
+	    if (ckWARN(WARN_UNINITIALIZED))
+		report_uninit(sv);
+	    return 0;
+	}
+}
+if (!SvIOKp(sv)) {
+	if (S_sv_2iuv_common(aTHX_ sv))
+	    return 0;
+}
+DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
+	PTR2UV(sv),SvIVX(sv)));
+return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
+}
+/*
+=for apidoc sv_2uv_flags
+Return the unsigned integer value of an SV, doing any necessary string
+conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
+Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
+=cut
+*/
+UV
+Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
+{
+PERL_ARGS_ASSERT_SV_2UV_FLAGS;
+if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
+	mg_get(sv);
+if (SvROK(sv)) {
+	if (SvAMAGIC(sv)) {
+	    SV *tmpstr;
+	    if (flags & SV_SKIP_OVERLOAD)
+		return 0;
+	    tmpstr = AMG_CALLunary(sv, numer_amg);
+	    if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+		return SvUV(tmpstr);
+	    }
+	}
+	return PTR2UV(SvRV(sv));
+}
+if (SvVALID(sv) || isREGEXP(sv)) {
+	/* FBMs use the space for SvIVX and SvNVX for other purposes, and use
+	   the same flag bit as SVf_IVisUV, so must not let them cache IVs.
+	   Regexps have no SvIVX and SvNVX fields. */
+	assert(isREGEXP(sv) || SvPOKp(sv));
+	{
+	    UV value;
+	    const char * const ptr =
+		isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
+	    const int numtype
+		= grok_number(ptr, SvCUR(sv), &value);
+	    if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
+		== IS_NUMBER_IN_UV) {
+		/* It's definitely an integer */
+		if (!(numtype & IS_NUMBER_NEG))
+		    return value;
+	    }
+/* Quite wrong but no good choices. */
+if ((numtype & IS_NUMBER_INFINITY)) {
+return UV_MAX; /* So wrong. */
+} else if ((numtype & IS_NUMBER_NAN)) {
+return 0; /* So wrong. */
+}
+	    if (!numtype) {
+		if (ckWARN(WARN_NUMERIC))
+		    not_a_number(sv);
+	    }
+	    return U_V(Atof(ptr));
+	}
+}
+if (SvTHINKFIRST(sv)) {
+#ifdef PERL_OLD_COPY_ON_WRITE
+	if (SvIsCOW(sv)) {
+	    sv_force_normal_flags(sv, 0);
+	}
+#endif
+	if (SvREADONLY(sv) && !SvOK(sv)) {
+	    if (ckWARN(WARN_UNINITIALIZED))
+		report_uninit(sv);
+	    return 0;
+	}
+}
+if (!SvIOKp(sv)) {
+	if (S_sv_2iuv_common(aTHX_ sv))
+	    return 0;
+}
+DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
+			  PTR2UV(sv),SvUVX(sv)));
+return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
+}
+/*
+=for apidoc sv_2nv_flags
+Return the num value of an SV, doing any necessary string or integer
+conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
+Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
+=cut
+*/
+NV
+Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
+{
+PERL_ARGS_ASSERT_SV_2NV_FLAGS;
+assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
+	 && SvTYPE(sv) != SVt_PVFM);
+if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
+	/* FBMs use the space for SvIVX and SvNVX for other purposes, and use
+	   the same flag bit as SVf_IVisUV, so must not let them cache NVs.
+	   Regexps have no SvIVX and SvNVX fields.  */
+	const char *ptr;
+	if (flags & SV_GMAGIC)
+	    mg_get(sv);
+	if (SvNOKp(sv))
+	    return SvNVX(sv);
+	if (SvPOKp(sv) && !SvIOKp(sv)) {
+	    ptr = SvPVX_const(sv);
+	  grokpv:
+	    if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
+		!grok_number(ptr, SvCUR(sv), NULL))
+		not_a_number(sv);
+	    return Atof(ptr);
+	}
+	if (SvIOKp(sv)) {
+	    if (SvIsUV(sv))
+		return (NV)SvUVX(sv);
+	    else
+		return (NV)SvIVX(sv);
+	}
+if (SvROK(sv)) {
+	    goto return_rok;
+	}
+	if (isREGEXP(sv)) {
+	    ptr = RX_WRAPPED((REGEXP *)sv);
+	    goto grokpv;
+	}
+	assert(SvTYPE(sv) >= SVt_PVMG);
+	/* This falls through to the report_uninit near the end of the
+	   function. */
+} else if (SvTHINKFIRST(sv)) {
+	if (SvROK(sv)) {
+	return_rok:
+	    if (SvAMAGIC(sv)) {
+		SV *tmpstr;
+		if (flags & SV_SKIP_OVERLOAD)
+		    return 0;
+		tmpstr = AMG_CALLunary(sv, numer_amg);
+if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+		    return SvNV(tmpstr);
+		}
+	    }
+	    return PTR2NV(SvRV(sv));
+	}
+#ifdef PERL_OLD_COPY_ON_WRITE
+	if (SvIsCOW(sv)) {
+	    sv_force_normal_flags(sv, 0);
+	}
+#endif
+	if (SvREADONLY(sv) && !SvOK(sv)) {
+	    if (ckWARN(WARN_UNINITIALIZED))
+		report_uninit(sv);
+	    return 0.0;
+	}
+}
+if (SvTYPE(sv) < SVt_NV) {
+	/* The logic to use SVt_PVNV if necessary is in sv_upgrade.  */
+	sv_upgrade(sv, SVt_NV);
+	DEBUG_c({
+	    STORE_NUMERIC_LOCAL_SET_STANDARD();
+	    PerlIO_printf(Perl_debug_log,
+			  "0x%"UVxf" num(%" NVgf ")\n",
+			  PTR2UV(sv), SvNVX(sv));
+	    RESTORE_NUMERIC_LOCAL();
+	});
+}
+else if (SvTYPE(sv) < SVt_PVNV)
+	sv_upgrade(sv, SVt_PVNV);
+if (SvNOKp(sv)) {
+return SvNVX(sv);
+}
+if (SvIOKp(sv)) {
+	SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
+#ifdef NV_PRESERVES_UV
+	if (SvIOK(sv))
+	    SvNOK_on(sv);
+	else
+	    SvNOKp_on(sv);
+#else
+	/* Only set the public NV OK flag if this NV preserves the IV  */
+	/* Check it's not 0xFFFFFFFFFFFFFFFF */
+	if (SvIOK(sv) &&
+	    SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
+		       : (SvIVX(sv) == I_V(SvNVX(sv))))
+	    SvNOK_on(sv);
+	else
+	    SvNOKp_on(sv);
+#endif
+}
+else if (SvPOKp(sv)) {
+	UV value;
+	const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
+	if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
+	    not_a_number(sv);
+#ifdef NV_PRESERVES_UV
+	if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
+	    == IS_NUMBER_IN_UV) {
+	    /* It's definitely an integer */
+	    SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
+	} else {
+S_sv_setnv(aTHX_ sv, numtype);
+}
+	if (numtype)
+	    SvNOK_on(sv);
+	else
+	    SvNOKp_on(sv);
+#else
+	SvNV_set(sv, Atof(SvPVX_const(sv)));
+	/* Only set the public NV OK flag if this NV preserves the value in
+	   the PV at least as well as an IV/UV would.
+	   Not sure how to do this 100% reliably. */
+	/* if that shift count is out of range then Configure's test is
+	   wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
+	   UV_BITS */
+	if (((UV)1 << NV_PRESERVES_UV_BITS) >
+	    U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
+	    SvNOK_on(sv); /* Definitely small enough to preserve all bits */
+	} else if (!(numtype & IS_NUMBER_IN_UV)) {
+/* Can't use strtol etc to convert this string, so don't try.
+sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
+SvNOK_on(sv);
+} else {
+/* value has been set.  It may not be precise.  */
+	    if ((numtype & IS_NUMBER_NEG) && (value >= (UV)IV_MIN)) {
+		/* 2s complement assumption for (UV)IV_MIN  */
+SvNOK_on(sv); /* Integer is too negative.  */
+} else {
+SvNOKp_on(sv);
+SvIOKp_on(sv);
+if (numtype & IS_NUMBER_NEG) {
+/* -IV_MIN is undefined, but we should never reach
+* this point with both IS_NUMBER_NEG and value ==
+* (UV)IV_MIN */
+assert(value != (UV)IV_MIN);
+SvIV_set(sv, -(IV)value);
+} else if (value <= (UV)IV_MAX) {
+		    SvIV_set(sv, (IV)value);
+		} else {
+		    SvUV_set(sv, value);
+		    SvIsUV_on(sv);
+		}
+if (numtype & IS_NUMBER_NOT_INT) {
+/* I believe that even if the original PV had decimals,
+they are lost beyond the limit of the FP precision.
+However, neither is canonical, so both only get p
+flags.  NWC, 2000/11/25 */
+/* Both already have p flags, so do nothing */
+} else {
+		    const NV nv = SvNVX(sv);
+/* XXX should this spot have NAN_COMPARE_BROKEN, too? */
+if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
+if (SvIVX(sv) == I_V(nv)) {
+SvNOK_on(sv);
+} else {
+/* It had no "." so it must be integer.  */
+}
+			SvIOK_on(sv);
+} else {
+/* between IV_MAX and NV(UV_MAX).
+Could be slightly > UV_MAX */
+if (numtype & IS_NUMBER_NOT_INT) {
+/* UV and NV both imprecise.  */
+} else {
+			    const UV nv_as_uv = U_V(nv);
+if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
+SvNOK_on(sv);
+}
+			    SvIOK_on(sv);
+}
+}
+}
+}
+}
+	/* It might be more code efficient to go through the entire logic above
+	   and conditionally set with SvNOKp_on() rather than SvNOK(), but it
+	   gets complex and potentially buggy, so more programmer efficient
+	   to do it this way, by turning off the public flags:  */
+	if (!numtype)
+	    SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
+#endif /* NV_PRESERVES_UV */
+}
+else  {
+	if (isGV_with_GP(sv)) {
+	    glob_2number(MUTABLE_GV(sv));
+	    return 0.0;
+	}
+	if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
+	    report_uninit(sv);
+	assert (SvTYPE(sv) >= SVt_NV);
+	/* Typically the caller expects that sv_any is not NULL now.  */
+	/* XXX Ilya implies that this is a bug in callers that assume this
+	   and ideally should be fixed.  */
+	return 0.0;
+}
+DEBUG_c({
+	STORE_NUMERIC_LOCAL_SET_STANDARD();
+	PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" NVgf ")\n",
+		      PTR2UV(sv), SvNVX(sv));
+	RESTORE_NUMERIC_LOCAL();
+});
+return SvNVX(sv);
+}
+/*
+=for apidoc sv_2num
+Return an SV with the numeric value of the source SV, doing any necessary
+reference or overload conversion.  The caller is expected to have handled
+get-magic already.
+=cut
+*/
+SV *
+Perl_sv_2num(pTHX_ SV *const sv)
+{
+PERL_ARGS_ASSERT_SV_2NUM;
+if (!SvROK(sv))
+	return sv;
+if (SvAMAGIC(sv)) {
+	SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
+	TAINT_IF(tmpsv && SvTAINTED(tmpsv));
+	if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
+	    return sv_2num(tmpsv);
+}
+return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
+}
+/* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
+* UV as a string towards the end of buf, and return pointers to start and
+* end of it.
+*
+* We assume that buf is at least TYPE_CHARS(UV) long.
+*/
+static char *
+S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
+{
+char *ptr = buf + TYPE_CHARS(UV);
+char * const ebuf = ptr;
+int sign;
+PERL_ARGS_ASSERT_UIV_2BUF;
+if (is_uv)
+	sign = 0;
+else if (iv >= 0) {
+	uv = iv;
+	sign = 0;
+} else {
+uv = (iv == IV_MIN) ? (UV)iv : (UV)(-iv);
+	sign = 1;
+}
+do {
+	*--ptr = '0' + (char)(uv % 10);
+} while (uv /= 10);
+if (sign)
+	*--ptr = '-';
+*peob = ebuf;
+return ptr;
+}
+/* Helper for sv_2pv_flags and sv_vcatpvfn_flags.  If the NV is an
+* infinity or a not-a-number, writes the appropriate strings to the
+* buffer, including a zero byte.  On success returns the written length,
+* excluding the zero byte, on failure (not an infinity, not a nan, or the
+* maxlen too small) returns zero.
+*
+* XXX for "Inf", "-Inf", and "NaN", we could have three read-only
+* shared string constants we point to, instead of generating a new
+* string for each instance. */
+STATIC size_t
+S_infnan_2pv(NV nv, char* buffer, size_t maxlen, char plus) {
+assert(maxlen >= 4);
+if (maxlen < 4) /* "Inf\0", "NaN\0" */
+return 0;
+else {
+char* s = buffer;
+if (Perl_isinf(nv)) {
+if (nv < 0) {
+if (maxlen < 5) /* "-Inf\0"  */
+return 0;
+*s++ = '-';
+} else if (plus) {
+*s++ = '+';
+}
+*s++ = 'I';
+*s++ = 'n';
+*s++ = 'f';
+} else if (Perl_isnan(nv)) {
+*s++ = 'N';
+*s++ = 'a';
+*s++ = 'N';
+/* XXX optionally output the payload mantissa bits as
+* "(unsigned)" (to match the nan("...") C99 function,
+* or maybe as "(0xhhh...)"  would make more sense...
+* provide a format string so that the user can decide?
+* NOTE: would affect the maxlen and assert() logic.*/
+}
+else
+return 0;
+assert((s == buffer + 3) || (s == buffer + 4));
+*s++ = 0;
+return s - buffer - 1; /* -1: excluding the zero byte */
+}
+}
+/*
+=for apidoc sv_2pv_flags
+Returns a pointer to the string value of an SV, and sets *lp to its length.
+If flags includes SV_GMAGIC, does an mg_get() first.  Coerces sv to a
+string if necessary.  Normally invoked via the C<SvPV_flags> macro.
+C<sv_2pv()> and C<sv_2pv_nomg> usually end up here too.
+=cut
+*/
+char *
+Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
+{
+char *s;
+PERL_ARGS_ASSERT_SV_2PV_FLAGS;
+assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
+	 && SvTYPE(sv) != SVt_PVFM);
+if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
+	mg_get(sv);
+if (SvROK(sv)) {
+	if (SvAMAGIC(sv)) {
+	    SV *tmpstr;
+	    if (flags & SV_SKIP_OVERLOAD)
+		return NULL;
+	    tmpstr = AMG_CALLunary(sv, string_amg);
+	    TAINT_IF(tmpstr && SvTAINTED(tmpstr));
+	    if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+		/* Unwrap this:  */
+		/* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
+		 */
+		char *pv;
+		if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
+		    if (flags & SV_CONST_RETURN) {
+			pv = (char *) SvPVX_const(tmpstr);
+		    } else {
+			pv = (flags & SV_MUTABLE_RETURN)
+			    ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
+		    }
+		    if (lp)
+			*lp = SvCUR(tmpstr);
+		} else {
+		    pv = sv_2pv_flags(tmpstr, lp, flags);
+		}
+		if (SvUTF8(tmpstr))
+		    SvUTF8_on(sv);
+		else
+		    SvUTF8_off(sv);
+		return pv;
+	    }
+	}
+	{
+	    STRLEN len;
+	    char *retval;
+	    char *buffer;
+	    SV *const referent = SvRV(sv);
+	    if (!referent) {
+		len = 7;
+		retval = buffer = savepvn("NULLREF", len);
+	    } else if (SvTYPE(referent) == SVt_REGEXP &&
+		       (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) ||
+			amagic_is_enabled(string_amg))) {
+		REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
+		assert(re);
+		/* If the regex is UTF-8 we want the containing scalar to
+		   have an UTF-8 flag too */
+		if (RX_UTF8(re))
+		    SvUTF8_on(sv);
+		else
+		    SvUTF8_off(sv);
+		if (lp)
+		    *lp = RX_WRAPLEN(re);
+		return RX_WRAPPED(re);
+	    } else {
+		const char *const typestr = sv_reftype(referent, 0);
+		const STRLEN typelen = strlen(typestr);
+		UV addr = PTR2UV(referent);
+		const char *stashname = NULL;
+		STRLEN stashnamelen = 0; /* hush, gcc */
+		const char *buffer_end;
+		if (SvOBJECT(referent)) {
+		    const HEK *const name = HvNAME_HEK(SvSTASH(referent));
+		    if (name) {
+			stashname = HEK_KEY(name);
+			stashnamelen = HEK_LEN(name);
+			if (HEK_UTF8(name)) {
+			    SvUTF8_on(sv);
+			} else {
+			    SvUTF8_off(sv);
+			}
+		    } else {
+			stashname = "__ANON__";
+			stashnamelen = 8;
+		    }
+		    len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
+			+ 2 * sizeof(UV) + 2 /* )\0 */;
+		} else {
+		    len = typelen + 3 /* (0x */
+			+ 2 * sizeof(UV) + 2 /* )\0 */;
+		}
+		Newx(buffer, len, char);
+		buffer_end = retval = buffer + len;
+		/* Working backwards  */
+		*--retval = '\0';
+		*--retval = ')';
+		do {
+		    *--retval = PL_hexdigit[addr & 15];
+		} while (addr >>= 4);
+		*--retval = 'x';
+		*--retval = '0';
+		*--retval = '(';
+		retval -= typelen;
+		memcpy(retval, typestr, typelen);
+		if (stashname) {
+		    *--retval = '=';
+		    retval -= stashnamelen;
+		    memcpy(retval, stashname, stashnamelen);
+		}
+		/* retval may not necessarily have reached the start of the
+		   buffer here.  */
+		assert (retval >= buffer);
+		len = buffer_end - retval - 1; /* -1 for that \0  */
+	    }
+	    if (lp)
+		*lp = len;
+	    SAVEFREEPV(buffer);
+	    return retval;
+	}
+}
+if (SvPOKp(sv)) {
+	if (lp)
+	    *lp = SvCUR(sv);
+	if (flags & SV_MUTABLE_RETURN)
+	    return SvPVX_mutable(sv);
+	if (flags & SV_CONST_RETURN)
+	    return (char *)SvPVX_const(sv);
+	return SvPVX(sv);
+}
+if (SvIOK(sv)) {
+	/* I'm assuming that if both IV and NV are equally valid then
+	   converting the IV is going to be more efficient */
+	const U32 isUIOK = SvIsUV(sv);
+	char buf[TYPE_CHARS(UV)];
+	char *ebuf, *ptr;
+	STRLEN len;
+	if (SvTYPE(sv) < SVt_PVIV)
+	    sv_upgrade(sv, SVt_PVIV);
+	ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
+	len = ebuf - ptr;
+	/* inlined from sv_setpvn */
+	s = SvGROW_mutable(sv, len + 1);
+	Move(ptr, s, len, char);
+	s += len;
+	*s = '\0';
+SvPOK_on(sv);
+}
+else if (SvNOK(sv)) {
+	if (SvTYPE(sv) < SVt_PVNV)
+	    sv_upgrade(sv, SVt_PVNV);
+	if (SvNVX(sv) == 0.0
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+	    && !Perl_isnan(SvNVX(sv))
+#endif
+	) {
+	    s = SvGROW_mutable(sv, 2);
+	    *s++ = '0';
+	    *s = '\0';
+	} else {
+STRLEN len;
+STRLEN size = 5; /* "-Inf\0" */
+s = SvGROW_mutable(sv, size);
+len = S_infnan_2pv(SvNVX(sv), s, size, 0);
+if (len > 0) {
+s += len;
+SvPOK_on(sv);
+}
+else {
+/* some Xenix systems wipe out errno here */
+dSAVE_ERRNO;
+size =
+1 + /* sign */
+1 + /* "." */
+NV_DIG +
+1 + /* "e" */
+1 + /* sign */
+5 + /* exponent digits */
+1 + /* \0 */
+2; /* paranoia */
+s = SvGROW_mutable(sv, size);
+#ifndef USE_LOCALE_NUMERIC
+SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
+SvPOK_on(sv);
+#else
+{
+bool local_radix;
+DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
+STORE_LC_NUMERIC_SET_TO_NEEDED();
+local_radix =
+PL_numeric_local &&
+PL_numeric_radix_sv &&
+SvUTF8(PL_numeric_radix_sv);
+if (local_radix && SvLEN(PL_numeric_radix_sv) > 1) {
+size += SvLEN(PL_numeric_radix_sv) - 1;
+s = SvGROW_mutable(sv, size);
+}
+SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
+/* If the radix character is UTF-8, and actually is in the
+* output, turn on the UTF-8 flag for the scalar */
+if (local_radix &&
+instr(s, SvPVX_const(PL_numeric_radix_sv))) {
+SvUTF8_on(sv);
+}
+RESTORE_LC_NUMERIC();
+}
+/* We don't call SvPOK_on(), because it may come to
+* pass that the locale changes so that the
+* stringification we just did is no longer correct.  We
+* will have to re-stringify every time it is needed */
+#endif
+RESTORE_ERRNO;
+}
+while (*s) s++;
+	}
+}
+else if (isGV_with_GP(sv)) {
+	GV *const gv = MUTABLE_GV(sv);
+	SV *const buffer = sv_newmortal();
+	gv_efullname3(buffer, gv, "*");
+	assert(SvPOK(buffer));
+	if (SvUTF8(buffer))
+	    SvUTF8_on(sv);
+	if (lp)
+	    *lp = SvCUR(buffer);
+	return SvPVX(buffer);
+}
+else if (isREGEXP(sv)) {
+	if (lp) *lp = RX_WRAPLEN((REGEXP *)sv);
+	return RX_WRAPPED((REGEXP *)sv);
+}
+else {
+	if (lp)
+	    *lp = 0;
+	if (flags & SV_UNDEF_RETURNS_NULL)
+	    return NULL;
+	if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
+	    report_uninit(sv);
+	/* Typically the caller expects that sv_any is not NULL now.  */
+	if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV)
+	    sv_upgrade(sv, SVt_PV);
+	return (char *)"";
+}
+{
+	const STRLEN len = s - SvPVX_const(sv);
+	if (lp)
+	    *lp = len;
+	SvCUR_set(sv, len);
+}
+DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
+			  PTR2UV(sv),SvPVX_const(sv)));
+if (flags & SV_CONST_RETURN)
+	return (char *)SvPVX_const(sv);
+if (flags & SV_MUTABLE_RETURN)
+	return SvPVX_mutable(sv);
+return SvPVX(sv);
+}
+/*
+=for apidoc sv_copypv
+Copies a stringified representation of the source SV into the
+destination SV.  Automatically performs any necessary mg_get and
+coercion of numeric values into strings.  Guaranteed to preserve
+UTF8 flag even from overloaded objects.  Similar in nature to
+sv_2pv[_flags] but operates directly on an SV instead of just the
+string.  Mostly uses sv_2pv_flags to do its work, except when that
+would lose the UTF-8'ness of the PV.
+=for apidoc sv_copypv_nomg
+Like sv_copypv, but doesn't invoke get magic first.
+=for apidoc sv_copypv_flags
+Implementation of sv_copypv and sv_copypv_nomg.  Calls get magic iff flags
+include SV_GMAGIC.
+=cut
+*/
+void
+Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
+{
+STRLEN len;
+const char *s;
+PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
+s = SvPV_flags_const(ssv,len,(flags & SV_GMAGIC));
+sv_setpvn(dsv,s,len);
+if (SvUTF8(ssv))
+	SvUTF8_on(dsv);
+else
+	SvUTF8_off(dsv);
+}
+/*
+=for apidoc sv_2pvbyte
+Return a pointer to the byte-encoded representation of the SV, and set *lp
+to its length.  May cause the SV to be downgraded from UTF-8 as a
+side-effect.
+Usually accessed via the C<SvPVbyte> macro.
+=cut
+*/
+char *
+Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp)
+{
+PERL_ARGS_ASSERT_SV_2PVBYTE;
+SvGETMAGIC(sv);
+if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
+|| isGV_with_GP(sv) || SvROK(sv)) {
+	SV *sv2 = sv_newmortal();
+	sv_copypv_nomg(sv2,sv);
+	sv = sv2;
+}
+sv_utf8_downgrade(sv,0);
+return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
+}
+/*
+=for apidoc sv_2pvutf8
+Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
+to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
+Usually accessed via the C<SvPVutf8> macro.
+=cut
+*/
+char *
+Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp)
+{
+PERL_ARGS_ASSERT_SV_2PVUTF8;
+if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
+|| isGV_with_GP(sv) || SvROK(sv))
+	sv = sv_mortalcopy(sv);
+else
+SvGETMAGIC(sv);
+sv_utf8_upgrade_nomg(sv);
+return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
+}
+/*
+=for apidoc sv_2bool
+This macro is only used by sv_true() or its macro equivalent, and only if
+the latter's argument is neither SvPOK, SvIOK nor SvNOK.
+It calls sv_2bool_flags with the SV_GMAGIC flag.
+=for apidoc sv_2bool_flags
+This function is only used by sv_true() and friends,  and only if
+the latter's argument is neither SvPOK, SvIOK nor SvNOK.  If the flags
+contain SV_GMAGIC, then it does an mg_get() first.
+=cut
+*/
+bool
+Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
+{
+PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
+restart:
+if(flags & SV_GMAGIC) SvGETMAGIC(sv);
+if (!SvOK(sv))
+	return 0;
+if (SvROK(sv)) {
+	if (SvAMAGIC(sv)) {
+	    SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
+	    if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) {
+bool svb;
+sv = tmpsv;
+if(SvGMAGICAL(sv)) {
+flags = SV_GMAGIC;
+goto restart; /* call sv_2bool */
+}
+/* expanded SvTRUE_common(sv, (flags = 0, goto restart)) */
+else if(!SvOK(sv)) {
+svb = 0;
+}
+else if(SvPOK(sv)) {
+svb = SvPVXtrue(sv);
+}
+else if((SvFLAGS(sv) & (SVf_IOK|SVf_NOK))) {
+svb = (SvIOK(sv) && SvIVX(sv) != 0)
+|| (SvNOK(sv) && SvNVX(sv) != 0.0);
+}
+else {
+flags = 0;
+goto restart; /* call sv_2bool_nomg */
+}
+return cBOOL(svb);
+}
+	}
+	return SvRV(sv) != 0;
+}
+if (isREGEXP(sv))
+	return
+	  RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0');
+return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0);
+}
+/*
+=for apidoc sv_utf8_upgrade
+Converts the PV of an SV to its UTF-8-encoded form.
+Forces the SV to string form if it is not already.
+Will C<mg_get> on C<sv> if appropriate.
+Always sets the SvUTF8 flag to avoid future validity checks even
+if the whole string is the same in UTF-8 as not.
+Returns the number of bytes in the converted string
+This is not a general purpose byte encoding to Unicode interface:
+use the Encode extension for that.
+=for apidoc sv_utf8_upgrade_nomg
+Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
+=for apidoc sv_utf8_upgrade_flags
+Converts the PV of an SV to its UTF-8-encoded form.
+Forces the SV to string form if it is not already.
+Always sets the SvUTF8 flag to avoid future validity checks even
+if all the bytes are invariant in UTF-8.
+If C<flags> has C<SV_GMAGIC> bit set,
+will C<mg_get> on C<sv> if appropriate, else not.
+If C<flags> has SV_FORCE_UTF8_UPGRADE set, this function assumes that the PV
+will expand when converted to UTF-8, and skips the extra work of checking for
+that.  Typically this flag is used by a routine that has already parsed the
+string and found such characters, and passes this information on so that the
+work doesn't have to be repeated.
+Returns the number of bytes in the converted string.
+This is not a general purpose byte encoding to Unicode interface:
+use the Encode extension for that.
+=for apidoc sv_utf8_upgrade_flags_grow
+Like sv_utf8_upgrade_flags, but has an additional parameter C<extra>, which is
+the number of unused bytes the string of 'sv' is guaranteed to have free after
+it upon return.  This allows the caller to reserve extra space that it intends
+to fill, to avoid extra grows.
+C<sv_utf8_upgrade>, C<sv_utf8_upgrade_nomg>, and C<sv_utf8_upgrade_flags>
+are implemented in terms of this function.
+Returns the number of bytes in the converted string (not including the spares).
+=cut
+(One might think that the calling routine could pass in the position of the
+first variant character when it has set SV_FORCE_UTF8_UPGRADE, so it wouldn't
+have to be found again.  But that is not the case, because typically when the
+caller is likely to use this flag, it won't be calling this routine unless it
+finds something that won't fit into a byte.  Otherwise it tries to not upgrade
+and just use bytes.  But some things that do fit into a byte are variants in
+utf8, and the caller may not have been keeping track of these.)
+If the routine itself changes the string, it adds a trailing C<NUL>.  Such a
+C<NUL> isn't guaranteed due to having other routines do the work in some input
+cases, or if the input is already flagged as being in utf8.
+The speed of this could perhaps be improved for many cases if someone wanted to
+write a fast function that counts the number of variant characters in a string,
+especially if it could return the position of the first one.
+*/
+STRLEN
+Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
+{
+PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
+if (sv == &PL_sv_undef)
+	return 0;
+if (!SvPOK_nog(sv)) {
+	STRLEN len = 0;
+	if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
+	    (void) sv_2pv_flags(sv,&len, flags);
+	    if (SvUTF8(sv)) {
+		if (extra) SvGROW(sv, SvCUR(sv) + extra);
+		return len;
+	    }
+	} else {
+	    (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
+	}
+}
+if (SvUTF8(sv)) {
+	if (extra) SvGROW(sv, SvCUR(sv) + extra);
+	return SvCUR(sv);
+}
+if (SvIsCOW(sv)) {
+S_sv_uncow(aTHX_ sv, 0);
+}
+if (IN_ENCODING && !(flags & SV_UTF8_NO_ENCODING)) {
+sv_recode_to_utf8(sv, _get_encoding());
+	if (extra) SvGROW(sv, SvCUR(sv) + extra);
+	return SvCUR(sv);
+}
+if (SvCUR(sv) == 0) {
+	if (extra) SvGROW(sv, extra);
+} else { /* Assume Latin-1/EBCDIC */
+	/* This function could be much more efficient if we
+	 * had a FLAG in SVs to signal if there are any variant
+	 * chars in the PV.  Given that there isn't such a flag
+	 * make the loop as fast as possible (although there are certainly ways
+	 * to speed this up, eg. through vectorization) */
+	U8 * s = (U8 *) SvPVX_const(sv);
+	U8 * e = (U8 *) SvEND(sv);
+	U8 *t = s;
+	STRLEN two_byte_count = 0;
+	if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
+	/* See if really will need to convert to utf8.  We mustn't rely on our
+	 * incoming SV being well formed and having a trailing '\0', as certain
+	 * code in pp_formline can send us partially built SVs. */
+	while (t < e) {
+	    const U8 ch = *t++;
+	    if (NATIVE_BYTE_IS_INVARIANT(ch)) continue;
+	    t--;    /* t already incremented; re-point to first variant */
+	    two_byte_count = 1;
+	    goto must_be_utf8;
+	}
+	/* utf8 conversion not needed because all are invariants.  Mark as
+	 * UTF-8 even if no variant - saves scanning loop */
+	SvUTF8_on(sv);
+	if (extra) SvGROW(sv, SvCUR(sv) + extra);
+	return SvCUR(sv);
+must_be_utf8:
+	/* Here, the string should be converted to utf8, either because of an
+	 * input flag (two_byte_count = 0), or because a character that
+	 * requires 2 bytes was found (two_byte_count = 1).  t points either to
+	 * the beginning of the string (if we didn't examine anything), or to
+	 * the first variant.  In either case, everything from s to t - 1 will
+	 * occupy only 1 byte each on output.
+	 *
+	 * There are two main ways to convert.  One is to create a new string
+	 * and go through the input starting from the beginning, appending each
+	 * converted value onto the new string as we go along.  It's probably
+	 * best to allocate enough space in the string for the worst possible
+	 * case rather than possibly running out of space and having to
+	 * reallocate and then copy what we've done so far.  Since everything
+	 * from s to t - 1 is invariant, the destination can be initialized
+	 * with these using a fast memory copy
+	 *
+	 * The other way is to figure out exactly how big the string should be
+	 * by parsing the entire input.  Then you don't have to make it big
+	 * enough to handle the worst possible case, and more importantly, if
+	 * the string you already have is large enough, you don't have to
+	 * allocate a new string, you can copy the last character in the input
+	 * string to the final position(s) that will be occupied by the
+	 * converted string and go backwards, stopping at t, since everything
+	 * before that is invariant.
+	 *
+	 * There are advantages and disadvantages to each method.
+	 *
+	 * In the first method, we can allocate a new string, do the memory
+	 * copy from the s to t - 1, and then proceed through the rest of the
+	 * string byte-by-byte.
+	 *
+	 * In the second method, we proceed through the rest of the input
+	 * string just calculating how big the converted string will be.  Then
+	 * there are two cases:
+	 *  1)	if the string has enough extra space to handle the converted
+	 *	value.  We go backwards through the string, converting until we
+	 *	get to the position we are at now, and then stop.  If this
+	 *	position is far enough along in the string, this method is
+	 *	faster than the other method.  If the memory copy were the same
+	 *	speed as the byte-by-byte loop, that position would be about
+	 *	half-way, as at the half-way mark, parsing to the end and back
+	 *	is one complete string's parse, the same amount as starting
+	 *	over and going all the way through.  Actually, it would be
+	 *	somewhat less than half-way, as it's faster to just count bytes
+	 *	than to also copy, and we don't have the overhead of allocating
+	 *	a new string, changing the scalar to use it, and freeing the
+	 *	existing one.  But if the memory copy is fast, the break-even
+	 *	point is somewhere after half way.  The counting loop could be
+	 *	sped up by vectorization, etc, to move the break-even point
+	 *	further towards the beginning.
+	 *  2)	if the string doesn't have enough space to handle the converted
+	 *	value.  A new string will have to be allocated, and one might
+	 *	as well, given that, start from the beginning doing the first
+	 *	method.  We've spent extra time parsing the string and in
+	 *	exchange all we've gotten is that we know precisely how big to
+	 *	make the new one.  Perl is more optimized for time than space,
+	 *	so this case is a loser.
+	 * So what I've decided to do is not use the 2nd method unless it is
+	 * guaranteed that a new string won't have to be allocated, assuming
+	 * the worst case.  I also decided not to put any more conditions on it
+	 * than this, for now.  It seems likely that, since the worst case is
+	 * twice as big as the unknown portion of the string (plus 1), we won't
+	 * be guaranteed enough space, causing us to go to the first method,
+	 * unless the string is short, or the first variant character is near
+	 * the end of it.  In either of these cases, it seems best to use the
+	 * 2nd method.  The only circumstance I can think of where this would
+	 * be really slower is if the string had once had much more data in it
+	 * than it does now, but there is still a substantial amount in it  */
+	{
+	    STRLEN invariant_head = t - s;
+	    STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
+	    if (SvLEN(sv) < size) {
+		/* Here, have decided to allocate a new string */
+		U8 *dst;
+		U8 *d;
+		Newx(dst, size, U8);
+		/* If no known invariants at the beginning of the input string,
+		 * set so starts from there.  Otherwise, can use memory copy to
+		 * get up to where we are now, and then start from here */
+		if (invariant_head == 0) {
+		    d = dst;
+		} else {
+		    Copy(s, dst, invariant_head, char);
+		    d = dst + invariant_head;
+		}
+		while (t < e) {
+append_utf8_from_native_byte(*t, &d);
+t++;
+		}
+		*d = '\0';
+		SvPV_free(sv); /* No longer using pre-existing string */
+		SvPV_set(sv, (char*)dst);
+		SvCUR_set(sv, d - dst);
+		SvLEN_set(sv, size);
+	    } else {
+		/* Here, have decided to get the exact size of the string.
+		 * Currently this happens only when we know that there is
+		 * guaranteed enough space to fit the converted string, so
+		 * don't have to worry about growing.  If two_byte_count is 0,
+		 * then t points to the first byte of the string which hasn't
+		 * been examined yet.  Otherwise two_byte_count is 1, and t
+		 * points to the first byte in the string that will expand to
+		 * two.  Depending on this, start examining at t or 1 after t.
+		 * */
+		U8 *d = t + two_byte_count;
+		/* Count up the remaining bytes that expand to two */
+		while (d < e) {
+		    const U8 chr = *d++;
+		    if (! NATIVE_BYTE_IS_INVARIANT(chr)) two_byte_count++;
+		}
+		/* The string will expand by just the number of bytes that
+		 * occupy two positions.  But we are one afterwards because of
+		 * the increment just above.  This is the place to put the
+		 * trailing NUL, and to set the length before we decrement */
+		d += two_byte_count;
+		SvCUR_set(sv, d - s);
+		*d-- = '\0';
+		/* Having decremented d, it points to the position to put the
+		 * very last byte of the expanded string.  Go backwards through
+		 * the string, copying and expanding as we go, stopping when we
+		 * get to the part that is invariant the rest of the way down */
+		e--;
+		while (e >= t) {
+		    if (NATIVE_BYTE_IS_INVARIANT(*e)) {
+			*d-- = *e;
+		    } else {
+			*d-- = UTF8_EIGHT_BIT_LO(*e);
+			*d-- = UTF8_EIGHT_BIT_HI(*e);
+		    }
+e--;
+		}
+	    }
+	    if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+		/* Update pos. We do it at the end rather than during
+		 * the upgrade, to avoid slowing down the common case
+		 * (upgrade without pos).
+		 * pos can be stored as either bytes or characters.  Since
+		 * this was previously a byte string we can just turn off
+		 * the bytes flag. */
+		MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
+		if (mg) {
+		    mg->mg_flags &= ~MGf_BYTES;
+		}
+		if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
+		    magic_setutf8(sv,mg); /* clear UTF8 cache */
+	    }
+	}
+}
+/* Mark as UTF-8 even if no variant - saves scanning loop */
+SvUTF8_on(sv);
+return SvCUR(sv);
+}
+/*
+=for apidoc sv_utf8_downgrade
+Attempts to convert the PV of an SV from characters to bytes.
+If the PV contains a character that cannot fit
+in a byte, this conversion will fail;
+in this case, either returns false or, if C<fail_ok> is not
+true, croaks.
+This is not a general purpose Unicode to byte encoding interface:
+use the Encode extension for that.
+=cut
+*/
+bool
+Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
+{
+PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
+if (SvPOKp(sv) && SvUTF8(sv)) {
+if (SvCUR(sv)) {
+	    U8 *s;
+	    STRLEN len;
+	    int mg_flags = SV_GMAGIC;
+if (SvIsCOW(sv)) {
+S_sv_uncow(aTHX_ sv, 0);
+}
+	    if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+		/* update pos */
+		MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
+		if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) {
+			mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len,
+						SV_GMAGIC|SV_CONST_RETURN);
+			mg_flags = 0; /* sv_pos_b2u does get magic */
+		}
+		if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
+		    magic_setutf8(sv,mg); /* clear UTF8 cache */
+	    }
+	    s = (U8 *) SvPV_flags(sv, len, mg_flags);
+	    if (!utf8_to_bytes(s, &len)) {
+	        if (fail_ok)
+		    return FALSE;
+		else {
+		    if (PL_op)
+		        Perl_croak(aTHX_ "Wide character in %s",
+				   OP_DESC(PL_op));
+		    else
+		        Perl_croak(aTHX_ "Wide character");
+		}
+	    }
+	    SvCUR_set(sv, len);
+	}
+}
+SvUTF8_off(sv);
+return TRUE;
+}
+/*
+=for apidoc sv_utf8_encode
+Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
+flag off so that it looks like octets again.
+=cut
+*/
+void
+Perl_sv_utf8_encode(pTHX_ SV *const sv)
+{
+PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
+if (SvREADONLY(sv)) {
+	sv_force_normal_flags(sv, 0);
+}
+(void) sv_utf8_upgrade(sv);
+SvUTF8_off(sv);
+}
+/*
+=for apidoc sv_utf8_decode
+If the PV of the SV is an octet sequence in UTF-8
+and contains a multiple-byte character, the C<SvUTF8> flag is turned on
+so that it looks like a character.  If the PV contains only single-byte
+characters, the C<SvUTF8> flag stays off.
+Scans PV for validity and returns false if the PV is invalid UTF-8.
+=cut
+*/
+bool
+Perl_sv_utf8_decode(pTHX_ SV *const sv)
+{
+PERL_ARGS_ASSERT_SV_UTF8_DECODE;
+if (SvPOKp(sv)) {
+const U8 *start, *c;
+const U8 *e;
+	/* The octets may have got themselves encoded - get them back as
+	 * bytes
+	 */
+	if (!sv_utf8_downgrade(sv, TRUE))
+	    return FALSE;
+/* it is actually just a matter of turning the utf8 flag on, but
+* we want to make sure everything inside is valid utf8 first.
+*/
+c = start = (const U8 *) SvPVX_const(sv);
+	if (!is_utf8_string(c, SvCUR(sv)))
+	    return FALSE;
+e = (const U8 *) SvEND(sv);
+while (c < e) {
+	    const U8 ch = *c++;
+if (!UTF8_IS_INVARIANT(ch)) {
+		SvUTF8_on(sv);
+		break;
+	    }
+}
+	if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+	    /* XXX Is this dead code?  XS_utf8_decode calls SvSETMAGIC
+		   after this, clearing pos.  Does anything on CPAN
+		   need this? */
+	    /* adjust pos to the start of a UTF8 char sequence */
+	    MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
+	    if (mg) {
+		I32 pos = mg->mg_len;
+		if (pos > 0) {
+		    for (c = start + pos; c > start; c--) {
+			if (UTF8_IS_START(*c))
+			    break;
+		    }
+		    mg->mg_len  = c - start;
+		}
+	    }
+	    if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
+		magic_setutf8(sv,mg); /* clear UTF8 cache */
+	}
+}
+return TRUE;
+}
+/*
+=for apidoc sv_setsv
+Copies the contents of the source SV C<ssv> into the destination SV
+C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
+function if the source SV needs to be reused.  Does not handle 'set' magic on
+destination SV.  Calls 'get' magic on source SV.  Loosely speaking, it
+performs a copy-by-value, obliterating any previous content of the
+destination.
+You probably want to use one of the assortment of wrappers, such as
+C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
+C<SvSetMagicSV_nosteal>.
+=for apidoc sv_setsv_flags
+Copies the contents of the source SV C<ssv> into the destination SV
+C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
+function if the source SV needs to be reused.  Does not handle 'set' magic.
+Loosely speaking, it performs a copy-by-value, obliterating any previous
+content of the destination.
+If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
+C<ssv> if appropriate, else not.  If the C<flags>
+parameter has the C<SV_NOSTEAL> bit set then the
+buffers of temps will not be stolen.  <sv_setsv>
+and C<sv_setsv_nomg> are implemented in terms of this function.
+You probably want to use one of the assortment of wrappers, such as
+C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
+C<SvSetMagicSV_nosteal>.
+This is the primary function for copying scalars, and most other
+copy-ish functions and macros use this underneath.
+=cut
+*/
+static void
+S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
+{
+I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
+HV *old_stash = NULL;
+PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
+if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
+	const char * const name = GvNAME(sstr);
+	const STRLEN len = GvNAMELEN(sstr);
+	{
+	    if (dtype >= SVt_PV) {
+		SvPV_free(dstr);
+		SvPV_set(dstr, 0);
+		SvLEN_set(dstr, 0);
+		SvCUR_set(dstr, 0);
+	    }
+	    SvUPGRADE(dstr, SVt_PVGV);
+	    (void)SvOK_off(dstr);
+	    isGV_with_GP_on(dstr);
+	}
+	GvSTASH(dstr) = GvSTASH(sstr);
+	if (GvSTASH(dstr))
+	    Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
+gv_name_set(MUTABLE_GV(dstr), name, len,
+GV_ADD | (GvNAMEUTF8(sstr) ? SVf_UTF8 : 0 ));
+	SvFAKE_on(dstr);	/* can coerce to non-glob */
+}
+if(GvGP(MUTABLE_GV(sstr))) {
+/* If source has method cache entry, clear it */
+if(GvCVGEN(sstr)) {
+SvREFCNT_dec(GvCV(sstr));
+GvCV_set(sstr, NULL);
+GvCVGEN(sstr) = 0;
+}
+/* If source has a real method, then a method is
+going to change */
+else if(
+GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
+) {
+mro_changes = 1;
+}
+}
+/* If dest already had a real method, that's a change as well */
+if(
+!mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
+&& GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
+) {
+mro_changes = 1;
+}
+/* We don't need to check the name of the destination if it was not a
+glob to begin with. */
+if(dtype == SVt_PVGV) {
+const char * const name = GvNAME((const GV *)dstr);
+if(
+strEQ(name,"ISA")
+/* The stash may have been detached from the symbol table, so
+check its name. */
+&& GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
+)
+mro_changes = 2;
+else {
+const STRLEN len = GvNAMELEN(dstr);
+if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
+|| (len == 1 && name[0] == ':')) {
+mro_changes = 3;
+/* Set aside the old stash, so we can reset isa caches on
+its subclasses. */
+if((old_stash = GvHV(dstr)))
+/* Make sure we do not lose it early. */
+SvREFCNT_inc_simple_void_NN(
+sv_2mortal((SV *)old_stash)
+);
+}
+}
+SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
+}
+/* freeing dstr's GP might free sstr (e.g. *x = $x),
+* so temporarily protect it */
+ENTER;
+SAVEFREESV(SvREFCNT_inc_simple_NN(sstr));
+gp_free(MUTABLE_GV(dstr));
+GvINTRO_off(dstr);		/* one-shot flag */
+GvGP_set(dstr, gp_ref(GvGP(sstr)));
+LEAVE;
+if (SvTAINTED(sstr))
+	SvTAINT(dstr);
+if (GvIMPORTED(dstr) != GVf_IMPORTED
+	&& CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
+	{
+	    GvIMPORTED_on(dstr);
+	}
+GvMULTI_on(dstr);
+if(mro_changes == 2) {
+if (GvAV((const GV *)sstr)) {
+	MAGIC *mg;
+	SV * const sref = (SV *)GvAV((const GV *)dstr);
+	if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
+	    if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
+		AV * const ary = newAV();
+		av_push(ary, mg->mg_obj); /* takes the refcount */
+		mg->mg_obj = (SV *)ary;
+	    }
+	    av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
+	}
+	else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
+}
+mro_isa_changed_in(GvSTASH(dstr));
+}
+else if(mro_changes == 3) {
+	HV * const stash = GvHV(dstr);
+	if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
+	    mro_package_moved(
+		stash, old_stash,
+		(GV *)dstr, 0
+	    );
+}
+else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
+if (GvIO(dstr) && dtype == SVt_PVGV) {
+	DEBUG_o(Perl_deb(aTHX_
+			"glob_assign_glob clearing PL_stashcache\n"));
+	/* It's a cache. It will rebuild itself quite happily.
+	   It's a lot of effort to work out exactly which key (or keys)
+	   might be invalidated by the creation of the this file handle.
+	 */
+	hv_clear(PL_stashcache);
+}
+return;
+}
+void
+Perl_gv_setref(pTHX_ SV *const dstr, SV *const sstr)
+{
+SV * const sref = SvRV(sstr);
+SV *dref;
+const int intro = GvINTRO(dstr);
+SV **location;
+U8 import_flag = 0;
+const U32 stype = SvTYPE(sref);
+PERL_ARGS_ASSERT_GV_SETREF;
+if (intro) {
+	GvINTRO_off(dstr);	/* one-shot flag */
+	GvLINE(dstr) = CopLINE(PL_curcop);
+	GvEGV(dstr) = MUTABLE_GV(dstr);
+}
+GvMULTI_on(dstr);
+switch (stype) {
+case SVt_PVCV:
+	location = (SV **) &(GvGP(dstr)->gp_cv); /* XXX bypassing GvCV_set */
+	import_flag = GVf_IMPORTED_CV;
+	goto common;
+case SVt_PVHV:
+	location = (SV **) &GvHV(dstr);
+	import_flag = GVf_IMPORTED_HV;
+	goto common;
+case SVt_PVAV:
+	location = (SV **) &GvAV(dstr);
+	import_flag = GVf_IMPORTED_AV;
+	goto common;
+case SVt_PVIO:
+	location = (SV **) &GvIOp(dstr);
+	goto common;
+case SVt_PVFM:
+	location = (SV **) &GvFORM(dstr);
+	goto common;
+default:
+	location = &GvSV(dstr);
+	import_flag = GVf_IMPORTED_SV;
+common:
+	if (intro) {
+	    if (stype == SVt_PVCV) {
+		/*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
+		if (GvCVGEN(dstr)) {
+		    SvREFCNT_dec(GvCV(dstr));
+		    GvCV_set(dstr, NULL);
+		    GvCVGEN(dstr) = 0; /* Switch off cacheness. */
+		}
+	    }
+	    /* SAVEt_GVSLOT takes more room on the savestack and has more
+	       overhead in leave_scope than SAVEt_GENERIC_SV.  But for CVs
+	       leave_scope needs access to the GV so it can reset method
+	       caches.  We must use SAVEt_GVSLOT whenever the type is
+	       SVt_PVCV, even if the stash is anonymous, as the stash may
+	       gain a name somehow before leave_scope. */
+	    if (stype == SVt_PVCV) {
+		/* There is no save_pushptrptrptr.  Creating it for this
+		   one call site would be overkill.  So inline the ss add
+		   routines here. */
+dSS_ADD;
+		SS_ADD_PTR(dstr);
+		SS_ADD_PTR(location);
+		SS_ADD_PTR(SvREFCNT_inc(*location));
+		SS_ADD_UV(SAVEt_GVSLOT);
+		SS_ADD_END(4);
+	    }
+	    else SAVEGENERICSV(*location);
+	}
+	dref = *location;
+	if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
+	    CV* const cv = MUTABLE_CV(*location);
+	    if (cv) {
+		if (!GvCVGEN((const GV *)dstr) &&
+		    (CvROOT(cv) || CvXSUB(cv)) &&
+		    /* redundant check that avoids creating the extra SV
+		       most of the time: */
+		    (CvCONST(cv) || ckWARN(WARN_REDEFINE)))
+		    {
+			SV * const new_const_sv =
+			    CvCONST((const CV *)sref)
+				 ? cv_const_sv((const CV *)sref)
+				 : NULL;
+			report_redefined_cv(
+			   sv_2mortal(Perl_newSVpvf(aTHX_
+				"%"HEKf"::%"HEKf,
+				HEKfARG(
+				 HvNAME_HEK(GvSTASH((const GV *)dstr))
+				),
+				HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr)))
+			   )),
+			   cv,
+			   CvCONST((const CV *)sref) ? &new_const_sv : NULL
+			);
+		    }
+		if (!intro)
+		    cv_ckproto_len_flags(cv, (const GV *)dstr,
+				   SvPOK(sref) ? CvPROTO(sref) : NULL,
+				   SvPOK(sref) ? CvPROTOLEN(sref) : 0,
+SvPOK(sref) ? SvUTF8(sref) : 0);
+	    }
+	    GvCVGEN(dstr) = 0; /* Switch off cacheness. */
+	    GvASSUMECV_on(dstr);
+	    if(GvSTASH(dstr)) { /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
+		if (intro && GvREFCNT(dstr) > 1) {
+		    /* temporary remove extra savestack's ref */
+		    --GvREFCNT(dstr);
+		    gv_method_changed(dstr);
+		    ++GvREFCNT(dstr);
+		}
+		else gv_method_changed(dstr);
+	    }
+	}
+	*location = SvREFCNT_inc_simple_NN(sref);
+	if (import_flag && !(GvFLAGS(dstr) & import_flag)
+	    && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
+	    GvFLAGS(dstr) |= import_flag;
+	}
+	if (import_flag == GVf_IMPORTED_SV) {
+	    if (intro) {
+		save_aliased_sv((GV *)dstr);
+	    }
+	    /* Turn off the flag if sref is not referenced elsewhere,
+	       even by weak refs.  (SvRMAGICAL is a pessimistic check for
+	       back refs.)  */
+	    if (SvREFCNT(sref) <= 2 && !SvRMAGICAL(sref))
+		GvALIASED_SV_off(dstr);
+	    else
+		GvALIASED_SV_on(dstr);
+	}
+	if (stype == SVt_PVHV) {
+	    const char * const name = GvNAME((GV*)dstr);
+	    const STRLEN len = GvNAMELEN(dstr);
+	    if (
+	        (
+	           (len > 1 && name[len-2] == ':' && name[len-1] == ':')
+	        || (len == 1 && name[0] == ':')
+	        )
+	     && (!dref || HvENAME_get(dref))
+	    ) {
+		mro_package_moved(
+		    (HV *)sref, (HV *)dref,
+		    (GV *)dstr, 0
+		);
+	    }
+	}
+	else if (
+	    stype == SVt_PVAV && sref != dref
+	 && strEQ(GvNAME((GV*)dstr), "ISA")
+	 /* The stash may have been detached from the symbol table, so
+	    check its name before doing anything. */
+	 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
+	) {
+	    MAGIC *mg;
+	    MAGIC * const omg = dref && SvSMAGICAL(dref)
+	                         ? mg_find(dref, PERL_MAGIC_isa)
+	                         : NULL;
+	    if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
+		if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
+		    AV * const ary = newAV();
+		    av_push(ary, mg->mg_obj); /* takes the refcount */
+		    mg->mg_obj = (SV *)ary;
+		}
+		if (omg) {
+		    if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
+			SV **svp = AvARRAY((AV *)omg->mg_obj);
+			I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
+			while (items--)
+			    av_push(
+			     (AV *)mg->mg_obj,
+			     SvREFCNT_inc_simple_NN(*svp++)
+			    );
+		    }
+		    else
+			av_push(
+			 (AV *)mg->mg_obj,
+			 SvREFCNT_inc_simple_NN(omg->mg_obj)
+			);
+		}
+		else
+		    av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
+	    }
+	    else
+	    {
+		sv_magic(
+		 sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
+		);
+		mg = mg_find(sref, PERL_MAGIC_isa);
+	    }
+	    /* Since the *ISA assignment could have affected more than
+	       one stash, don't call mro_isa_changed_in directly, but let
+	       magic_clearisa do it for us, as it already has the logic for
+	       dealing with globs vs arrays of globs. */
+	    assert(mg);
+	    Perl_magic_clearisa(aTHX_ NULL, mg);
+	}
+else if (stype == SVt_PVIO) {
+DEBUG_o(Perl_deb(aTHX_ "gv_setref clearing PL_stashcache\n"));
+/* It's a cache. It will rebuild itself quite happily.
+It's a lot of effort to work out exactly which key (or keys)
+might be invalidated by the creation of the this file handle.
+*/
+hv_clear(PL_stashcache);
+}
+	break;
+}
+if (!intro) SvREFCNT_dec(dref);
+if (SvTAINTED(sstr))
+	SvTAINT(dstr);
+return;
+}
+#ifdef PERL_DEBUG_READONLY_COW
+# include <sys/mman.h>
+# ifndef PERL_MEMORY_DEBUG_HEADER_SIZE
+#  define PERL_MEMORY_DEBUG_HEADER_SIZE 0
+# endif
+void
+Perl_sv_buf_to_ro(pTHX_ SV *sv)
+{
+struct perl_memory_debug_header * const header =
+	(struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
+const MEM_SIZE len = header->size;
+PERL_ARGS_ASSERT_SV_BUF_TO_RO;
+# ifdef PERL_TRACK_MEMPOOL
+if (!header->readonly) header->readonly = 1;
+# endif
+if (mprotect(header, len, PROT_READ))
+	Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
+			 header, len, errno);
+}
+static void
+S_sv_buf_to_rw(pTHX_ SV *sv)
+{
+struct perl_memory_debug_header * const header =
+	(struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
+const MEM_SIZE len = header->size;
+PERL_ARGS_ASSERT_SV_BUF_TO_RW;
+if (mprotect(header, len, PROT_READ|PROT_WRITE))
+	Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
+			 header, len, errno);
+# ifdef PERL_TRACK_MEMPOOL
+header->readonly = 0;
+# endif
+}
+#else
+# define sv_buf_to_ro(sv)	NOOP
+# define sv_buf_to_rw(sv)	NOOP
+#endif
+void
+Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
+{
+U32 sflags;
+int dtype;
+svtype stype;
+PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
+if (UNLIKELY( sstr == dstr ))
+	return;
+if (SvIS_FREED(dstr)) {
+	Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
+		   " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
+}
+SV_CHECK_THINKFIRST_COW_DROP(dstr);
+if (UNLIKELY( !sstr ))
+	sstr = &PL_sv_undef;
+if (SvIS_FREED(sstr)) {
+	Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
+		   (void*)sstr, (void*)dstr);
+}
+stype = SvTYPE(sstr);
+dtype = SvTYPE(dstr);
+/* There's a lot of redundancy below but we're going for speed here */
+switch (stype) {
+case SVt_NULL:
+undef_sstr:
+	if (LIKELY( dtype != SVt_PVGV && dtype != SVt_PVLV )) {
+	    (void)SvOK_off(dstr);
+	    return;
+	}
+	break;
+case SVt_IV:
+	if (SvIOK(sstr)) {
+	    switch (dtype) {
+	    case SVt_NULL:
+		/* For performance, we inline promoting to type SVt_IV. */
+		/* We're starting from SVt_NULL, so provided that define is
+		 * actual 0, we don't have to unset any SV type flags
+		 * to promote to SVt_IV. */
+		STATIC_ASSERT_STMT(SVt_NULL == 0);
+		SET_SVANY_FOR_BODYLESS_IV(dstr);
+		SvFLAGS(dstr) |= SVt_IV;
+		break;
+	    case SVt_NV:
+	    case SVt_PV:
+		sv_upgrade(dstr, SVt_PVIV);
+		break;
+	    case SVt_PVGV:
+	    case SVt_PVLV:
+		goto end_of_first_switch;
+	    }
+	    (void)SvIOK_only(dstr);
+	    SvIV_set(dstr,  SvIVX(sstr));
+	    if (SvIsUV(sstr))
+		SvIsUV_on(dstr);
+	    /* SvTAINTED can only be true if the SV has taint magic, which in
+	       turn means that the SV type is PVMG (or greater). This is the
+	       case statement for SVt_IV, so this cannot be true (whatever gcov
+	       may say).  */
+	    assert(!SvTAINTED(sstr));
+	    return;
+	}
+	if (!SvROK(sstr))
+	    goto undef_sstr;
+	if (dtype < SVt_PV && dtype != SVt_IV)
+	    sv_upgrade(dstr, SVt_IV);
+	break;
+case SVt_NV:
+	if (LIKELY( SvNOK(sstr) )) {
+	    switch (dtype) {
+	    case SVt_NULL:
+	    case SVt_IV:
+		sv_upgrade(dstr, SVt_NV);
+		break;
+	    case SVt_PV:
+	    case SVt_PVIV:
+		sv_upgrade(dstr, SVt_PVNV);
+		break;
+	    case SVt_PVGV:
+	    case SVt_PVLV:
+		goto end_of_first_switch;
+	    }
+	    SvNV_set(dstr, SvNVX(sstr));
+	    (void)SvNOK_only(dstr);
+	    /* SvTAINTED can only be true if the SV has taint magic, which in
+	       turn means that the SV type is PVMG (or greater). This is the
+	       case statement for SVt_NV, so this cannot be true (whatever gcov
+	       may say).  */
+	    assert(!SvTAINTED(sstr));
+	    return;
+	}
+	goto undef_sstr;
+case SVt_PV:
+	if (dtype < SVt_PV)
+	    sv_upgrade(dstr, SVt_PV);
+	break;
+case SVt_PVIV:
+	if (dtype < SVt_PVIV)
+	    sv_upgrade(dstr, SVt_PVIV);
+	break;
+case SVt_PVNV:
+	if (dtype < SVt_PVNV)
+	    sv_upgrade(dstr, SVt_PVNV);
+	break;
+default:
+	{
+	const char * const type = sv_reftype(sstr,0);
+	if (PL_op)
+	    /* diag_listed_as: Bizarre copy of %s */
+	    Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
+	else
+	    Perl_croak(aTHX_ "Bizarre copy of %s", type);
+	}
+	NOT_REACHED; /* NOTREACHED */
+case SVt_REGEXP:
+upgregexp:
+	if (dtype < SVt_REGEXP)
+	{
+	    if (dtype >= SVt_PV) {
+		SvPV_free(dstr);
+		SvPV_set(dstr, 0);
+		SvLEN_set(dstr, 0);
+		SvCUR_set(dstr, 0);
+	    }
+	    sv_upgrade(dstr, SVt_REGEXP);
+	}
+	break;
+	case SVt_INVLIST:
+case SVt_PVLV:
+case SVt_PVGV:
+case SVt_PVMG:
+	if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
+	    mg_get(sstr);
+	    if (SvTYPE(sstr) != stype)
+		stype = SvTYPE(sstr);
+	}
+	if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
+		    glob_assign_glob(dstr, sstr, dtype);
+		    return;
+	}
+	if (stype == SVt_PVLV)
+	{
+	    if (isREGEXP(sstr)) goto upgregexp;
+	    SvUPGRADE(dstr, SVt_PVNV);
+	}
+	else
+	    SvUPGRADE(dstr, (svtype)stype);
+}
+end_of_first_switch:
+/* dstr may have been upgraded.  */
+dtype = SvTYPE(dstr);
+sflags = SvFLAGS(sstr);
+if (UNLIKELY( dtype == SVt_PVCV )) {
+	/* Assigning to a subroutine sets the prototype.  */
+	if (SvOK(sstr)) {
+	    STRLEN len;
+	    const char *const ptr = SvPV_const(sstr, len);
+SvGROW(dstr, len + 1);
+Copy(ptr, SvPVX(dstr), len + 1, char);
+SvCUR_set(dstr, len);
+	    SvPOK_only(dstr);
+	    SvFLAGS(dstr) |= sflags & SVf_UTF8;
+	    CvAUTOLOAD_off(dstr);
+	} else {
+	    SvOK_off(dstr);
+	}
+}
+else if (UNLIKELY(dtype == SVt_PVAV || dtype == SVt_PVHV
+|| dtype == SVt_PVFM))
+{
+	const char * const type = sv_reftype(dstr,0);
+	if (PL_op)
+	    /* diag_listed_as: Cannot copy to %s */
+	    Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
+	else
+	    Perl_croak(aTHX_ "Cannot copy to %s", type);
+} else if (sflags & SVf_ROK) {
+	if (isGV_with_GP(dstr)
+	    && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
+	    sstr = SvRV(sstr);
+	    if (sstr == dstr) {
+		if (GvIMPORTED(dstr) != GVf_IMPORTED
+		    && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
+		{
+		    GvIMPORTED_on(dstr);
+		}
+		GvMULTI_on(dstr);
+		return;
+	    }
+	    glob_assign_glob(dstr, sstr, dtype);
+	    return;
+	}
+	if (dtype >= SVt_PV) {
+	    if (isGV_with_GP(dstr)) {
+		gv_setref(dstr, sstr);
+		return;
+	    }
+	    if (SvPVX_const(dstr)) {
+		SvPV_free(dstr);
+		SvLEN_set(dstr, 0);
+SvCUR_set(dstr, 0);
+	    }
+	}
+	(void)SvOK_off(dstr);
+	SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
+	SvFLAGS(dstr) |= sflags & SVf_ROK;
+	assert(!(sflags & SVp_NOK));
+	assert(!(sflags & SVp_IOK));
+	assert(!(sflags & SVf_NOK));
+	assert(!(sflags & SVf_IOK));
+}
+else if (isGV_with_GP(dstr)) {
+	if (!(sflags & SVf_OK)) {
+	    Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
+			   "Undefined value assigned to typeglob");
+	}
+	else {
+	    GV *gv = gv_fetchsv_nomg(sstr, GV_ADD, SVt_PVGV);
+	    if (dstr != (const SV *)gv) {
+		const char * const name = GvNAME((const GV *)dstr);
+		const STRLEN len = GvNAMELEN(dstr);
+		HV *old_stash = NULL;
+		bool reset_isa = FALSE;
+		if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
+		 || (len == 1 && name[0] == ':')) {
+		    /* Set aside the old stash, so we can reset isa caches
+		       on its subclasses. */
+		    if((old_stash = GvHV(dstr))) {
+			/* Make sure we do not lose it early. */
+			SvREFCNT_inc_simple_void_NN(
+			 sv_2mortal((SV *)old_stash)
+			);
+		    }
+		    reset_isa = TRUE;
+		}
+		if (GvGP(dstr)) {
+		    SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
+		    gp_free(MUTABLE_GV(dstr));
+		}
+		GvGP_set(dstr, gp_ref(GvGP(gv)));
+		if (reset_isa) {
+		    HV * const stash = GvHV(dstr);
+		    if(
+		        old_stash ? (HV *)HvENAME_get(old_stash) : stash
+		    )
+			mro_package_moved(
+			 stash, old_stash,
+			 (GV *)dstr, 0
+			);
+		}
+	    }
+	}
+}
+else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
+	  && (stype == SVt_REGEXP || isREGEXP(sstr))) {
+	reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
+}
+else if (sflags & SVp_POK) {
+	const STRLEN cur = SvCUR(sstr);
+	const STRLEN len = SvLEN(sstr);
+	/*
+	 * We have three basic ways to copy the string:
+	 *
+	 *  1. Swipe
+	 *  2. Copy-on-write
+	 *  3. Actual copy
+	 *
+	 * Which we choose is based on various factors.  The following
+	 * things are listed in order of speed, fastest to slowest:
+	 *  - Swipe
+	 *  - Copying a short string
+	 *  - Copy-on-write bookkeeping
+	 *  - malloc
+	 *  - Copying a long string
+	 *
+	 * We swipe the string (steal the string buffer) if the SV on the
+	 * rhs is about to be freed anyway (TEMP and refcnt==1).  This is a
+	 * big win on long strings.  It should be a win on short strings if
+	 * SvPVX_const(dstr) has to be allocated.  If not, it should not
+	 * slow things down, as SvPVX_const(sstr) would have been freed
+	 * soon anyway.
+	 *
+	 * We also steal the buffer from a PADTMP (operator target) if it
+	 * is ‘long enough’.  For short strings, a swipe does not help
+	 * here, as it causes more malloc calls the next time the target
+	 * is used.  Benchmarks show that even if SvPVX_const(dstr) has to
+	 * be allocated it is still not worth swiping PADTMPs for short
+	 * strings, as the savings here are small.
+	 *
+	 * If swiping is not an option, then we see whether it is
+	 * worth using copy-on-write.  If the lhs already has a buf-
+	 * fer big enough and the string is short, we skip it and fall back
+	 * to method 3, since memcpy is faster for short strings than the
+	 * later bookkeeping overhead that copy-on-write entails.
+	 * If the rhs is not a copy-on-write string yet, then we also
+	 * consider whether the buffer is too large relative to the string
+	 * it holds.  Some operations such as readline allocate a large
+	 * buffer in the expectation of reusing it.  But turning such into
+	 * a COW buffer is counter-productive because it increases memory
+	 * usage by making readline allocate a new large buffer the sec-
+	 * ond time round.  So, if the buffer is too large, again, we use
+	 * method 3 (copy).
+	 *
+	 * Finally, if there is no buffer on the left, or the buffer is too
+	 * small, then we use copy-on-write and make both SVs share the
+	 * string buffer.
+	 *
+	 */
+	/* Whichever path we take through the next code, we want this true,
+	   and doing it now facilitates the COW check.  */
+	(void)SvPOK_only(dstr);
+	if (
+(              /* Either ... */
+				/* slated for free anyway (and not COW)? */
+(sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP
+/* or a swipable TARG */
+|| ((sflags &
+(SVs_PADTMP|SVf_READONLY|SVf_PROTECT|SVf_IsCOW))
+== SVs_PADTMP
+/* whose buffer is worth stealing */
+&& CHECK_COWBUF_THRESHOLD(cur,len)
+)
+) &&
+!(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
+	         (!(flags & SV_NOSTEAL)) &&
+					/* and we're allowed to steal temps */
+SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
+len)             /* and really is a string */
+	{	/* Passes the swipe test.  */
+	    if (SvPVX_const(dstr))	/* we know that dtype >= SVt_PV */
+		SvPV_free(dstr);
+	    SvPV_set(dstr, SvPVX_mutable(sstr));
+	    SvLEN_set(dstr, SvLEN(sstr));
+	    SvCUR_set(dstr, SvCUR(sstr));
+	    SvTEMP_off(dstr);
+	    (void)SvOK_off(sstr);	/* NOTE: nukes most SvFLAGS on sstr */
+	    SvPV_set(sstr, NULL);
+	    SvLEN_set(sstr, 0);
+	    SvCUR_set(sstr, 0);
+	    SvTEMP_off(sstr);
+}
+	else if (flags & SV_COW_SHARED_HASH_KEYS
+	      &&
+#ifdef PERL_OLD_COPY_ON_WRITE
+		 (  sflags & SVf_IsCOW
+		 || (   (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
+		     && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
+		     && SvTYPE(sstr) >= SVt_PVIV && len
+		    )
+		 )
+#elif defined(PERL_NEW_COPY_ON_WRITE)
+		 (sflags & SVf_IsCOW
+		   ? (!len ||
+(  (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1)
+			  /* If this is a regular (non-hek) COW, only so
+			     many COW "copies" are possible. */
+		       && CowREFCNT(sstr) != SV_COW_REFCNT_MAX  ))
+		   : (  (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
+		     && !(SvFLAGS(dstr) & SVf_BREAK)
+&& CHECK_COW_THRESHOLD(cur,len) && cur+1 < len
+&& (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1)
+		    ))
+#else
+		 sflags & SVf_IsCOW
+	      && !(SvFLAGS(dstr) & SVf_BREAK)
+#endif
+) {
+/* Either it's a shared hash key, or it's suitable for
+copy-on-write.  */
+if (DEBUG_C_TEST) {
+PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
+sv_dump(sstr);
+sv_dump(dstr);
+}
+#ifdef PERL_ANY_COW
+if (!(sflags & SVf_IsCOW)) {
+SvIsCOW_on(sstr);
+# ifdef PERL_OLD_COPY_ON_WRITE
+/* Make the source SV into a loop of 1.
+(about to become 2) */
+SV_COW_NEXT_SV_SET(sstr, sstr);
+# else
+		    CowREFCNT(sstr) = 0;
+# endif
+}
+#endif
+	    if (SvPVX_const(dstr)) {	/* we know that dtype >= SVt_PV */
+		SvPV_free(dstr);
+	    }
+#ifdef PERL_ANY_COW
+	    if (len) {
+# ifdef PERL_OLD_COPY_ON_WRITE
+		    assert (SvTYPE(dstr) >= SVt_PVIV);
+/* SvIsCOW_normal */
+/* splice us in between source and next-after-source.  */
+SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
+SV_COW_NEXT_SV_SET(sstr, dstr);
+# else
+		    if (sflags & SVf_IsCOW) {
+			sv_buf_to_rw(sstr);
+		    }
+		    CowREFCNT(sstr)++;
+# endif
+SvPV_set(dstr, SvPVX_mutable(sstr));
+sv_buf_to_ro(sstr);
+} else
+#endif
+{
+/* SvIsCOW_shared_hash */
+DEBUG_C(PerlIO_printf(Perl_debug_log,
+"Copy on write: Sharing hash\n"));
+		    assert (SvTYPE(dstr) >= SVt_PV);
+SvPV_set(dstr,
+			     HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
+	    }
+	    SvLEN_set(dstr, len);
+	    SvCUR_set(dstr, cur);
+	    SvIsCOW_on(dstr);
+	} else {
+	    /* Failed the swipe test, and we cannot do copy-on-write either.
+	       Have to copy the string.  */
+	    SvGROW(dstr, cur + 1);	/* inlined from sv_setpvn */
+	    Move(SvPVX_const(sstr),SvPVX(dstr),cur,char);
+	    SvCUR_set(dstr, cur);
+	    *SvEND(dstr) = '\0';
+}
+	if (sflags & SVp_NOK) {
+	    SvNV_set(dstr, SvNVX(sstr));
+	}
+	if (sflags & SVp_IOK) {
+	    SvIV_set(dstr, SvIVX(sstr));
+	    /* Must do this otherwise some other overloaded use of 0x80000000
+	       gets confused. I guess SVpbm_VALID */
+	    if (sflags & SVf_IVisUV)
+		SvIsUV_on(dstr);
+	}
+	SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
+	{
+	    const MAGIC * const smg = SvVSTRING_mg(sstr);
+	    if (smg) {
+		sv_magic(dstr, NULL, PERL_MAGIC_vstring,
+			 smg->mg_ptr, smg->mg_len);
+		SvRMAGICAL_on(dstr);
+	    }
+	}
+}
+else if (sflags & (SVp_IOK|SVp_NOK)) {
+	(void)SvOK_off(dstr);
+	SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
+	if (sflags & SVp_IOK) {
+	    /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
+	    SvIV_set(dstr, SvIVX(sstr));
+	}
+	if (sflags & SVp_NOK) {
+	    SvNV_set(dstr, SvNVX(sstr));
+	}
+}
+else {
+	if (isGV_with_GP(sstr)) {
+	    gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
+	}
+	else
+	    (void)SvOK_off(dstr);
+}
+if (SvTAINTED(sstr))
+	SvTAINT(dstr);
+}
+/*
+=for apidoc sv_setsv_mg
+Like C<sv_setsv>, but also handles 'set' magic.
+=cut
+*/
+void
+Perl_sv_setsv_mg(pTHX_ SV *const dstr, SV *const sstr)
+{
+PERL_ARGS_ASSERT_SV_SETSV_MG;
+sv_setsv(dstr,sstr);
+SvSETMAGIC(dstr);
+}
+#ifdef PERL_ANY_COW
+# ifdef PERL_OLD_COPY_ON_WRITE
+#  define SVt_COW SVt_PVIV
+# else
+#  define SVt_COW SVt_PV
+# endif
+SV *
+Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
+{
+STRLEN cur = SvCUR(sstr);
+STRLEN len = SvLEN(sstr);
+char *new_pv;
+#if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_NEW_COPY_ON_WRITE)
+const bool already = cBOOL(SvIsCOW(sstr));
+#endif
+PERL_ARGS_ASSERT_SV_SETSV_COW;
+if (DEBUG_C_TEST) {
+	PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
+		      (void*)sstr, (void*)dstr);
+	sv_dump(sstr);
+	if (dstr)
+		    sv_dump(dstr);
+}
+if (dstr) {
+	if (SvTHINKFIRST(dstr))
+	    sv_force_normal_flags(dstr, SV_COW_DROP_PV);
+	else if (SvPVX_const(dstr))
+	    Safefree(SvPVX_mutable(dstr));
+}
+else
+	new_SV(dstr);
+SvUPGRADE(dstr, SVt_COW);
+assert (SvPOK(sstr));
+assert (SvPOKp(sstr));
+# ifdef PERL_OLD_COPY_ON_WRITE
+assert (!SvIOK(sstr));
+assert (!SvIOKp(sstr));
+assert (!SvNOK(sstr));
+assert (!SvNOKp(sstr));
+# endif
+if (SvIsCOW(sstr)) {
+	if (SvLEN(sstr) == 0) {
+	    /* source is a COW shared hash key.  */
+	    DEBUG_C(PerlIO_printf(Perl_debug_log,
+				  "Fast copy on write: Sharing hash\n"));
+	    new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
+	    goto common_exit;
+	}
+# ifdef PERL_OLD_COPY_ON_WRITE
+	SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
+# else
+	assert(SvCUR(sstr)+1 < SvLEN(sstr));
+	assert(CowREFCNT(sstr) < SV_COW_REFCNT_MAX);
+# endif
+} else {
+	assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
+	SvUPGRADE(sstr, SVt_COW);
+	SvIsCOW_on(sstr);
+	DEBUG_C(PerlIO_printf(Perl_debug_log,
+			      "Fast copy on write: Converting sstr to COW\n"));
+# ifdef PERL_OLD_COPY_ON_WRITE
+	SV_COW_NEXT_SV_SET(dstr, sstr);
+# else
+	CowREFCNT(sstr) = 0;
+# endif
+}
+# ifdef PERL_OLD_COPY_ON_WRITE
+SV_COW_NEXT_SV_SET(sstr, dstr);
+# else
+#  ifdef PERL_DEBUG_READONLY_COW
+if (already) sv_buf_to_rw(sstr);
+#  endif
+CowREFCNT(sstr)++;
+# endif
+new_pv = SvPVX_mutable(sstr);
+sv_buf_to_ro(sstr);
+common_exit:
+SvPV_set(dstr, new_pv);
+SvFLAGS(dstr) = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW);
+if (SvUTF8(sstr))
+	SvUTF8_on(dstr);
+SvLEN_set(dstr, len);
+SvCUR_set(dstr, cur);
+if (DEBUG_C_TEST) {
+	sv_dump(dstr);
+}
+return dstr;
+}
+#endif
+/*
+=for apidoc sv_setpvn
+Copies a string (possibly containing embedded C<NUL> characters) into an SV.
+The C<len> parameter indicates the number of
+bytes to be copied.  If the C<ptr> argument is NULL the SV will become
+undefined.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
+=cut
+*/
+void
+Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
+{
+char *dptr;
+PERL_ARGS_ASSERT_SV_SETPVN;
+SV_CHECK_THINKFIRST_COW_DROP(sv);
+if (!ptr) {
+	(void)SvOK_off(sv);
+	return;
+}
+else {
+/* len is STRLEN which is unsigned, need to copy to signed */
+	const IV iv = len;
+	if (iv < 0)
+	    Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %"
+		       IVdf, iv);
+}
+SvUPGRADE(sv, SVt_PV);
+dptr = SvGROW(sv, len + 1);
+Move(ptr,dptr,len,char);
+dptr[len] = '\0';
+SvCUR_set(sv, len);
+(void)SvPOK_only_UTF8(sv);		/* validate pointer */
+SvTAINT(sv);
+if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
+}
+/*
+=for apidoc sv_setpvn_mg
+Like C<sv_setpvn>, but also handles 'set' magic.
+=cut
+*/
+void
+Perl_sv_setpvn_mg(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
+{
+PERL_ARGS_ASSERT_SV_SETPVN_MG;
+sv_setpvn(sv,ptr,len);
+SvSETMAGIC(sv);
+}
+/*
+=for apidoc sv_setpv
+Copies a string into an SV.  The string must be terminated with a C<NUL>
+character.
+Does not handle 'set' magic.  See C<sv_setpv_mg>.
+=cut
+*/
+void
+Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
+{
+STRLEN len;
+PERL_ARGS_ASSERT_SV_SETPV;
+SV_CHECK_THINKFIRST_COW_DROP(sv);
+if (!ptr) {
+	(void)SvOK_off(sv);
+	return;
+}
+len = strlen(ptr);
+SvUPGRADE(sv, SVt_PV);
+SvGROW(sv, len + 1);
+Move(ptr,SvPVX(sv),len+1,char);
+SvCUR_set(sv, len);
+(void)SvPOK_only_UTF8(sv);		/* validate pointer */
+SvTAINT(sv);
+if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
+}
+/*
+=for apidoc sv_setpv_mg
+Like C<sv_setpv>, but also handles 'set' magic.
+=cut
+*/
+void
+Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr)
+{
+PERL_ARGS_ASSERT_SV_SETPV_MG;
+sv_setpv(sv,ptr);
+SvSETMAGIC(sv);
+}
+void
+Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
+{
+PERL_ARGS_ASSERT_SV_SETHEK;
+if (!hek) {
+	return;
+}
+if (HEK_LEN(hek) == HEf_SVKEY) {
+	sv_setsv(sv, *(SV**)HEK_KEY(hek));
+return;
+} else {
+	const int flags = HEK_FLAGS(hek);
+	if (flags & HVhek_WASUTF8) {
+	    STRLEN utf8_len = HEK_LEN(hek);
+	    char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len);
+	    sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
+	    SvUTF8_on(sv);
+return;
+} else if (flags & HVhek_UNSHARED) {
+	    sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
+	    if (HEK_UTF8(hek))
+		SvUTF8_on(sv);
+	    else SvUTF8_off(sv);
+return;
+	}
+{
+	    SV_CHECK_THINKFIRST_COW_DROP(sv);
+	    SvUPGRADE(sv, SVt_PV);
+	    SvPV_free(sv);
+	    SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
+	    SvCUR_set(sv, HEK_LEN(hek));
+	    SvLEN_set(sv, 0);
+	    SvIsCOW_on(sv);
+	    SvPOK_on(sv);
+	    if (HEK_UTF8(hek))
+		SvUTF8_on(sv);
+	    else SvUTF8_off(sv);
+return;
+	}
+}
+}
+/*
+=for apidoc sv_usepvn_flags
+Tells an SV to use C<ptr> to find its string value.  Normally the
+string is stored inside the SV, but sv_usepvn allows the SV to use an
+outside string.  The C<ptr> should point to memory that was allocated
+by L<Newx|perlclib/Memory Management and String Handling>.  It must be
+the start of a Newx-ed block of memory, and not a pointer to the
+middle of it (beware of L<OOK|perlguts/Offsets> and copy-on-write),
+and not be from a non-Newx memory allocator like C<malloc>.  The
+string length, C<len>, must be supplied.  By default this function
+will C<Renew> (i.e. realloc, move) the memory pointed to by C<ptr>,
+so that pointer should not be freed or used by the programmer after
+giving it to sv_usepvn, and neither should any pointers from "behind"
+that pointer (e.g. ptr + 1) be used.
+If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC.  If C<flags> &
+SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be C<NUL>, and the realloc
+will be skipped (i.e. the buffer is actually at least 1 byte longer than
+C<len>, and already meets the requirements for storing in C<SvPVX>).
+=cut
+*/
+void
+Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
+{
+STRLEN allocate;
+PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
+SV_CHECK_THINKFIRST_COW_DROP(sv);
+SvUPGRADE(sv, SVt_PV);
+if (!ptr) {
+	(void)SvOK_off(sv);
+	if (flags & SV_SMAGIC)
+	    SvSETMAGIC(sv);
+	return;
+}
+if (SvPVX_const(sv))
+	SvPV_free(sv);
+#ifdef DEBUGGING
+if (flags & SV_HAS_TRAILING_NUL)
+	assert(ptr[len] == '\0');
+#endif
+allocate = (flags & SV_HAS_TRAILING_NUL)
+	? len + 1 :
+#ifdef Perl_safesysmalloc_size
+	len + 1;
+#else
+	PERL_STRLEN_ROUNDUP(len + 1);
+#endif
+if (flags & SV_HAS_TRAILING_NUL) {
+	/* It's long enough - do nothing.
+	   Specifically Perl_newCONSTSUB is relying on this.  */
+} else {
+#ifdef DEBUGGING
+	/* Force a move to shake out bugs in callers.  */
+	char *new_ptr = (char*)safemalloc(allocate);
+	Copy(ptr, new_ptr, len, char);
+	PoisonFree(ptr,len,char);
+	Safefree(ptr);
+	ptr = new_ptr;
+#else
+	ptr = (char*) saferealloc (ptr, allocate);
+#endif
+}
+#ifdef Perl_safesysmalloc_size
+SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
+#else
+SvLEN_set(sv, allocate);
+#endif
+SvCUR_set(sv, len);
+SvPV_set(sv, ptr);
+if (!(flags & SV_HAS_TRAILING_NUL)) {
+	ptr[len] = '\0';
+}
+(void)SvPOK_only_UTF8(sv);		/* validate pointer */
+SvTAINT(sv);
+if (flags & SV_SMAGIC)
+	SvSETMAGIC(sv);
+}
+#ifdef PERL_OLD_COPY_ON_WRITE
+/* Need to do this *after* making the SV normal, as we need the buffer
+pointer to remain valid until after we've copied it.  If we let go too early,
+another thread could invalidate it by unsharing last of the same hash key
+(which it can do by means other than releasing copy-on-write Svs)
+or by changing the other copy-on-write SVs in the loop.  */
+STATIC void
+S_sv_release_COW(pTHX_ SV *sv, const char *pvx, SV *after)
+{
+PERL_ARGS_ASSERT_SV_RELEASE_COW;
+{ /* this SV was SvIsCOW_normal(sv) */
+/* we need to find the SV pointing to us.  */
+SV *current = SV_COW_NEXT_SV(after);
+if (current == sv) {
+/* The SV we point to points back to us (there were only two of us
+in the loop.)
+Hence other SV is no longer copy on write either.  */
+SvIsCOW_off(after);
+sv_buf_to_rw(after);
+} else {
+/* We need to follow the pointers around the loop.  */
+SV *next;
+while ((next = SV_COW_NEXT_SV(current)) != sv) {
+assert (next);
+current = next;
+/* don't loop forever if the structure is bust, and we have
+a pointer into a closed loop.  */
+assert (current != after);
+assert (SvPVX_const(current) == pvx);
+}
+/* Make the SV before us point to the SV after us.  */
+SV_COW_NEXT_SV_SET(current, after);
+}
+}
+}
+#endif
+/*
+=for apidoc sv_force_normal_flags
+Undo various types of fakery on an SV, where fakery means
+"more than" a string: if the PV is a shared string, make
+a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
+an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
+we do the copy, and is also used locally; if this is a
+vstring, drop the vstring magic.  If C<SV_COW_DROP_PV> is set
+then a copy-on-write scalar drops its PV buffer (if any) and becomes
+SvPOK_off rather than making a copy.  (Used where this
+scalar is about to be set to some other value.)  In addition,
+the C<flags> parameter gets passed to C<sv_unref_flags()>
+when unreffing.  C<sv_force_normal> calls this function
+with flags set to 0.
+This function is expected to be used to signal to perl that this SV is
+about to be written to, and any extra book-keeping needs to be taken care
+of.  Hence, it croaks on read-only values.
+=cut
+*/
+static void
+S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
+{
+assert(SvIsCOW(sv));
+{
+#ifdef PERL_ANY_COW
+	const char * const pvx = SvPVX_const(sv);
+	const STRLEN len = SvLEN(sv);
+	const STRLEN cur = SvCUR(sv);
+# ifdef PERL_OLD_COPY_ON_WRITE
+	/* next COW sv in the loop.  If len is 0 then this is a shared-hash
+	   key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
+	   we'll fail an assertion.  */
+	SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
+# endif
+if (DEBUG_C_TEST) {
+PerlIO_printf(Perl_debug_log,
+"Copy on write: Force normal %ld\n",
+(long) flags);
+sv_dump(sv);
+}
+SvIsCOW_off(sv);
+# ifdef PERL_NEW_COPY_ON_WRITE
+	if (len) {
+	    /* Must do this first, since the CowREFCNT uses SvPVX and
+	    we need to write to CowREFCNT, or de-RO the whole buffer if we are
+	    the only owner left of the buffer. */
+	    sv_buf_to_rw(sv); /* NOOP if RO-ing not supported */
+	    {
+		U8 cowrefcnt = CowREFCNT(sv);
+		if(cowrefcnt != 0) {
+		    cowrefcnt--;
+		    CowREFCNT(sv) = cowrefcnt;
+		    sv_buf_to_ro(sv);
+		    goto copy_over;
+		}
+	    }
+	    /* Else we are the only owner of the buffer. */
+}
+	else
+# endif
+	{
+/* This SV doesn't own the buffer, so need to Newx() a new one:  */
+copy_over:
+SvPV_set(sv, NULL);
+SvCUR_set(sv, 0);
+SvLEN_set(sv, 0);
+if (flags & SV_COW_DROP_PV) {
+/* OK, so we don't need to copy our buffer.  */
+SvPOK_off(sv);
+} else {
+SvGROW(sv, cur + 1);
+Move(pvx,SvPVX(sv),cur,char);
+SvCUR_set(sv, cur);
+*SvEND(sv) = '\0';
+}
+	    if (len) {
+# ifdef PERL_OLD_COPY_ON_WRITE
+		sv_release_COW(sv, pvx, next);
+# endif
+	    } else {
+		unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
+	    }
+if (DEBUG_C_TEST) {
+sv_dump(sv);
+}
+	}
+#else
+	    const char * const pvx = SvPVX_const(sv);
+	    const STRLEN len = SvCUR(sv);
+	    SvIsCOW_off(sv);
+	    SvPV_set(sv, NULL);
+	    SvLEN_set(sv, 0);
+	    if (flags & SV_COW_DROP_PV) {
+		/* OK, so we don't need to copy our buffer.  */
+		SvPOK_off(sv);
+	    } else {
+		SvGROW(sv, len + 1);
+		Move(pvx,SvPVX(sv),len,char);
+		*SvEND(sv) = '\0';
+	    }
+	    unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
+#endif
+}
+}
+void
+Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
+{
+PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
+if (SvREADONLY(sv))
+	Perl_croak_no_modify();
+else if (SvIsCOW(sv) && LIKELY(SvTYPE(sv) != SVt_PVHV))
+	S_sv_uncow(aTHX_ sv, flags);
+if (SvROK(sv))
+	sv_unref_flags(sv, flags);
+else if (SvFAKE(sv) && isGV_with_GP(sv))
+	sv_unglob(sv, flags);
+else if (SvFAKE(sv) && isREGEXP(sv)) {
+	/* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
+	   to sv_unglob. We only need it here, so inline it.  */
+	const bool islv = SvTYPE(sv) == SVt_PVLV;
+	const svtype new_type =
+	  islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
+	SV *const temp = newSV_type(new_type);
+	regexp *const temp_p = ReANY((REGEXP *)sv);
+	if (new_type == SVt_PVMG) {
+	    SvMAGIC_set(temp, SvMAGIC(sv));
+	    SvMAGIC_set(sv, NULL);
+	    SvSTASH_set(temp, SvSTASH(sv));
+	    SvSTASH_set(sv, NULL);
+	}
+	if (!islv) SvCUR_set(temp, SvCUR(sv));
+	/* Remember that SvPVX is in the head, not the body.  But
+	   RX_WRAPPED is in the body. */
+	assert(ReANY((REGEXP *)sv)->mother_re);
+	/* Their buffer is already owned by someone else. */
+	if (flags & SV_COW_DROP_PV) {
+	    /* SvLEN is already 0.  For SVt_REGEXP, we have a brand new
+	       zeroed body.  For SVt_PVLV, it should have been set to 0
+	       before turning into a regexp. */
+	    assert(!SvLEN(islv ? sv : temp));
+	    sv->sv_u.svu_pv = 0;
+	}
+	else {
+	    sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv));
+	    SvLEN_set(islv ? sv : temp, SvCUR(sv)+1);
+	    SvPOK_on(sv);
+	}
+	/* Now swap the rest of the bodies. */
+	SvFAKE_off(sv);
+	if (!islv) {
+	    SvFLAGS(sv) &= ~SVTYPEMASK;
+	    SvFLAGS(sv) |= new_type;
+	    SvANY(sv) = SvANY(temp);
+	}
+	SvFLAGS(temp) &= ~(SVTYPEMASK);
+	SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
+	SvANY(temp) = temp_p;
+	temp->sv_u.svu_rx = (regexp *)temp_p;
+	SvREFCNT_dec_NN(temp);
+}
+else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring);
+}
+/*
+=for apidoc sv_chop
+Efficient removal of characters from the beginning of the string buffer.
+SvPOK(sv), or at least SvPOKp(sv), must be true and the C<ptr> must be a
+pointer to somewhere inside the string buffer.  The C<ptr> becomes the first
+character of the adjusted string.  Uses the "OOK hack".  On return, only
+SvPOK(sv) and SvPOKp(sv) among the OK flags will be true.
+Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
+refer to the same chunk of data.
+The unfortunate similarity of this function's name to that of Perl's C<chop>
+operator is strictly coincidental.  This function works from the left;
+C<chop> works from the right.
+=cut
+*/
+void
+Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr)
+{
+STRLEN delta;
+STRLEN old_delta;
+U8 *p;
+#ifdef DEBUGGING
+const U8 *evacp;
+STRLEN evacn;
+#endif
+STRLEN max_delta;
+PERL_ARGS_ASSERT_SV_CHOP;
+if (!ptr || !SvPOKp(sv))
+	return;
+delta = ptr - SvPVX_const(sv);
+if (!delta) {
+	/* Nothing to do.  */
+	return;
+}
+max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
+if (delta > max_delta)
+	Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
+		   ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
+/* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */
+SV_CHECK_THINKFIRST(sv);
+SvPOK_only_UTF8(sv);
+if (!SvOOK(sv)) {
+	if (!SvLEN(sv)) { /* make copy of shared string */
+	    const char *pvx = SvPVX_const(sv);
+	    const STRLEN len = SvCUR(sv);
+	    SvGROW(sv, len + 1);
+	    Move(pvx,SvPVX(sv),len,char);
+	    *SvEND(sv) = '\0';
+	}
+	SvOOK_on(sv);
+	old_delta = 0;
+} else {
+	SvOOK_offset(sv, old_delta);
+}
+SvLEN_set(sv, SvLEN(sv) - delta);
+SvCUR_set(sv, SvCUR(sv) - delta);
+SvPV_set(sv, SvPVX(sv) + delta);
+p = (U8 *)SvPVX_const(sv);
+#ifdef DEBUGGING
+/* how many bytes were evacuated?  we will fill them with sentinel
+bytes, except for the part holding the new offset of course. */
+evacn = delta;
+if (old_delta)
+	evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN));
+assert(evacn);
+assert(evacn <= delta + old_delta);
+evacp = p - evacn;
+#endif
+/* This sets 'delta' to the accumulated value of all deltas so far */
+delta += old_delta;
+assert(delta);
+/* If 'delta' fits in a byte, store it just prior to the new beginning of
+* the string; otherwise store a 0 byte there and store 'delta' just prior
+* to that, using as many bytes as a STRLEN occupies.  Thus it overwrites a
+* portion of the chopped part of the string */
+if (delta < 0x100) {
+	*--p = (U8) delta;
+} else {
+	*--p = 0;
+	p -= sizeof(STRLEN);
+	Copy((U8*)&delta, p, sizeof(STRLEN), U8);
+}
+#ifdef DEBUGGING
+/* Fill the preceding buffer with sentinals to verify that no-one is
+using it.  */
+while (p > evacp) {
+	--p;
+	*p = (U8)PTR2UV(p);
+}
+#endif
+}
+/*
+=for apidoc sv_catpvn
+Concatenates the string onto the end of the string which is in the SV.  The
+C<len> indicates number of bytes to copy.  If the SV has the UTF-8
+status set, then the bytes appended should be valid UTF-8.
+Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
+=for apidoc sv_catpvn_flags
+Concatenates the string onto the end of the string which is in the SV.  The
+C<len> indicates number of bytes to copy.
+By default, the string appended is assumed to be valid UTF-8 if the SV has
+the UTF-8 status set, and a string of bytes otherwise.  One can force the
+appended string to be interpreted as UTF-8 by supplying the C<SV_CATUTF8>
+flag, and as bytes by supplying the C<SV_CATBYTES> flag; the SV or the
+string appended will be upgraded to UTF-8 if necessary.
+If C<flags> has the C<SV_SMAGIC> bit set, will
+C<mg_set> on C<dsv> afterwards if appropriate.
+C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
+in terms of this function.
+=cut
+*/
+void
+Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags)
+{
+STRLEN dlen;
+const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
+PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
+assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8));
+if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) {
+if (flags & SV_CATUTF8 && !SvUTF8(dsv)) {
+	 sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
+	 dlen = SvCUR(dsv);
+}
+else SvGROW(dsv, dlen + slen + 1);
+if (sstr == dstr)
+	sstr = SvPVX_const(dsv);
+Move(sstr, SvPVX(dsv) + dlen, slen, char);
+SvCUR_set(dsv, SvCUR(dsv) + slen);
+}
+else {
+	/* We inline bytes_to_utf8, to avoid an extra malloc. */
+	const char * const send = sstr + slen;
+	U8 *d;
+	/* Something this code does not account for, which I think is
+	   impossible; it would require the same pv to be treated as
+	   bytes *and* utf8, which would indicate a bug elsewhere. */
+	assert(sstr != dstr);
+	SvGROW(dsv, dlen + slen * 2 + 1);
+	d = (U8 *)SvPVX(dsv) + dlen;
+	while (sstr < send) {
+append_utf8_from_native_byte(*sstr, &d);
+	    sstr++;
+	}
+	SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv));
+}
+*SvEND(dsv) = '\0';
+(void)SvPOK_only_UTF8(dsv);		/* validate pointer */
+SvTAINT(dsv);
+if (flags & SV_SMAGIC)
+	SvSETMAGIC(dsv);
+}
+/*
+=for apidoc sv_catsv
+Concatenates the string from SV C<ssv> onto the end of the string in SV
+C<dsv>.  If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
+Handles 'get' magic on both SVs, but no 'set' magic.  See C<sv_catsv_mg> and
+C<sv_catsv_nomg>.
+=for apidoc sv_catsv_flags
+Concatenates the string from SV C<ssv> onto the end of the string in SV
+C<dsv>.  If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
+If C<flags> include C<SV_GMAGIC> bit set, will call C<mg_get> on both SVs if
+appropriate.  If C<flags> include C<SV_SMAGIC>, C<mg_set> will be called on
+the modified SV afterward, if appropriate.  C<sv_catsv>, C<sv_catsv_nomg>,
+and C<sv_catsv_mg> are implemented in terms of this function.
+=cut */
+void
+Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
+{
+PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
+if (ssv) {
+	STRLEN slen;
+	const char *spv = SvPV_flags_const(ssv, slen, flags);
+if (flags & SV_GMAGIC)
+SvGETMAGIC(dsv);
+sv_catpvn_flags(dsv, spv, slen,
+			    DO_UTF8(ssv) ? SV_CATUTF8 : SV_CATBYTES);
+if (flags & SV_SMAGIC)
+SvSETMAGIC(dsv);
+}
+}
+/*
+=for apidoc sv_catpv
+Concatenates the C<NUL>-terminated string onto the end of the string which is
+in the SV.
+If the SV has the UTF-8 status set, then the bytes appended should be
+valid UTF-8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
+=cut */
+void
+Perl_sv_catpv(pTHX_ SV *const sv, const char *ptr)
+{
+STRLEN len;
+STRLEN tlen;
+char *junk;
+PERL_ARGS_ASSERT_SV_CATPV;
+if (!ptr)
+	return;
+junk = SvPV_force(sv, tlen);
+len = strlen(ptr);
+SvGROW(sv, tlen + len + 1);
+if (ptr == junk)
+	ptr = SvPVX_const(sv);
+Move(ptr,SvPVX(sv)+tlen,len+1,char);
+SvCUR_set(sv, SvCUR(sv) + len);
+(void)SvPOK_only_UTF8(sv);		/* validate pointer */
+SvTAINT(sv);
+}
+/*
+=for apidoc sv_catpv_flags
+Concatenates the C<NUL>-terminated string onto the end of the string which is
+in the SV.
+If the SV has the UTF-8 status set, then the bytes appended should
+be valid UTF-8.  If C<flags> has the C<SV_SMAGIC> bit set, will C<mg_set>
+on the modified SV if appropriate.
+=cut
+*/
+void
+Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, const I32 flags)
+{
+PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
+sv_catpvn_flags(dstr, sstr, strlen(sstr), flags);
+}
+/*
+=for apidoc sv_catpv_mg
+Like C<sv_catpv>, but also handles 'set' magic.
+=cut
+*/
+void
+Perl_sv_catpv_mg(pTHX_ SV *const sv, const char *const ptr)
+{
+PERL_ARGS_ASSERT_SV_CATPV_MG;
+sv_catpv(sv,ptr);
+SvSETMAGIC(sv);
+}
+/*
+=for apidoc newSV
+Creates a new SV.  A non-zero C<len> parameter indicates the number of
+bytes of preallocated string space the SV should have.  An extra byte for a
+trailing C<NUL> is also reserved.  (SvPOK is not set for the SV even if string
+space is allocated.)  The reference count for the new SV is set to 1.
+In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
+parameter, I<x>, a debug aid which allowed callers to identify themselves.
+This aid has been superseded by a new build option, PERL_MEM_LOG (see
+L<perlhacktips/PERL_MEM_LOG>).  The older API is still there for use in XS
+modules supporting older perls.
+=cut
+*/
+SV *
+Perl_newSV(pTHX_ const STRLEN len)
+{
+SV *sv;
+new_SV(sv);
+if (len) {
+	sv_grow(sv, len + 1);
+}
+return sv;
+}
+/*
+=for apidoc sv_magicext
+Adds magic to an SV, upgrading it if necessary.  Applies the
+supplied vtable and returns a pointer to the magic added.
+Note that C<sv_magicext> will allow things that C<sv_magic> will not.
+In particular, you can add magic to SvREADONLY SVs, and add more than
+one instance of the same 'how'.
+If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
+stored, if C<namlen> is zero then C<name> is stored as-is and - as another
+special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
+to contain an C<SV*> and is stored as-is with its REFCNT incremented.
+(This is now used as a subroutine by C<sv_magic>.)
+=cut
+*/
+MAGIC *
+Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
+const MGVTBL *const vtable, const char *const name, const I32 namlen)
+{
+MAGIC* mg;
+PERL_ARGS_ASSERT_SV_MAGICEXT;
+SvUPGRADE(sv, SVt_PVMG);
+Newxz(mg, 1, MAGIC);
+mg->mg_moremagic = SvMAGIC(sv);
+SvMAGIC_set(sv, mg);
+/* Sometimes a magic contains a reference loop, where the sv and
+object refer to each other.  To prevent a reference loop that
+would prevent such objects being freed, we look for such loops
+and if we find one we avoid incrementing the object refcount.
+Note we cannot do this to avoid self-tie loops as intervening RV must
+have its REFCNT incremented to keep it in existence.
+*/
+if (!obj || obj == sv ||
+	how == PERL_MAGIC_arylen ||
+	how == PERL_MAGIC_symtab ||
+	(SvTYPE(obj) == SVt_PVGV &&
+	    (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
+	     || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
+	     || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
+{
+	mg->mg_obj = obj;
+}
+else {
+	mg->mg_obj = SvREFCNT_inc_simple(obj);
+	mg->mg_flags |= MGf_REFCOUNTED;
+}
+/* Normal self-ties simply pass a null object, and instead of
+using mg_obj directly, use the SvTIED_obj macro to produce a
+new RV as needed.  For glob "self-ties", we are tieing the PVIO
+with an RV obj pointing to the glob containing the PVIO.  In
+this case, to avoid a reference loop, we need to weaken the
+reference.
+*/
+if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
+obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
+{
+sv_rvweaken(obj);
+}
+mg->mg_type = how;
+mg->mg_len = namlen;
+if (name) {
+	if (namlen > 0)
+	    mg->mg_ptr = savepvn(name, namlen);
+	else if (namlen == HEf_SVKEY) {
+	    /* Yes, this is casting away const. This is only for the case of
+	       HEf_SVKEY. I think we need to document this aberation of the
+	       constness of the API, rather than making name non-const, as
+	       that change propagating outwards a long way.  */
+	    mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
+	} else
+	    mg->mg_ptr = (char *) name;
+}
+mg->mg_virtual = (MGVTBL *) vtable;
+mg_magical(sv);
+return mg;
+}
+MAGIC *
+Perl_sv_magicext_mglob(pTHX_ SV *sv)
+{
+PERL_ARGS_ASSERT_SV_MAGICEXT_MGLOB;
+if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
+	/* This sv is only a delegate.  //g magic must be attached to
+	   its target. */
+	vivify_defelem(sv);
+	sv = LvTARG(sv);
+}
+#ifdef PERL_OLD_COPY_ON_WRITE
+if (SvIsCOW(sv))
+	sv_force_normal_flags(sv, 0);
+#endif
+return sv_magicext(sv, NULL, PERL_MAGIC_regex_global,
+		       &PL_vtbl_mglob, 0, 0);
+}
+/*
+=for apidoc sv_magic
+Adds magic to an SV.  First upgrades C<sv> to type C<SVt_PVMG> if
+necessary, then adds a new magic item of type C<how> to the head of the
+magic list.
+See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
+handling of the C<name> and C<namlen> arguments.
+You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
+to add more than one instance of the same 'how'.
+=cut
+*/
+void
+Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how,
+const char *const name, const I32 namlen)
+{
+const MGVTBL *vtable;
+MAGIC* mg;
+unsigned int flags;
+unsigned int vtable_index;
+PERL_ARGS_ASSERT_SV_MAGIC;
+if (how < 0 || (unsigned)how >= C_ARRAY_LENGTH(PL_magic_data)
+	|| ((flags = PL_magic_data[how]),
+	    (vtable_index = flags & PERL_MAGIC_VTABLE_MASK)
+	    > magic_vtable_max))
+	Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
+/* PERL_MAGIC_ext is reserved for use by extensions not perl internals.
+Useful for attaching extension internal data to perl vars.
+Note that multiple extensions may clash if magical scalars
+etc holding private data from one are passed to another. */
+vtable = (vtable_index == magic_vtable_max)
+	? NULL : PL_magic_vtables + vtable_index;
+#ifdef PERL_OLD_COPY_ON_WRITE
+if (SvIsCOW(sv))
+sv_force_normal_flags(sv, 0);
+#endif
+if (SvREADONLY(sv)) {
+	if (
+	    !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
+	   )
+	{
+	    Perl_croak_no_modify();
+	}
+}
+if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
+	if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
+	    /* sv_magic() refuses to add a magic of the same 'how' as an
+	       existing one
+	     */
+	    if (how == PERL_MAGIC_taint)
+		mg->mg_len |= 1;
+	    return;
+	}
+}
+/* Force pos to be stored as characters, not bytes. */
+if (SvMAGICAL(sv) && DO_UTF8(sv)
+&& (mg = mg_find(sv, PERL_MAGIC_regex_global))
+&& mg->mg_len != -1
+&& mg->mg_flags & MGf_BYTES) {
+	mg->mg_len = (SSize_t)sv_pos_b2u_flags(sv, (STRLEN)mg->mg_len,
+					       SV_CONST_RETURN);
+	mg->mg_flags &= ~MGf_BYTES;
+}
+/* Rest of work is done else where */
+mg = sv_magicext(sv,obj,how,vtable,name,namlen);
+switch (how) {
+case PERL_MAGIC_taint:
+	mg->mg_len = 1;
+	break;
+case PERL_MAGIC_ext:
+case PERL_MAGIC_dbfile:
+	SvRMAGICAL_on(sv);
+	break;
+}
+}
+static int
+S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)
+{
+MAGIC* mg;
+MAGIC** mgp;
+assert(flags <= 1);
+if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
+	return 0;
+mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
+for (mg = *mgp; mg; mg = *mgp) {
+	const MGVTBL* const virt = mg->mg_virtual;
+	if (mg->mg_type == type && (!flags || virt == vtbl)) {
+	    *mgp = mg->mg_moremagic;
+	    if (virt && virt->svt_free)
+		virt->svt_free(aTHX_ sv, mg);
+	    if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
+		if (mg->mg_len > 0)
+		    Safefree(mg->mg_ptr);
+		else if (mg->mg_len == HEf_SVKEY)
+		    SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
+		else if (mg->mg_type == PERL_MAGIC_utf8)
+		    Safefree(mg->mg_ptr);
+}
+	    if (mg->mg_flags & MGf_REFCOUNTED)
+		SvREFCNT_dec(mg->mg_obj);
+	    Safefree(mg);
+	}
+	else
+	    mgp = &mg->mg_moremagic;
+}
+if (SvMAGIC(sv)) {
+	if (SvMAGICAL(sv))	/* if we're under save_magic, wait for restore_magic; */
+	    mg_magical(sv);	/*    else fix the flags now */
+}
+else {
+	SvMAGICAL_off(sv);
+	SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+}
+return 0;
+}
+/*
+=for apidoc sv_unmagic
+Removes all magic of type C<type> from an SV.
+=cut
+*/
+int
+Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
+{
+PERL_ARGS_ASSERT_SV_UNMAGIC;
+return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0);
+}
+/*
+=for apidoc sv_unmagicext
+Removes all magic of type C<type> with the specified C<vtbl> from an SV.
+=cut
+*/
+int
+Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
+{
+PERL_ARGS_ASSERT_SV_UNMAGICEXT;
+return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1);
+}
+/*
+=for apidoc sv_rvweaken
+Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
+referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
+push a back-reference to this RV onto the array of backreferences
+associated with that magic.  If the RV is magical, set magic will be
+called after the RV is cleared.
+=cut
+*/
+SV *
+Perl_sv_rvweaken(pTHX_ SV *const sv)
+{
+SV *tsv;
+PERL_ARGS_ASSERT_SV_RVWEAKEN;
+if (!SvOK(sv))  /* let undefs pass */
+	return sv;
+if (!SvROK(sv))
+	Perl_croak(aTHX_ "Can't weaken a nonreference");
+else if (SvWEAKREF(sv)) {
+	Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
+	return sv;
+}
+else if (SvREADONLY(sv)) croak_no_modify();
+tsv = SvRV(sv);
+Perl_sv_add_backref(aTHX_ tsv, sv);
+SvWEAKREF_on(sv);
+SvREFCNT_dec_NN(tsv);
+return sv;
+}
+/*
+=for apidoc sv_get_backrefs
+If the sv is the target of a weak reference then it returns the back
+references structure associated with the sv; otherwise return NULL.
+When returning a non-null result the type of the return is relevant. If it
+is an AV then the elements of the AV are the weak reference RVs which
+point at this item. If it is any other type then the item itself is the
+weak reference.
+See also Perl_sv_add_backref(), Perl_sv_del_backref(),
+Perl_sv_kill_backrefs()
+=cut
+*/
+SV *
+Perl_sv_get_backrefs(SV *const sv)
+{
+SV *backrefs= NULL;
+PERL_ARGS_ASSERT_SV_GET_BACKREFS;
+/* find slot to store array or singleton backref */
+if (SvTYPE(sv) == SVt_PVHV) {
+if (SvOOK(sv)) {
+struct xpvhv_aux * const iter = HvAUX((HV *)sv);
+backrefs = (SV *)iter->xhv_backreferences;
+}
+} else if (SvMAGICAL(sv)) {
+MAGIC *mg = mg_find(sv, PERL_MAGIC_backref);
+if (mg)
+backrefs = mg->mg_obj;
+}
+return backrefs;
+}
+/* Give tsv backref magic if it hasn't already got it, then push a
+* back-reference to sv onto the array associated with the backref magic.
+*
+* As an optimisation, if there's only one backref and it's not an AV,
+* store it directly in the HvAUX or mg_obj slot, avoiding the need to
+* allocate an AV. (Whether the slot holds an AV tells us whether this is
+* active.)
+*/
+/* A discussion about the backreferences array and its refcount:
+*
+* The AV holding the backreferences is pointed to either as the mg_obj of
+* PERL_MAGIC_backref, or in the specific case of a HV, from the
+* xhv_backreferences field. The array is created with a refcount
+* of 2. This means that if during global destruction the array gets
+* picked on before its parent to have its refcount decremented by the
+* random zapper, it won't actually be freed, meaning it's still there for
+* when its parent gets freed.
+*
+* When the parent SV is freed, the extra ref is killed by
+* Perl_sv_kill_backrefs.  The other ref is killed, in the case of magic,
+* by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs.
+*
+* When a single backref SV is stored directly, it is not reference
+* counted.
+*/
+void
+Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
+{
+SV **svp;
+AV *av = NULL;
+MAGIC *mg = NULL;
+PERL_ARGS_ASSERT_SV_ADD_BACKREF;
+/* find slot to store array or singleton backref */
+if (SvTYPE(tsv) == SVt_PVHV) {
+	svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
+} else {
+if (SvMAGICAL(tsv))
+mg = mg_find(tsv, PERL_MAGIC_backref);
+	if (!mg)
+mg = sv_magicext(tsv, NULL, PERL_MAGIC_backref, &PL_vtbl_backref, NULL, 0);
+	svp = &(mg->mg_obj);
+}
+/* create or retrieve the array */
+if (   (!*svp && SvTYPE(sv) == SVt_PVAV)
+	|| (*svp && SvTYPE(*svp) != SVt_PVAV)
+) {
+	/* create array */
+	if (mg)
+	    mg->mg_flags |= MGf_REFCOUNTED;
+	av = newAV();
+	AvREAL_off(av);
+	SvREFCNT_inc_simple_void_NN(av);
+	/* av now has a refcnt of 2; see discussion above */
+	av_extend(av, *svp ? 2 : 1);
+	if (*svp) {
+	    /* move single existing backref to the array */
+	    AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
+	}
+	*svp = (SV*)av;
+}
+else {
+	av = MUTABLE_AV(*svp);
+if (!av) {
+/* optimisation: store single backref directly in HvAUX or mg_obj */
+*svp = sv;
+return;
+}
+assert(SvTYPE(av) == SVt_PVAV);
+if (AvFILLp(av) >= AvMAX(av)) {
+av_extend(av, AvFILLp(av)+1);
+}
+}
+/* push new backref */
+AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
+}
+/* delete a back-reference to ourselves from the backref magic associated
+* with the SV we point to.
+*/
+void
+Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
+{
+SV **svp = NULL;
+PERL_ARGS_ASSERT_SV_DEL_BACKREF;
+if (SvTYPE(tsv) == SVt_PVHV) {
+	if (SvOOK(tsv))
+	    svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
+}
+else if (SvIS_FREED(tsv) && PL_phase == PERL_PHASE_DESTRUCT) {
+	/* It's possible for the the last (strong) reference to tsv to have
+	   become freed *before* the last thing holding a weak reference.
+	   If both survive longer than the backreferences array, then when
+	   the referent's reference count drops to 0 and it is freed, it's
+	   not able to chase the backreferences, so they aren't NULLed.
+	   For example, a CV holds a weak reference to its stash. If both the
+	   CV and the stash survive longer than the backreferences array,
+	   and the CV gets picked for the SvBREAK() treatment first,
+	   *and* it turns out that the stash is only being kept alive because
+	   of an our variable in the pad of the CV, then midway during CV
+	   destruction the stash gets freed, but CvSTASH() isn't set to NULL.
+	   It ends up pointing to the freed HV. Hence it's chased in here, and
+	   if this block wasn't here, it would hit the !svp panic just below.
+	   I don't believe that "better" destruction ordering is going to help
+	   here - during global destruction there's always going to be the
+	   chance that something goes out of order. We've tried to make it
+	   foolproof before, and it only resulted in evolutionary pressure on
+	   fools. Which made us look foolish for our hubris. :-(
+	*/
+	return;
+}
+else {
+	MAGIC *const mg
+	    = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
+	svp =  mg ? &(mg->mg_obj) : NULL;
+}
+if (!svp)
+	Perl_croak(aTHX_ "panic: del_backref, svp=0");
+if (!*svp) {
+	/* It's possible that sv is being freed recursively part way through the
+	   freeing of tsv. If this happens, the backreferences array of tsv has
+	   already been freed, and so svp will be NULL. If this is the case,
+	   we should not panic. Instead, nothing needs doing, so return.  */
+	if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0)
+	    return;
+	Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf,
+		   (void*)*svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv));
+}
+if (SvTYPE(*svp) == SVt_PVAV) {
+#ifdef DEBUGGING
+	int count = 1;
+#endif
+	AV * const av = (AV*)*svp;
+	SSize_t fill;
+	assert(!SvIS_FREED(av));
+	fill = AvFILLp(av);
+	assert(fill > -1);
+	svp = AvARRAY(av);
+	/* for an SV with N weak references to it, if all those
+	 * weak refs are deleted, then sv_del_backref will be called
+	 * N times and O(N^2) compares will be done within the backref
+	 * array. To ameliorate this potential slowness, we:
+	 * 1) make sure this code is as tight as possible;
+	 * 2) when looking for SV, look for it at both the head and tail of the
+	 *    array first before searching the rest, since some create/destroy
+	 *    patterns will cause the backrefs to be freed in order.
+	 */
+	if (*svp == sv) {
+	    AvARRAY(av)++;
+	    AvMAX(av)--;
+	}
+	else {
+	    SV **p = &svp[fill];
+	    SV *const topsv = *p;
+	    if (topsv != sv) {
+#ifdef DEBUGGING
+		count = 0;
+#endif
+		while (--p > svp) {
+		    if (*p == sv) {
+			/* We weren't the last entry.
+			   An unordered list has this property that you
+			   can take the last element off the end to fill
+			   the hole, and it's still an unordered list :-)
+			*/
+			*p = topsv;
+#ifdef DEBUGGING
+			count++;
+#else
+			break; /* should only be one */
+#endif
+		    }
+		}
+	    }
+	}
+	assert(count ==1);
+	AvFILLp(av) = fill-1;
+}
+else if (SvIS_FREED(*svp) && PL_phase == PERL_PHASE_DESTRUCT) {
+	/* freed AV; skip */
+}
+else {
+	/* optimisation: only a single backref, stored directly */
+	if (*svp != sv)
+	    Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p",
+(void*)*svp, (void*)sv);
+	*svp = NULL;
+}
+}
+void
+Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
+{
+SV **svp;
+SV **last;
+bool is_array;
+PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
+if (!av)
+	return;
+/* after multiple passes through Perl_sv_clean_all() for a thingy
+* that has badly leaked, the backref array may have gotten freed,
+* since we only protect it against 1 round of cleanup */
+if (SvIS_FREED(av)) {
+	if (PL_in_clean_all) /* All is fair */
+	    return;
+	Perl_croak(aTHX_
+		   "panic: magic_killbackrefs (freed backref AV/SV)");
+}
+is_array = (SvTYPE(av) == SVt_PVAV);
+if (is_array) {
+	assert(!SvIS_FREED(av));
+	svp = AvARRAY(av);
+	if (svp)
+	    last = svp + AvFILLp(av);
+}
+else {
+	/* optimisation: only a single backref, stored directly */
+	svp = (SV**)&av;
+	last = svp;
+}
+if (svp) {
+	while (svp <= last) {
+	    if (*svp) {
+		SV *const referrer = *svp;
+		if (SvWEAKREF(referrer)) {
+		    /* XXX Should we check that it hasn't changed? */
+		    assert(SvROK(referrer));
+		    SvRV_set(referrer, 0);
+		    SvOK_off(referrer);
+		    SvWEAKREF_off(referrer);
+		    SvSETMAGIC(referrer);
+		} else if (SvTYPE(referrer) == SVt_PVGV ||
+			   SvTYPE(referrer) == SVt_PVLV) {
+		    assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
+		    /* You lookin' at me?  */
+		    assert(GvSTASH(referrer));
+		    assert(GvSTASH(referrer) == (const HV *)sv);
+		    GvSTASH(referrer) = 0;
+		} else if (SvTYPE(referrer) == SVt_PVCV ||
+			   SvTYPE(referrer) == SVt_PVFM) {
+		    if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
+			/* You lookin' at me?  */
+			assert(CvSTASH(referrer));
+			assert(CvSTASH(referrer) == (const HV *)sv);
+			SvANY(MUTABLE_CV(referrer))->xcv_stash = 0;
+		    }
+		    else {
+			assert(SvTYPE(sv) == SVt_PVGV);
+			/* You lookin' at me?  */
+			assert(CvGV(referrer));
+			assert(CvGV(referrer) == (const GV *)sv);
+			anonymise_cv_maybe(MUTABLE_GV(sv),
+						MUTABLE_CV(referrer));
+		    }
+		} else {
+		    Perl_croak(aTHX_
+			       "panic: magic_killbackrefs (flags=%"UVxf")",
+			       (UV)SvFLAGS(referrer));
+		}
+		if (is_array)
+		    *svp = NULL;
+	    }
+	    svp++;
+	}
+}
+if (is_array) {
+	AvFILLp(av) = -1;
+	SvREFCNT_dec_NN(av); /* remove extra count added by sv_add_backref() */
+}
+return;
+}
+/*
+=for apidoc sv_insert
+Inserts a string at the specified offset/length within the SV.  Similar to
+the Perl substr() function.  Handles get magic.
+=for apidoc sv_insert_flags
+Same as C<sv_insert>, but the extra C<flags> are passed to the
+C<SvPV_force_flags> that applies to C<bigstr>.
+=cut
+*/
+void
+Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
+{
+char *big;
+char *mid;
+char *midend;
+char *bigend;
+SSize_t i;		/* better be sizeof(STRLEN) or bad things happen */
+STRLEN curlen;
+PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
+SvPV_force_flags(bigstr, curlen, flags);
+(void)SvPOK_only_UTF8(bigstr);
+if (offset + len > curlen) {
+	SvGROW(bigstr, offset+len+1);
+	Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
+	SvCUR_set(bigstr, offset+len);
+}
+SvTAINT(bigstr);
+i = littlelen - len;
+if (i > 0) {			/* string might grow */
+	big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
+	mid = big + offset + len;
+	midend = bigend = big + SvCUR(bigstr);
+	bigend += i;
+	*bigend = '\0';
+	while (midend > mid)		/* shove everything down */
+	    *--bigend = *--midend;
+	Move(little,big+offset,littlelen,char);
+	SvCUR_set(bigstr, SvCUR(bigstr) + i);
+	SvSETMAGIC(bigstr);
+	return;
+}
+else if (i == 0) {
+	Move(little,SvPVX(bigstr)+offset,len,char);
+	SvSETMAGIC(bigstr);
+	return;
+}
+big = SvPVX(bigstr);
+mid = big + offset;
+midend = mid + len;
+bigend = big + SvCUR(bigstr);
+if (midend > bigend)
+	Perl_croak(aTHX_ "panic: sv_insert, midend=%p, bigend=%p",
+		   midend, bigend);
+if (mid - big > bigend - midend) {	/* faster to shorten from end */
+	if (littlelen) {
+	    Move(little, mid, littlelen,char);
+	    mid += littlelen;
+	}
+	i = bigend - midend;
+	if (i > 0) {
+	    Move(midend, mid, i,char);
+	    mid += i;
+	}
+	*mid = '\0';
+	SvCUR_set(bigstr, mid - big);
+}
+else if ((i = mid - big)) {	/* faster from front */
+	midend -= littlelen;
+	mid = midend;
+	Move(big, midend - i, i, char);
+	sv_chop(bigstr,midend-i);
+	if (littlelen)
+	    Move(little, mid, littlelen,char);
+}
+else if (littlelen) {
+	midend -= littlelen;
+	sv_chop(bigstr,midend);
+	Move(little,midend,littlelen,char);
+}
+else {
+	sv_chop(bigstr,midend);
+}
+SvSETMAGIC(bigstr);
+}
+/*
+=for apidoc sv_replace
+Make the first argument a copy of the second, then delete the original.
+The target SV physically takes over ownership of the body of the source SV
+and inherits its flags; however, the target keeps any magic it owns,
+and any magic in the source is discarded.
+Note that this is a rather specialist SV copying operation; most of the
+time you'll want to use C<sv_setsv> or one of its many macro front-ends.
+=cut
+*/
+void
+Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv)
+{
+const U32 refcnt = SvREFCNT(sv);
+PERL_ARGS_ASSERT_SV_REPLACE;
+SV_CHECK_THINKFIRST_COW_DROP(sv);
+if (SvREFCNT(nsv) != 1) {
+	Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
+		   " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
+}
+if (SvMAGICAL(sv)) {
+	if (SvMAGICAL(nsv))
+	    mg_free(nsv);
+	else
+	    sv_upgrade(nsv, SVt_PVMG);
+	SvMAGIC_set(nsv, SvMAGIC(sv));
+	SvFLAGS(nsv) |= SvMAGICAL(sv);
+	SvMAGICAL_off(sv);
+	SvMAGIC_set(sv, NULL);
+}
+SvREFCNT(sv) = 0;
+sv_clear(sv);
+assert(!SvREFCNT(sv));
+#ifdef DEBUG_LEAKING_SCALARS
+sv->sv_flags  = nsv->sv_flags;
+sv->sv_any    = nsv->sv_any;
+sv->sv_refcnt = nsv->sv_refcnt;
+sv->sv_u      = nsv->sv_u;
+#else
+StructCopy(nsv,sv,SV);
+#endif
+if(SvTYPE(sv) == SVt_IV) {
+	SET_SVANY_FOR_BODYLESS_IV(sv);
+}
+#ifdef PERL_OLD_COPY_ON_WRITE
+if (SvIsCOW_normal(nsv)) {
+	/* We need to follow the pointers around the loop to make the
+	   previous SV point to sv, rather than nsv.  */
+	SV *next;
+	SV *current = nsv;
+	while ((next = SV_COW_NEXT_SV(current)) != nsv) {
+	    assert(next);
+	    current = next;
+	    assert(SvPVX_const(current) == SvPVX_const(nsv));
+	}
+	/* Make the SV before us point to the SV after us.  */
+	if (DEBUG_C_TEST) {
+	    PerlIO_printf(Perl_debug_log, "previous is\n");
+	    sv_dump(current);
+	    PerlIO_printf(Perl_debug_log,
+"move it from 0x%"UVxf" to 0x%"UVxf"\n",
+			  (UV) SV_COW_NEXT_SV(current), (UV) sv);
+	}
+	SV_COW_NEXT_SV_SET(current, sv);
+}
+#endif
+SvREFCNT(sv) = refcnt;
+SvFLAGS(nsv) |= SVTYPEMASK;		/* Mark as freed */
+SvREFCNT(nsv) = 0;
+del_SV(nsv);
+}
+/* We're about to free a GV which has a CV that refers back to us.
+* If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
+* field) */
+STATIC void
+S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
+{
+SV *gvname;
+GV *anongv;
+PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
+/* be assertive! */
+assert(SvREFCNT(gv) == 0);
+assert(isGV(gv) && isGV_with_GP(gv));
+assert(GvGP(gv));
+assert(!CvANON(cv));
+assert(CvGV(cv) == gv);
+assert(!CvNAMED(cv));
+/* will the CV shortly be freed by gp_free() ? */
+if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
+	SvANY(cv)->xcv_gv_u.xcv_gv = NULL;
+	return;
+}
+/* if not, anonymise: */
+gvname = (GvSTASH(gv) && HvNAME(GvSTASH(gv)) && HvENAME(GvSTASH(gv)))
+? newSVhek(HvENAME_HEK(GvSTASH(gv)))
+: newSVpvn_flags( "__ANON__", 8, 0 );
+sv_catpvs(gvname, "::__ANON__");
+anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
+SvREFCNT_dec_NN(gvname);
+CvANON_on(cv);
+CvCVGV_RC_on(cv);
+SvANY(cv)->xcv_gv_u.xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
+}
+/*
+=for apidoc sv_clear
+Clear an SV: call any destructors, free up any memory used by the body,
+and free the body itself.  The SV's head is I<not> freed, although
+its type is set to all 1's so that it won't inadvertently be assumed
+to be live during global destruction etc.
+This function should only be called when REFCNT is zero.  Most of the time
+you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
+instead.
+=cut
+*/
+void
+Perl_sv_clear(pTHX_ SV *const orig_sv)
+{
+dVAR;
+HV *stash;
+U32 type;
+const struct body_details *sv_type_details;
+SV* iter_sv = NULL;
+SV* next_sv = NULL;
+SV *sv = orig_sv;
+STRLEN hash_index = 0; /* initialise to make Coverity et al happy.
+Not strictly necessary */
+PERL_ARGS_ASSERT_SV_CLEAR;
+/* within this loop, sv is the SV currently being freed, and
+* iter_sv is the most recent AV or whatever that's being iterated
+* over to provide more SVs */
+while (sv) {
+	type = SvTYPE(sv);
+	assert(SvREFCNT(sv) == 0);
+	assert(SvTYPE(sv) != (svtype)SVTYPEMASK);
+	if (type <= SVt_IV) {
+	    /* See the comment in sv.h about the collusion between this
+	     * early return and the overloading of the NULL slots in the
+	     * size table.  */
+	    if (SvROK(sv))
+		goto free_rv;
+	    SvFLAGS(sv) &= SVf_BREAK;
+	    SvFLAGS(sv) |= SVTYPEMASK;
+	    goto free_head;
+	}
+	/* objs are always >= MG, but pad names use the SVs_OBJECT flag
+	   for another purpose  */
+	assert(!SvOBJECT(sv) || type >= SVt_PVMG);
+	if (type >= SVt_PVMG) {
+	    if (SvOBJECT(sv)) {
+		if (!curse(sv, 1)) goto get_next_sv;
+		type = SvTYPE(sv); /* destructor may have changed it */
+	    }
+	    /* Free back-references before magic, in case the magic calls
+	     * Perl code that has weak references to sv. */
+	    if (type == SVt_PVHV) {
+		Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
+		if (SvMAGIC(sv))
+		    mg_free(sv);
+	    }
+	    else if (SvMAGIC(sv)) {
+		/* Free back-references before other types of magic. */
+		sv_unmagic(sv, PERL_MAGIC_backref);
+		mg_free(sv);
+	    }
+	    SvMAGICAL_off(sv);
+	}
+	switch (type) {
+	    /* case SVt_INVLIST: */
+	case SVt_PVIO:
+	    if (IoIFP(sv) &&
+		IoIFP(sv) != PerlIO_stdin() &&
+		IoIFP(sv) != PerlIO_stdout() &&
+		IoIFP(sv) != PerlIO_stderr() &&
+		!(IoFLAGS(sv) & IOf_FAKE_DIRP))
+	    {
+		io_close(MUTABLE_IO(sv), NULL, FALSE,
+			 (IoTYPE(sv) == IoTYPE_WRONLY ||
+			  IoTYPE(sv) == IoTYPE_RDWR   ||
+			  IoTYPE(sv) == IoTYPE_APPEND));
+	    }
+	    if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
+		PerlDir_close(IoDIRP(sv));
+	    IoDIRP(sv) = (DIR*)NULL;
+	    Safefree(IoTOP_NAME(sv));
+	    Safefree(IoFMT_NAME(sv));
+	    Safefree(IoBOTTOM_NAME(sv));
+	    if ((const GV *)sv == PL_statgv)
+		PL_statgv = NULL;
+	    goto freescalar;
+	case SVt_REGEXP:
+	    /* FIXME for plugins */
+	  freeregexp:
+	    pregfree2((REGEXP*) sv);
+	    goto freescalar;
+	case SVt_PVCV:
+	case SVt_PVFM:
+	    cv_undef(MUTABLE_CV(sv));
+	    /* If we're in a stash, we don't own a reference to it.
+	     * However it does have a back reference to us, which needs to
+	     * be cleared.  */
+	    if ((stash = CvSTASH(sv)))
+		sv_del_backref(MUTABLE_SV(stash), sv);
+	    goto freescalar;
+	case SVt_PVHV:
+	    if (PL_last_swash_hv == (const HV *)sv) {
+		PL_last_swash_hv = NULL;
+	    }
+	    if (HvTOTALKEYS((HV*)sv) > 0) {
+		const HEK *hek;
+		/* this statement should match the one at the beginning of
+		 * hv_undef_flags() */
+		if (   PL_phase != PERL_PHASE_DESTRUCT
+		    && (hek = HvNAME_HEK((HV*)sv)))
+		{
+		    if (PL_stashcache) {
+			DEBUG_o(Perl_deb(aTHX_
+			    "sv_clear clearing PL_stashcache for '%"HEKf
+			    "'\n",
+			     HEKfARG(hek)));
+			(void)hv_deletehek(PL_stashcache,
+hek, G_DISCARD);
+}
+		    hv_name_set((HV*)sv, NULL, 0, 0);
+		}
+		/* save old iter_sv in unused SvSTASH field */
+		assert(!SvOBJECT(sv));
+		SvSTASH(sv) = (HV*)iter_sv;
+		iter_sv = sv;
+		/* save old hash_index in unused SvMAGIC field */
+		assert(!SvMAGICAL(sv));
+		assert(!SvMAGIC(sv));
+		((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index = hash_index;
+		hash_index = 0;
+		next_sv = Perl_hfree_next_entry(aTHX_ (HV*)sv, &hash_index);
+		goto get_next_sv; /* process this new sv */
+	    }
+	    /* free empty hash */
+	    Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
+	    assert(!HvARRAY((HV*)sv));
+	    break;
+	case SVt_PVAV:
+	    {
+		AV* av = MUTABLE_AV(sv);
+		if (PL_comppad == av) {
+		    PL_comppad = NULL;
+		    PL_curpad = NULL;
+		}
+		if (AvREAL(av) && AvFILLp(av) > -1) {
+		    next_sv = AvARRAY(av)[AvFILLp(av)--];
+		    /* save old iter_sv in top-most slot of AV,
+		     * and pray that it doesn't get wiped in the meantime */
+		    AvARRAY(av)[AvMAX(av)] = iter_sv;
+		    iter_sv = sv;
+		    goto get_next_sv; /* process this new sv */
+		}
+		Safefree(AvALLOC(av));
+	    }
+	    break;
+	case SVt_PVLV:
+	    if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
+		SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
+		HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
+		PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
+	    }
+	    else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV**  */
+		SvREFCNT_dec(LvTARG(sv));
+	    if (isREGEXP(sv)) goto freeregexp;
+/* FALLTHROUGH */
+	case SVt_PVGV:
+	    if (isGV_with_GP(sv)) {
+		if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
+		   && HvENAME_get(stash))
+		    mro_method_changed_in(stash);
+		gp_free(MUTABLE_GV(sv));
+		if (GvNAME_HEK(sv))
+		    unshare_hek(GvNAME_HEK(sv));
+		/* If we're in a stash, we don't own a reference to it.
+		 * However it does have a back reference to us, which
+		 * needs to be cleared.  */
+		if (!SvVALID(sv) && (stash = GvSTASH(sv)))
+			sv_del_backref(MUTABLE_SV(stash), sv);
+	    }
+	    /* FIXME. There are probably more unreferenced pointers to SVs
+	     * in the interpreter struct that we should check and tidy in
+	     * a similar fashion to this:  */
+	    /* See also S_sv_unglob, which does the same thing. */
+	    if ((const GV *)sv == PL_last_in_gv)
+		PL_last_in_gv = NULL;
+	    else if ((const GV *)sv == PL_statgv)
+		PL_statgv = NULL;
+else if ((const GV *)sv == PL_stderrgv)
+PL_stderrgv = NULL;
+/* FALLTHROUGH */
+	case SVt_PVMG:
+	case SVt_PVNV:
+	case SVt_PVIV:
+	case SVt_INVLIST:
+	case SVt_PV:
+	  freescalar:
+	    /* Don't bother with SvOOK_off(sv); as we're only going to
+	     * free it.  */
+	    if (SvOOK(sv)) {
+		STRLEN offset;
+		SvOOK_offset(sv, offset);
+		SvPV_set(sv, SvPVX_mutable(sv) - offset);
+		/* Don't even bother with turning off the OOK flag.  */
+	    }
+	    if (SvROK(sv)) {
+	    free_rv:
+		{
+		    SV * const target = SvRV(sv);
+		    if (SvWEAKREF(sv))
+			sv_del_backref(target, sv);
+		    else
+			next_sv = target;
+		}
+	    }
+#ifdef PERL_ANY_COW
+	    else if (SvPVX_const(sv)
+		     && !(SvTYPE(sv) == SVt_PVIO
+		     && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
+	    {
+		if (SvIsCOW(sv)) {
+		    if (DEBUG_C_TEST) {
+			PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
+			sv_dump(sv);
+		    }
+		    if (SvLEN(sv)) {
+# ifdef PERL_OLD_COPY_ON_WRITE
+			sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
+# else
+			if (CowREFCNT(sv)) {
+			    sv_buf_to_rw(sv);
+			    CowREFCNT(sv)--;
+			    sv_buf_to_ro(sv);
+			    SvLEN_set(sv, 0);
+			}
+# endif
+		    } else {
+			unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
+		    }
+		}
+# ifdef PERL_OLD_COPY_ON_WRITE
+		else
+# endif
+		if (SvLEN(sv)) {
+		    Safefree(SvPVX_mutable(sv));
+		}
+	    }
+#else
+	    else if (SvPVX_const(sv) && SvLEN(sv)
+		     && !(SvTYPE(sv) == SVt_PVIO
+		     && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
+		Safefree(SvPVX_mutable(sv));
+	    else if (SvPVX_const(sv) && SvIsCOW(sv)) {
+		unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
+	    }
+#endif
+	    break;
+	case SVt_NV:
+	    break;
+	}
+free_body:
+	SvFLAGS(sv) &= SVf_BREAK;
+	SvFLAGS(sv) |= SVTYPEMASK;
+	sv_type_details = bodies_by_type + type;
+	if (sv_type_details->arena) {
+	    del_body(((char *)SvANY(sv) + sv_type_details->offset),
+		     &PL_body_roots[type]);
+	}
+	else if (sv_type_details->body_size) {
+	    safefree(SvANY(sv));
+	}
+free_head:
+	/* caller is responsible for freeing the head of the original sv */
+	if (sv != orig_sv && !SvREFCNT(sv))
+	    del_SV(sv);
+	/* grab and free next sv, if any */
+get_next_sv:
+	while (1) {
+	    sv = NULL;
+	    if (next_sv) {
+		sv = next_sv;
+		next_sv = NULL;
+	    }
+	    else if (!iter_sv) {
+		break;
+	    } else if (SvTYPE(iter_sv) == SVt_PVAV) {
+		AV *const av = (AV*)iter_sv;
+		if (AvFILLp(av) > -1) {
+		    sv = AvARRAY(av)[AvFILLp(av)--];
+		}
+		else { /* no more elements of current AV to free */
+		    sv = iter_sv;
+		    type = SvTYPE(sv);
+		    /* restore previous value, squirrelled away */
+		    iter_sv = AvARRAY(av)[AvMAX(av)];
+		    Safefree(AvALLOC(av));
+		    goto free_body;
+		}
+	    } else if (SvTYPE(iter_sv) == SVt_PVHV) {
+		sv = Perl_hfree_next_entry(aTHX_ (HV*)iter_sv, &hash_index);
+		if (!sv && !HvTOTALKEYS((HV *)iter_sv)) {
+		    /* no more elements of current HV to free */
+		    sv = iter_sv;
+		    type = SvTYPE(sv);
+		    /* Restore previous values of iter_sv and hash_index,
+		     * squirrelled away */
+		    assert(!SvOBJECT(sv));
+		    iter_sv = (SV*)SvSTASH(sv);
+		    assert(!SvMAGICAL(sv));
+		    hash_index = ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index;
+#ifdef DEBUGGING
+		    /* perl -DA does not like rubbish in SvMAGIC. */
+		    SvMAGIC_set(sv, 0);
+#endif
+		    /* free any remaining detritus from the hash struct */
+		    Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
+		    assert(!HvARRAY((HV*)sv));
+		    goto free_body;
+		}
+	    }
+	    /* unrolled SvREFCNT_dec and sv_free2 follows: */
+	    if (!sv)
+		continue;
+	    if (!SvREFCNT(sv)) {
+		sv_free(sv);
+		continue;
+	    }
+	    if (--(SvREFCNT(sv)))
+		continue;
+#ifdef DEBUGGING
+	    if (SvTEMP(sv)) {
+		Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
+			 "Attempt to free temp prematurely: SV 0x%"UVxf
+			 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
+		continue;
+	    }
+#endif
+	    if (SvIMMORTAL(sv)) {
+		/* make sure SvREFCNT(sv)==0 happens very seldom */
+		SvREFCNT(sv) = SvREFCNT_IMMORTAL;
+		continue;
+	    }
+	    break;
+	} /* while 1 */
+} /* while sv */
+}
+/* This routine curses the sv itself, not the object referenced by sv. So
+sv does not have to be ROK. */
+static bool
+S_curse(pTHX_ SV * const sv, const bool check_refcnt) {
+PERL_ARGS_ASSERT_CURSE;
+assert(SvOBJECT(sv));
+if (PL_defstash &&	/* Still have a symbol table? */
+	SvDESTROYABLE(sv))
+{
+	dSP;
+	HV* stash;
+	do {
+	  stash = SvSTASH(sv);
+	  assert(SvTYPE(stash) == SVt_PVHV);
+	  if (HvNAME(stash)) {
+	    CV* destructor = NULL;
+	    assert (SvOOK(stash));
+	    if (!SvOBJECT(stash)) destructor = (CV *)SvSTASH(stash);
+	    if (!destructor || HvMROMETA(stash)->destroy_gen
+				!= PL_sub_generation)
+	    {
+		GV * const gv =
+		    gv_fetchmeth_autoload(stash, "DESTROY", 7, 0);
+		if (gv) destructor = GvCV(gv);
+		if (!SvOBJECT(stash))
+		{
+		    SvSTASH(stash) =
+			destructor ? (HV *)destructor : ((HV *)0)+1;
+		    HvAUX(stash)->xhv_mro_meta->destroy_gen =
+			PL_sub_generation;
+		}
+	    }
+	    assert(!destructor || destructor == ((CV *)0)+1
+		|| SvTYPE(destructor) == SVt_PVCV);
+	    if (destructor && destructor != ((CV *)0)+1
+		/* A constant subroutine can have no side effects, so
+		   don't bother calling it.  */
+		&& !CvCONST(destructor)
+		/* Don't bother calling an empty destructor or one that
+		   returns immediately. */
+		&& (CvISXSUB(destructor)
+		|| (CvSTART(destructor)
+		    && (CvSTART(destructor)->op_next->op_type
+					!= OP_LEAVESUB)
+		    && (CvSTART(destructor)->op_next->op_type
+					!= OP_PUSHMARK
+			|| CvSTART(destructor)->op_next->op_next->op_type
+					!= OP_RETURN
+		       )
+		   ))
+	       )
+	    {
+		SV* const tmpref = newRV(sv);
+		SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
+		ENTER;
+		PUSHSTACKi(PERLSI_DESTROY);
+		EXTEND(SP, 2);
+		PUSHMARK(SP);
+		PUSHs(tmpref);
+		PUTBACK;
+		call_sv(MUTABLE_SV(destructor),
+			    G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
+		POPSTACK;
+		SPAGAIN;
+		LEAVE;
+		if(SvREFCNT(tmpref) < 2) {
+		    /* tmpref is not kept alive! */
+		    SvREFCNT(sv)--;
+		    SvRV_set(tmpref, NULL);
+		    SvROK_off(tmpref);
+		}
+		SvREFCNT_dec_NN(tmpref);
+	    }
+	  }
+	} while (SvOBJECT(sv) && SvSTASH(sv) != stash);
+	if (check_refcnt && SvREFCNT(sv)) {
+	    if (PL_in_clean_objs)
+		Perl_croak(aTHX_
+		  "DESTROY created new reference to dead object '%"HEKf"'",
+		   HEKfARG(HvNAME_HEK(stash)));
+	    /* DESTROY gave object new lease on life */
+	    return FALSE;
+	}
+}
+if (SvOBJECT(sv)) {
+	HV * const stash = SvSTASH(sv);
+	/* Curse before freeing the stash, as freeing the stash could cause
+	   a recursive call into S_curse. */
+	SvOBJECT_off(sv);	/* Curse the object. */
+	SvSTASH_set(sv,0);	/* SvREFCNT_dec may try to read this */
+	SvREFCNT_dec(stash); /* possibly of changed persuasion */
+}
+return TRUE;
+}
+/*
+=for apidoc sv_newref
+Increment an SV's reference count.  Use the C<SvREFCNT_inc()> wrapper
+instead.
+=cut
+*/
+SV *
+Perl_sv_newref(pTHX_ SV *const sv)
+{
+PERL_UNUSED_CONTEXT;
+if (sv)
+	(SvREFCNT(sv))++;
+return sv;
+}
+/*
+=for apidoc sv_free
+Decrement an SV's reference count, and if it drops to zero, call
+C<sv_clear> to invoke destructors and free up any memory used by
+the body; finally, deallocate the SV's head itself.
+Normally called via a wrapper macro C<SvREFCNT_dec>.
+=cut
+*/
+void
+Perl_sv_free(pTHX_ SV *const sv)
+{
+SvREFCNT_dec(sv);
+}
+/* Private helper function for SvREFCNT_dec().
+* Called with rc set to original SvREFCNT(sv), where rc == 0 or 1 */
+void
+Perl_sv_free2(pTHX_ SV *const sv, const U32 rc)
+{
+dVAR;
+PERL_ARGS_ASSERT_SV_FREE2;
+if (LIKELY( rc == 1 )) {
+/* normal case */
+SvREFCNT(sv) = 0;
+#ifdef DEBUGGING
+if (SvTEMP(sv)) {
+Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
+"Attempt to free temp prematurely: SV 0x%"UVxf
+pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
+return;
+}
+#endif
+if (SvIMMORTAL(sv)) {
+/* make sure SvREFCNT(sv)==0 happens very seldom */
+SvREFCNT(sv) = SvREFCNT_IMMORTAL;
+return;
+}
+sv_clear(sv);
+if (! SvREFCNT(sv)) /* may have have been resurrected */
+del_SV(sv);
+return;
+}
+/* handle exceptional cases */
+assert(rc == 0);
+if (SvFLAGS(sv) & SVf_BREAK)
+/* this SV's refcnt has been artificially decremented to
+* trigger cleanup */
+return;
+if (PL_in_clean_all) /* All is fair */
+return;
+if (SvIMMORTAL(sv)) {
+/* make sure SvREFCNT(sv)==0 happens very seldom */
+SvREFCNT(sv) = SvREFCNT_IMMORTAL;
+return;
+}
+if (ckWARN_d(WARN_INTERNAL)) {
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+Perl_dump_sv_child(aTHX_ sv);
+#else
+#ifdef DEBUG_LEAKING_SCALARS
+sv_dump(sv);
+#endif
+#ifdef DEBUG_LEAKING_SCALARS_ABORT
+if (PL_warnhook == PERL_WARNHOOK_FATAL
+|| ckDEAD(packWARN(WARN_INTERNAL))) {
+/* Don't let Perl_warner cause us to escape our fate:  */
+abort();
+}
+#endif
+/* This may not return:  */
+Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
+"Attempt to free unreferenced scalar: SV 0x%"UVxf
+pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
+#endif
+}
+#ifdef DEBUG_LEAKING_SCALARS_ABORT
+abort();
+#endif
+}
+/*
+=for apidoc sv_len
+Returns the length of the string in the SV.  Handles magic and type
+coercion and sets the UTF8 flag appropriately.  See also C<SvCUR>, which
+gives raw access to the xpv_cur slot.
+=cut
+*/
+STRLEN
+Perl_sv_len(pTHX_ SV *const sv)
+{
+STRLEN len;
+if (!sv)
+	return 0;
+(void)SvPV_const(sv, len);
+return len;
+}
+/*
+=for apidoc sv_len_utf8
+Returns the number of characters in the string in an SV, counting wide
+UTF-8 bytes as a single character.  Handles magic and type coercion.
+=cut
+*/
+/*
+* The length is cached in PERL_MAGIC_utf8, in the mg_len field.  Also the
+* mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
+* (Note that the mg_len is not the length of the mg_ptr field.
+* This allows the cache to store the character length of the string without
+* needing to malloc() extra storage to attach to the mg_ptr.)
+*
+*/
+STRLEN
+Perl_sv_len_utf8(pTHX_ SV *const sv)
+{
+if (!sv)
+	return 0;
+SvGETMAGIC(sv);
+return sv_len_utf8_nomg(sv);
+}
+STRLEN
+Perl_sv_len_utf8_nomg(pTHX_ SV * const sv)
+{
+STRLEN len;
+const U8 *s = (U8*)SvPV_nomg_const(sv, len);
+PERL_ARGS_ASSERT_SV_LEN_UTF8_NOMG;
+if (PL_utf8cache && SvUTF8(sv)) {
+	    STRLEN ulen;
+	    MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
+	    if (mg && (mg->mg_len != -1 || mg->mg_ptr)) {
+		if (mg->mg_len != -1)
+		    ulen = mg->mg_len;
+		else {
+		    /* We can use the offset cache for a headstart.
+		       The longer value is stored in the first pair.  */
+		    STRLEN *cache = (STRLEN *) mg->mg_ptr;
+		    ulen = cache[0] + Perl_utf8_length(aTHX_ s + cache[1],
+						       s + len);
+		}
+		if (PL_utf8cache < 0) {
+		    const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
+		    assert_uft8_cache_coherent("sv_len_utf8", ulen, real, sv);
+		}
+	    }
+	    else {
+		ulen = Perl_utf8_length(aTHX_ s, s + len);
+		utf8_mg_len_cache_update(sv, &mg, ulen);
+	    }
+	    return ulen;
+}
+return SvUTF8(sv) ? Perl_utf8_length(aTHX_ s, s + len) : len;
+}
+/* Walk forwards to find the byte corresponding to the passed in UTF-8
+offset.  */
+static STRLEN
+S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
+		      STRLEN *const uoffset_p, bool *const at_end)
+{
+const U8 *s = start;
+STRLEN uoffset = *uoffset_p;
+PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
+while (s < send && uoffset) {
+	--uoffset;
+	s += UTF8SKIP(s);
+}
+if (s == send) {
+	*at_end = TRUE;
+}
+else if (s > send) {
+	*at_end = TRUE;
+	/* This is the existing behaviour. Possibly it should be a croak, as
+	   it's actually a bounds error  */
+	s = send;
+}
+*uoffset_p -= uoffset;
+return s - start;
+}
+/* Given the length of the string in both bytes and UTF-8 characters, decide
+whether to walk forwards or backwards to find the byte corresponding to
+the passed in UTF-8 offset.  */
+static STRLEN
+S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
+		    STRLEN uoffset, const STRLEN uend)
+{
+STRLEN backw = uend - uoffset;
+PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
+if (uoffset < 2 * backw) {
+	/* The assumption is that going forwards is twice the speed of going
+	   forward (that's where the 2 * backw comes from).
+	   (The real figure of course depends on the UTF-8 data.)  */
+	const U8 *s = start;
+	while (s < send && uoffset--)
+	    s += UTF8SKIP(s);
+	assert (s <= send);
+	if (s > send)
+	    s = send;
+	return s - start;
+}
+while (backw--) {
+	send--;
+	while (UTF8_IS_CONTINUATION(*send))
+	    send--;
+}
+return send - start;
+}
+/* For the string representation of the given scalar, find the byte
+corresponding to the passed in UTF-8 offset.  uoffset0 and boffset0
+give another position in the string, *before* the sought offset, which
+(which is always true, as 0, 0 is a valid pair of positions), which should
+help reduce the amount of linear searching.
+If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
+will be used to reduce the amount of linear searching. The cache will be
+created if necessary, and the found value offered to it for update.  */
+static STRLEN
+S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
+		    const U8 *const send, STRLEN uoffset,
+		    STRLEN uoffset0, STRLEN boffset0)
+{
+STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy.  */
+bool found = FALSE;
+bool at_end = FALSE;
+PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
+assert (uoffset >= uoffset0);
+if (!uoffset)
+	return 0;
+if (!SvREADONLY(sv) && !SvGMAGICAL(sv) && SvPOK(sv)
+	&& PL_utf8cache
+	&& (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
+		     (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) {
+	if ((*mgp)->mg_ptr) {
+	    STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
+	    if (cache[0] == uoffset) {
+		/* An exact match. */
+		return cache[1];
+	    }
+	    if (cache[2] == uoffset) {
+		/* An exact match. */
+		return cache[3];
+	    }
+	    if (cache[0] < uoffset) {
+		/* The cache already knows part of the way.   */
+		if (cache[0] > uoffset0) {
+		    /* The cache knows more than the passed in pair  */
+		    uoffset0 = cache[0];
+		    boffset0 = cache[1];
+		}
+		if ((*mgp)->mg_len != -1) {
+		    /* And we know the end too.  */
+		    boffset = boffset0
+			+ sv_pos_u2b_midway(start + boffset0, send,
+					      uoffset - uoffset0,
+					      (*mgp)->mg_len - uoffset0);
+		} else {
+		    uoffset -= uoffset0;
+		    boffset = boffset0
+			+ sv_pos_u2b_forwards(start + boffset0,
+					      send, &uoffset, &at_end);
+		    uoffset += uoffset0;
+		}
+	    }
+	    else if (cache[2] < uoffset) {
+		/* We're between the two cache entries.  */
+		if (cache[2] > uoffset0) {
+		    /* and the cache knows more than the passed in pair  */
+		    uoffset0 = cache[2];
+		    boffset0 = cache[3];
+		}
+		boffset = boffset0
+		    + sv_pos_u2b_midway(start + boffset0,
+					  start + cache[1],
+					  uoffset - uoffset0,
+					  cache[0] - uoffset0);
+	    } else {
+		boffset = boffset0
+		    + sv_pos_u2b_midway(start + boffset0,
+					  start + cache[3],
+					  uoffset - uoffset0,
+					  cache[2] - uoffset0);
+	    }
+	    found = TRUE;
+	}
+	else if ((*mgp)->mg_len != -1) {
+	    /* If we can take advantage of a passed in offset, do so.  */
+	    /* In fact, offset0 is either 0, or less than offset, so don't
+	       need to worry about the other possibility.  */
+	    boffset = boffset0
+		+ sv_pos_u2b_midway(start + boffset0, send,
+				      uoffset - uoffset0,
+				      (*mgp)->mg_len - uoffset0);
+	    found = TRUE;
+	}
+}
+if (!found || PL_utf8cache < 0) {
+	STRLEN real_boffset;
+	uoffset -= uoffset0;
+	real_boffset = boffset0 + sv_pos_u2b_forwards(start + boffset0,
+						      send, &uoffset, &at_end);
+	uoffset += uoffset0;
+	if (found && PL_utf8cache < 0)
+	    assert_uft8_cache_coherent("sv_pos_u2b_cache", boffset,
+				       real_boffset, sv);
+	boffset = real_boffset;
+}
+if (PL_utf8cache && !SvGMAGICAL(sv) && SvPOK(sv)) {
+	if (at_end)
+	    utf8_mg_len_cache_update(sv, mgp, uoffset);
+	else
+	    utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
+}
+return boffset;
+}
+/*
+=for apidoc sv_pos_u2b_flags
+Converts the offset from a count of UTF-8 chars from
+the start of the string, to a count of the equivalent number of bytes; if
+lenp is non-zero, it does the same to lenp, but this time starting from
+the offset, rather than from the start
+of the string.  Handles type coercion.
+I<flags> is passed to C<SvPV_flags>, and usually should be
+C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
+=cut
+*/
+/*
+* sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential
+* PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
+* byte offsets.  See also the comments of S_utf8_mg_pos_cache_update().
+*
+*/
+STRLEN
+Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp,
+		      U32 flags)
+{
+const U8 *start;
+STRLEN len;
+STRLEN boffset;
+PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS;
+start = (U8*)SvPV_flags(sv, len, flags);
+if (len) {
+	const U8 * const send = start + len;
+	MAGIC *mg = NULL;
+	boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
+	if (lenp
+	    && *lenp /* don't bother doing work for 0, as its bytes equivalent
+			is 0, and *lenp is already set to that.  */) {
+	    /* Convert the relative offset to absolute.  */
+	    const STRLEN uoffset2 = uoffset + *lenp;
+	    const STRLEN boffset2
+		= sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
+				      uoffset, boffset) - boffset;
+	    *lenp = boffset2;
+	}
+} else {
+	if (lenp)
+	    *lenp = 0;
+	boffset = 0;
+}
+return boffset;
+}
+/*
+=for apidoc sv_pos_u2b
+Converts the value pointed to by offsetp from a count of UTF-8 chars from
+the start of the string, to a count of the equivalent number of bytes; if
+lenp is non-zero, it does the same to lenp, but this time starting from
+the offset, rather than from the start of the string.  Handles magic and
+type coercion.
+Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer
+than 2Gb.
+=cut
+*/
+/*
+* sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
+* PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
+* byte offsets.  See also the comments of S_utf8_mg_pos_cache_update().
+*
+*/
+/* This function is subject to size and sign problems */
+void
+Perl_sv_pos_u2b(pTHX_ SV *const sv, I32 *const offsetp, I32 *const lenp)
+{
+PERL_ARGS_ASSERT_SV_POS_U2B;
+if (lenp) {
+	STRLEN ulen = (STRLEN)*lenp;
+	*offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen,
+					 SV_GMAGIC|SV_CONST_RETURN);
+	*lenp = (I32)ulen;
+} else {
+	*offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL,
+					 SV_GMAGIC|SV_CONST_RETURN);
+}
+}
+static void
+S_utf8_mg_len_cache_update(pTHX_ SV *const sv, MAGIC **const mgp,
+			   const STRLEN ulen)
+{
+PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE;
+if (SvREADONLY(sv) || SvGMAGICAL(sv) || !SvPOK(sv))
+	return;
+if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
+		  !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
+	*mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
+}
+assert(*mgp);
+(*mgp)->mg_len = ulen;
+}
+/* Create and update the UTF8 magic offset cache, with the proffered utf8/
+byte length pairing. The (byte) length of the total SV is passed in too,
+as blen, because for some (more esoteric) SVs, the call to SvPV_const()
+may not have updated SvCUR, so we can't rely on reading it directly.
+The proffered utf8/byte length pairing isn't used if the cache already has
+two pairs, and swapping either for the proffered pair would increase the
+RMS of the intervals between known byte offsets.
+The cache itself consists of 4 STRLEN values
+0: larger UTF-8 offset
+1: corresponding byte offset
+2: smaller UTF-8 offset
+3: corresponding byte offset
+Unused cache pairs have the value 0, 0.
+Keeping the cache "backwards" means that the invariant of
+cache[0] >= cache[2] is maintained even with empty slots, which means that
+the code that uses it doesn't need to worry if only 1 entry has actually
+been set to non-zero.  It also makes the "position beyond the end of the
+cache" logic much simpler, as the first slot is always the one to start
+from.
+*/
+static void
+S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
+const STRLEN utf8, const STRLEN blen)
+{
+STRLEN *cache;
+PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
+if (SvREADONLY(sv))
+	return;
+if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
+		  !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
+	*mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
+			   0);
+	(*mgp)->mg_len = -1;
+}
+assert(*mgp);
+if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
+	Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
+	(*mgp)->mg_ptr = (char *) cache;
+}
+assert(cache);
+if (PL_utf8cache < 0 && SvPOKp(sv)) {
+	/* SvPOKp() because, if sv is a reference, then SvPVX() is actually
+	   a pointer.  Note that we no longer cache utf8 offsets on refer-
+	   ences, but this check is still a good idea, for robustness.  */
+	const U8 *start = (const U8 *) SvPVX_const(sv);
+	const STRLEN realutf8 = utf8_length(start, start + byte);
+	assert_uft8_cache_coherent("utf8_mg_pos_cache_update", utf8, realutf8,
+				   sv);
+}
+/* Cache is held with the later position first, to simplify the code
+that deals with unbounded ends.  */
+ASSERT_UTF8_CACHE(cache);
+if (cache[1] == 0) {
+	/* Cache is totally empty  */
+	cache[0] = utf8;
+	cache[1] = byte;
+} else if (cache[3] == 0) {
+	if (byte > cache[1]) {
+	    /* New one is larger, so goes first.  */
+	    cache[2] = cache[0];
+	    cache[3] = cache[1];
+	    cache[0] = utf8;
+	    cache[1] = byte;
+	} else {
+	    cache[2] = utf8;
+	    cache[3] = byte;
+	}
+} else {
+/* float casts necessary? XXX */
+#define THREEWAY_SQUARE(a,b,c,d) \
+	    ((float)((d) - (c))) * ((float)((d) - (c))) \
+	    + ((float)((c) - (b))) * ((float)((c) - (b))) \
+	       + ((float)((b) - (a))) * ((float)((b) - (a)))
+	/* Cache has 2 slots in use, and we know three potential pairs.
+	   Keep the two that give the lowest RMS distance. Do the
+	   calculation in bytes simply because we always know the byte
+	   length.  squareroot has the same ordering as the positive value,
+	   so don't bother with the actual square root.  */
+	if (byte > cache[1]) {
+	    /* New position is after the existing pair of pairs.  */
+	    const float keep_earlier
+		= THREEWAY_SQUARE(0, cache[3], byte, blen);
+	    const float keep_later
+		= THREEWAY_SQUARE(0, cache[1], byte, blen);
+	    if (keep_later < keep_earlier) {
+cache[2] = cache[0];
+cache[3] = cache[1];
+	    }
+cache[0] = utf8;
+cache[1] = byte;
+	}
+	else {
+	    const float keep_later = THREEWAY_SQUARE(0, byte, cache[1], blen);
+	    float b, c, keep_earlier;
+	    if (byte > cache[3]) {
+		/* New position is between the existing pair of pairs.  */
+		b = (float)cache[3];
+		c = (float)byte;
+	    } else {
+		/* New position is before the existing pair of pairs.  */
+		b = (float)byte;
+		c = (float)cache[3];
+	    }
+	    keep_earlier = THREEWAY_SQUARE(0, b, c, blen);
+	    if (byte > cache[3]) {
+		if (keep_later < keep_earlier) {
+		    cache[2] = utf8;
+		    cache[3] = byte;
+		}
+		else {
+		    cache[0] = utf8;
+		    cache[1] = byte;
+		}
+	    }
+	    else {
+		if (! (keep_later < keep_earlier)) {
+		    cache[0] = cache[2];
+		    cache[1] = cache[3];
+		}
+		cache[2] = utf8;
+		cache[3] = byte;
+	    }
+	}
+}
+ASSERT_UTF8_CACHE(cache);
+}
+/* We already know all of the way, now we may be able to walk back.  The same
+assumption is made as in S_sv_pos_u2b_midway(), namely that walking
+backward is half the speed of walking forward. */
+static STRLEN
+S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
+const U8 *end, STRLEN endu)
+{
+const STRLEN forw = target - s;
+STRLEN backw = end - target;
+PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
+if (forw < 2 * backw) {
+	return utf8_length(s, target);
+}
+while (end > target) {
+	end--;
+	while (UTF8_IS_CONTINUATION(*end)) {
+	    end--;
+	}
+	endu--;
+}
+return endu;
+}
+/*
+=for apidoc sv_pos_b2u_flags
+Converts the offset from a count of bytes from the start of the string, to
+a count of the equivalent number of UTF-8 chars.  Handles type coercion.
+I<flags> is passed to C<SvPV_flags>, and usually should be
+C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
+=cut
+*/
+/*
+* sv_pos_b2u_flags() uses, like sv_pos_u2b_flags(), the mg_ptr of the
+* potential PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8
+* and byte offsets.
+*
+*/
+STRLEN
+Perl_sv_pos_b2u_flags(pTHX_ SV *const sv, STRLEN const offset, U32 flags)
+{
+const U8* s;
+STRLEN len = 0; /* Actually always set, but let's keep gcc happy.  */
+STRLEN blen;
+MAGIC* mg = NULL;
+const U8* send;
+bool found = FALSE;
+PERL_ARGS_ASSERT_SV_POS_B2U_FLAGS;
+s = (const U8*)SvPV_flags(sv, blen, flags);
+if (blen < offset)
+	Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset, blen=%"UVuf
+		   ", byte=%"UVuf, (UV)blen, (UV)offset);
+send = s + offset;
+if (!SvREADONLY(sv)
+	&& PL_utf8cache
+	&& SvTYPE(sv) >= SVt_PVMG
+	&& (mg = mg_find(sv, PERL_MAGIC_utf8)))
+{
+	if (mg->mg_ptr) {
+	    STRLEN * const cache = (STRLEN *) mg->mg_ptr;
+	    if (cache[1] == offset) {
+		/* An exact match. */
+		return cache[0];
+	    }
+	    if (cache[3] == offset) {
+		/* An exact match. */
+		return cache[2];
+	    }
+	    if (cache[1] < offset) {
+		/* We already know part of the way. */
+		if (mg->mg_len != -1) {
+		    /* Actually, we know the end too.  */
+		    len = cache[0]
+			+ S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
+					      s + blen, mg->mg_len - cache[0]);
+		} else {
+		    len = cache[0] + utf8_length(s + cache[1], send);
+		}
+	    }
+	    else if (cache[3] < offset) {
+		/* We're between the two cached pairs, so we do the calculation
+		   offset by the byte/utf-8 positions for the earlier pair,
+		   then add the utf-8 characters from the string start to
+		   there.  */
+		len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
+					  s + cache[1], cache[0] - cache[2])
+		    + cache[2];
+	    }
+	    else { /* cache[3] > offset */
+		len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
+					  cache[2]);
+	    }
+	    ASSERT_UTF8_CACHE(cache);
+	    found = TRUE;
+	} else if (mg->mg_len != -1) {
+	    len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
+	    found = TRUE;
+	}
+}
+if (!found || PL_utf8cache < 0) {
+	const STRLEN real_len = utf8_length(s, send);
+	if (found && PL_utf8cache < 0)
+	    assert_uft8_cache_coherent("sv_pos_b2u", len, real_len, sv);
+	len = real_len;
+}
+if (PL_utf8cache) {
+	if (blen == offset)
+	    utf8_mg_len_cache_update(sv, &mg, len);
+	else
+	    utf8_mg_pos_cache_update(sv, &mg, offset, len, blen);
+}
+return len;
+}
+/*
+=for apidoc sv_pos_b2u
+Converts the value pointed to by offsetp from a count of bytes from the
+start of the string, to a count of the equivalent number of UTF-8 chars.
+Handles magic and type coercion.
+Use C<sv_pos_b2u_flags> in preference, which correctly handles strings
+longer than 2Gb.
+=cut
+*/
+/*
+* sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
+* PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
+* byte offsets.
+*
+*/
+void
+Perl_sv_pos_b2u(pTHX_ SV *const sv, I32 *const offsetp)
+{
+PERL_ARGS_ASSERT_SV_POS_B2U;
+if (!sv)
+	return;
+*offsetp = (I32)sv_pos_b2u_flags(sv, (STRLEN)*offsetp,
+				     SV_GMAGIC|SV_CONST_RETURN);
+}
+static void
+S_assert_uft8_cache_coherent(pTHX_ const char *const func, STRLEN from_cache,
+			     STRLEN real, SV *const sv)
+{
+PERL_ARGS_ASSERT_ASSERT_UFT8_CACHE_COHERENT;
+/* As this is debugging only code, save space by keeping this test here,
+rather than inlining it in all the callers.  */
+if (from_cache == real)
+	return;
+/* Need to turn the assertions off otherwise we may recurse infinitely
+while printing error messages.  */
+SAVEI8(PL_utf8cache);
+PL_utf8cache = 0;
+Perl_croak(aTHX_ "panic: %s cache %"UVuf" real %"UVuf" for %"SVf,
+	       func, (UV) from_cache, (UV) real, SVfARG(sv));
+}
+/*
+=for apidoc sv_eq
+Returns a boolean indicating whether the strings in the two SVs are
+identical.  Is UTF-8 and 'use bytes' aware, handles get magic, and will
+coerce its args to strings if necessary.
+=for apidoc sv_eq_flags
+Returns a boolean indicating whether the strings in the two SVs are
+identical.  Is UTF-8 and 'use bytes' aware and coerces its args to strings
+if necessary.  If the flags include SV_GMAGIC, it handles get-magic, too.
+=cut
+*/
+I32
+Perl_sv_eq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags)
+{
+const char *pv1;
+STRLEN cur1;
+const char *pv2;
+STRLEN cur2;
+I32  eq     = 0;
+SV* svrecode = NULL;
+if (!sv1) {
+	pv1 = "";
+	cur1 = 0;
+}
+else {
+	/* if pv1 and pv2 are the same, second SvPV_const call may
+	 * invalidate pv1 (if we are handling magic), so we may need to
+	 * make a copy */
+	if (sv1 == sv2 && flags & SV_GMAGIC
+	 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
+	    pv1 = SvPV_const(sv1, cur1);
+	    sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
+	}
+	pv1 = SvPV_flags_const(sv1, cur1, flags);
+}
+if (!sv2){
+	pv2 = "";
+	cur2 = 0;
+}
+else
+	pv2 = SvPV_flags_const(sv2, cur2, flags);
+if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
+/* Differing utf8ness.
+	 * Do not UTF8size the comparands as a side-effect. */
+	 if (IN_ENCODING) {
+	      if (SvUTF8(sv1)) {
+		   svrecode = newSVpvn(pv2, cur2);
+		   sv_recode_to_utf8(svrecode, _get_encoding());
+		   pv2 = SvPV_const(svrecode, cur2);
+	      }
+	      else {
+		   svrecode = newSVpvn(pv1, cur1);
+		   sv_recode_to_utf8(svrecode, _get_encoding());
+		   pv1 = SvPV_const(svrecode, cur1);
+	      }
+	      /* Now both are in UTF-8. */
+	      if (cur1 != cur2) {
+		   SvREFCNT_dec_NN(svrecode);
+		   return FALSE;
+	      }
+	 }
+	 else {
+	      if (SvUTF8(sv1)) {
+		  /* sv1 is the UTF-8 one  */
+		  return bytes_cmp_utf8((const U8*)pv2, cur2,
+					(const U8*)pv1, cur1) == 0;
+	      }
+	      else {
+		  /* sv2 is the UTF-8 one  */
+		  return bytes_cmp_utf8((const U8*)pv1, cur1,
+					(const U8*)pv2, cur2) == 0;
+	      }
+	 }
+}
+if (cur1 == cur2)
+	eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
+SvREFCNT_dec(svrecode);
+return eq;
+}
+/*
+=for apidoc sv_cmp
+Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
+string in C<sv1> is less than, equal to, or greater than the string in
+C<sv2>.  Is UTF-8 and 'use bytes' aware, handles get magic, and will
+coerce its args to strings if necessary.  See also C<sv_cmp_locale>.
+=for apidoc sv_cmp_flags
+Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
+string in C<sv1> is less than, equal to, or greater than the string in
+C<sv2>.  Is UTF-8 and 'use bytes' aware and will coerce its args to strings
+if necessary.  If the flags include SV_GMAGIC, it handles get magic.  See
+also C<sv_cmp_locale_flags>.
+=cut
+*/
+I32
+Perl_sv_cmp(pTHX_ SV *const sv1, SV *const sv2)
+{
+return sv_cmp_flags(sv1, sv2, SV_GMAGIC);
+}
+I32
+Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2,
+		  const U32 flags)
+{
+STRLEN cur1, cur2;
+const char *pv1, *pv2;
+I32  cmp;
+SV *svrecode = NULL;
+if (!sv1) {
+	pv1 = "";
+	cur1 = 0;
+}
+else
+	pv1 = SvPV_flags_const(sv1, cur1, flags);
+if (!sv2) {
+	pv2 = "";
+	cur2 = 0;
+}
+else
+	pv2 = SvPV_flags_const(sv2, cur2, flags);
+if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
+/* Differing utf8ness.
+	 * Do not UTF8size the comparands as a side-effect. */
+	if (SvUTF8(sv1)) {
+	    if (IN_ENCODING) {
+		 svrecode = newSVpvn(pv2, cur2);
+		 sv_recode_to_utf8(svrecode, _get_encoding());
+		 pv2 = SvPV_const(svrecode, cur2);
+	    }
+	    else {
+		const int retval = -bytes_cmp_utf8((const U8*)pv2, cur2,
+						   (const U8*)pv1, cur1);
+		return retval ? retval < 0 ? -1 : +1 : 0;
+	    }
+	}
+	else {
+	    if (IN_ENCODING) {
+		 svrecode = newSVpvn(pv1, cur1);
+		 sv_recode_to_utf8(svrecode, _get_encoding());
+		 pv1 = SvPV_const(svrecode, cur1);
+	    }
+	    else {
+		const int retval = bytes_cmp_utf8((const U8*)pv1, cur1,
+						  (const U8*)pv2, cur2);
+		return retval ? retval < 0 ? -1 : +1 : 0;
+	    }
+	}
+}
+if (!cur1) {
+	cmp = cur2 ? -1 : 0;
+} else if (!cur2) {
+	cmp = 1;
+} else {
+const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
+	if (retval) {
+	    cmp = retval < 0 ? -1 : 1;
+	} else if (cur1 == cur2) {
+	    cmp = 0;
+} else {
+	    cmp = cur1 < cur2 ? -1 : 1;
+	}
+}
+SvREFCNT_dec(svrecode);
+return cmp;
+}
+/*
+=for apidoc sv_cmp_locale
+Compares the strings in two SVs in a locale-aware manner.  Is UTF-8 and
+'use bytes' aware, handles get magic, and will coerce its args to strings
+if necessary.  See also C<sv_cmp>.
+=for apidoc sv_cmp_locale_flags
+Compares the strings in two SVs in a locale-aware manner.  Is UTF-8 and
+'use bytes' aware and will coerce its args to strings if necessary.  If the
+flags contain SV_GMAGIC, it handles get magic.  See also C<sv_cmp_flags>.
+=cut
+*/
+I32
+Perl_sv_cmp_locale(pTHX_ SV *const sv1, SV *const sv2)
+{
+return sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC);
+}
+I32
+Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2,
+			 const U32 flags)
+{
+#ifdef USE_LOCALE_COLLATE
+char *pv1, *pv2;
+STRLEN len1, len2;
+I32 retval;
+if (PL_collation_standard)
+	goto raw_compare;
+len1 = 0;
+pv1 = sv1 ? sv_collxfrm_flags(sv1, &len1, flags) : (char *) NULL;
+len2 = 0;
+pv2 = sv2 ? sv_collxfrm_flags(sv2, &len2, flags) : (char *) NULL;
+if (!pv1 || !len1) {
+	if (pv2 && len2)
+	    return -1;
+	else
+	    goto raw_compare;
+}
+else {
+	if (!pv2 || !len2)
+	    return 1;
+}
+retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
+if (retval)
+	return retval < 0 ? -1 : 1;
+/*
+* When the result of collation is equality, that doesn't mean
+* that there are no differences -- some locales exclude some
+* characters from consideration.  So to avoid false equalities,
+* we use the raw string as a tiebreaker.
+*/
+raw_compare:
+/* FALLTHROUGH */
+#else
+PERL_UNUSED_ARG(flags);
+#endif /* USE_LOCALE_COLLATE */
+return sv_cmp(sv1, sv2);
+}
+#ifdef USE_LOCALE_COLLATE
+/*
+=for apidoc sv_collxfrm
+This calls C<sv_collxfrm_flags> with the SV_GMAGIC flag.  See
+C<sv_collxfrm_flags>.
+=for apidoc sv_collxfrm_flags
+Add Collate Transform magic to an SV if it doesn't already have it.  If the
+flags contain SV_GMAGIC, it handles get-magic.
+Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
+scalar data of the variable, but transformed to such a format that a normal
+memory comparison can be used to compare the data according to the locale
+settings.
+=cut
+*/
+char *
+Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags)
+{
+MAGIC *mg;
+PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS;
+mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
+if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
+	const char *s;
+	char *xf;
+	STRLEN len, xlen;
+	if (mg)
+	    Safefree(mg->mg_ptr);
+	s = SvPV_flags_const(sv, len, flags);
+	if ((xf = mem_collxfrm(s, len, &xlen))) {
+	    if (! mg) {
+#ifdef PERL_OLD_COPY_ON_WRITE
+		if (SvIsCOW(sv))
+		    sv_force_normal_flags(sv, 0);
+#endif
+		mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
+				 0, 0);
+		assert(mg);
+	    }
+	    mg->mg_ptr = xf;
+	    mg->mg_len = xlen;
+	}
+	else {
+	    if (mg) {
+		mg->mg_ptr = NULL;
+		mg->mg_len = -1;
+	    }
+	}
+}
+if (mg && mg->mg_ptr) {
+	*nxp = mg->mg_len;
+	return mg->mg_ptr + sizeof(PL_collation_ix);
+}
+else {
+	*nxp = 0;
+	return NULL;
+}
+}
+#endif /* USE_LOCALE_COLLATE */
+static char *
+S_sv_gets_append_to_utf8(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
+{
+SV * const tsv = newSV(0);
+ENTER;
+SAVEFREESV(tsv);
+sv_gets(tsv, fp, 0);
+sv_utf8_upgrade_nomg(tsv);
+SvCUR_set(sv,append);
+sv_catsv(sv,tsv);
+LEAVE;
+return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
+}
+static char *
+S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
+{
+SSize_t bytesread;
+const STRLEN recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
+/* Grab the size of the record we're getting */
+char *buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
+/* Go yank in */
+#ifdef __VMS
+int fd;
+Stat_t st;
+/* With a true, record-oriented file on VMS, we need to use read directly
+* to ensure that we respect RMS record boundaries.  The user is responsible
+* for providing a PL_rs value that corresponds to the FAB$W_MRS (maximum
+* record size) field.  N.B. This is likely to produce invalid results on
+* varying-width character data when a record ends mid-character.
+*/
+fd = PerlIO_fileno(fp);
+if (fd != -1
+	&& PerlLIO_fstat(fd, &st) == 0
+	&& (st.st_fab_rfm == FAB$C_VAR
+	    || st.st_fab_rfm == FAB$C_VFC
+	    || st.st_fab_rfm == FAB$C_FIX)) {
+	bytesread = PerlLIO_read(fd, buffer, recsize);
+}
+else /* in-memory file from PerlIO::Scalar
+* or not a record-oriented file
+*/
+#endif
+{
+	bytesread = PerlIO_read(fp, buffer, recsize);
+	/* At this point, the logic in sv_get() means that sv will
+	   be treated as utf-8 if the handle is utf8.
+	*/
+	if (PerlIO_isutf8(fp) && bytesread > 0) {
+	    char *bend = buffer + bytesread;
+	    char *bufp = buffer;
+	    size_t charcount = 0;
+	    bool charstart = TRUE;
+	    STRLEN skip = 0;
+	    while (charcount < recsize) {
+		/* count accumulated characters */
+		while (bufp < bend) {
+		    if (charstart) {
+			skip = UTF8SKIP(bufp);
+		    }
+		    if (bufp + skip > bend) {
+			/* partial at the end */
+			charstart = FALSE;
+			break;
+		    }
+		    else {
+			++charcount;
+			bufp += skip;
+			charstart = TRUE;
+		    }
+		}
+		if (charcount < recsize) {
+		    STRLEN readsize;
+		    STRLEN bufp_offset = bufp - buffer;
+		    SSize_t morebytesread;
+		    /* originally I read enough to fill any incomplete
+		       character and the first byte of the next
+		       character if needed, but if there's many
+		       multi-byte encoded characters we're going to be
+		       making a read call for every character beyond
+		       the original read size.
+		       So instead, read the rest of the character if
+		       any, and enough bytes to match at least the
+		       start bytes for each character we're going to
+		       read.
+		    */
+		    if (charstart)
+			readsize = recsize - charcount;
+		    else
+			readsize = skip - (bend - bufp) + recsize - charcount - 1;
+		    buffer = SvGROW(sv, append + bytesread + readsize + 1) + append;
+		    bend = buffer + bytesread;
+		    morebytesread = PerlIO_read(fp, bend, readsize);
+		    if (morebytesread <= 0) {
+			/* we're done, if we still have incomplete
+			   characters the check code in sv_gets() will
+			   warn about them.
+			   I'd originally considered doing
+			   PerlIO_ungetc() on all but the lead
+			   character of the incomplete character, but
+			   read() doesn't do that, so I don't.
+			*/
+			break;
+		    }
+		    /* prepare to scan some more */
+		    bytesread += morebytesread;
+		    bend = buffer + bytesread;
+		    bufp = buffer + bufp_offset;
+		}
+	    }
+	}
+}
+if (bytesread < 0)
+	bytesread = 0;
+SvCUR_set(sv, bytesread + append);
+buffer[bytesread] = '\0';
+return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
+}
+/*
+=for apidoc sv_gets
+Get a line from the filehandle and store it into the SV, optionally
+appending to the currently-stored string.  If C<append> is not 0, the
+line is appended to the SV instead of overwriting it.  C<append> should
+be set to the byte offset that the appended string should start at
+in the SV (typically, C<SvCUR(sv)> is a suitable choice).
+=cut
+*/
+char *
+Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
+{
+const char *rsptr;
+STRLEN rslen;
+STDCHAR rslast;
+STDCHAR *bp;
+SSize_t cnt;
+int i = 0;
+int rspara = 0;
+PERL_ARGS_ASSERT_SV_GETS;
+if (SvTHINKFIRST(sv))
+	sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
+/* XXX. If you make this PVIV, then copy on write can copy scalars read
+from <>.
+However, perlbench says it's slower, because the existing swipe code
+is faster than copy on write.
+Swings and roundabouts.  */
+SvUPGRADE(sv, SVt_PV);
+if (append) {
+/* line is going to be appended to the existing buffer in the sv */
+	if (PerlIO_isutf8(fp)) {
+	    if (!SvUTF8(sv)) {
+		sv_utf8_upgrade_nomg(sv);
+		sv_pos_u2b(sv,&append,0);
+	    }
+	} else if (SvUTF8(sv)) {
+	    return S_sv_gets_append_to_utf8(aTHX_ sv, fp, append);
+	}
+}
+SvPOK_only(sv);
+if (!append) {
+/* not appending - "clear" the string by setting SvCUR to 0,
+* the pv is still avaiable. */
+SvCUR_set(sv,0);
+}
+if (PerlIO_isutf8(fp))
+	SvUTF8_on(sv);
+if (IN_PERL_COMPILETIME) {
+	/* we always read code in line mode */
+	rsptr = "\n";
+	rslen = 1;
+}
+else if (RsSNARF(PL_rs)) {
+	/* If it is a regular disk file use size from stat() as estimate
+	   of amount we are going to read -- may result in mallocing
+	   more memory than we really need if the layers below reduce
+	   the size we read (e.g. CRLF or a gzip layer).
+	 */
+	Stat_t st;
+	if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode))  {
+	    const Off_t offset = PerlIO_tell(fp);
+	    if (offset != (Off_t) -1 && st.st_size + append > offset) {
+#ifdef PERL_NEW_COPY_ON_WRITE
+/* Add an extra byte for the sake of copy-on-write's
+* buffer reference count. */
+		(void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 2));
+#else
+		(void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
+#endif
+	    }
+	}
+	rsptr = NULL;
+	rslen = 0;
+}
+else if (RsRECORD(PL_rs)) {
+	return S_sv_gets_read_record(aTHX_ sv, fp, append);
+}
+else if (RsPARA(PL_rs)) {
+	rsptr = "\n\n";
+	rslen = 2;
+	rspara = 1;
+}
+else {
+	/* Get $/ i.e. PL_rs into same encoding as stream wants */
+	if (PerlIO_isutf8(fp)) {
+	    rsptr = SvPVutf8(PL_rs, rslen);
+	}
+	else {
+	    if (SvUTF8(PL_rs)) {
+		if (!sv_utf8_downgrade(PL_rs, TRUE)) {
+		    Perl_croak(aTHX_ "Wide character in $/");
+		}
+	    }
+/* extract the raw pointer to the record separator */
+	    rsptr = SvPV_const(PL_rs, rslen);
+	}
+}
+/* rslast is the last character in the record separator
+* note we don't use rslast except when rslen is true, so the
+* null assign is a placeholder. */
+rslast = rslen ? rsptr[rslen - 1] : '\0';
+if (rspara) {		/* have to do this both before and after */
+	do {			/* to make sure file boundaries work right */
+	    if (PerlIO_eof(fp))
+		return 0;
+	    i = PerlIO_getc(fp);
+	    if (i != '\n') {
+		if (i == -1)
+		    return 0;
+		PerlIO_ungetc(fp,i);
+		break;
+	    }
+	} while (i != EOF);
+}
+/* See if we know enough about I/O mechanism to cheat it ! */
+/* This used to be #ifdef test - it is made run-time test for ease
+of abstracting out stdio interface. One call should be cheap
+enough here - and may even be a macro allowing compile
+time optimization.
+*/
+if (PerlIO_fast_gets(fp)) {
+/*
+* We can do buffer based IO operations on this filehandle.
+*
+* This means we can bypass a lot of subcalls and process
+* the buffer directly, it also means we know the upper bound
+* on the amount of data we might read of the current buffer
+* into our sv. Knowing this allows us to preallocate the pv
+* to be able to hold that maximum, which allows us to simplify
+* a lot of logic. */
+/*
+* We're going to steal some values from the stdio struct
+* and put EVERYTHING in the innermost loop into registers.
+*/
+STDCHAR *ptr;       /* pointer into fp's read-ahead buffer */
+STRLEN bpx;         /* length of the data in the target sv
+used to fix pointers after a SvGROW */
+I32 shortbuffered;  /* If the pv buffer is shorter than the amount
+of data left in the read-ahead buffer.
+If 0 then the pv buffer can hold the full
+amount left, otherwise this is the amount it
+can hold. */
+#if defined(__VMS) && defined(PERLIO_IS_STDIO)
+/* An ungetc()d char is handled separately from the regular
+* buffer, so we getc() it back out and stuff it in the buffer.
+*/
+i = PerlIO_getc(fp);
+if (i == EOF) return 0;
+*(--((*fp)->_ptr)) = (unsigned char) i;
+(*fp)->_cnt++;
+#endif
+/* Here is some breathtakingly efficient cheating */
+/* When you read the following logic resist the urge to think
+* of record separators that are 1 byte long. They are an
+* uninteresting special (simple) case.
+*
+* Instead think of record separators which are at least 2 bytes
+* long, and keep in mind that we need to deal with such
+* separators when they cross a read-ahead buffer boundary.
+*
+* Also consider that we need to gracefully deal with separators
+* that may be longer than a single read ahead buffer.
+*
+* Lastly do not forget we want to copy the delimiter as well. We
+* are copying all data in the file _up_to_and_including_ the separator
+* itself.
+*
+* Now that you have all that in mind here is what is happening below:
+*
+* 1. When we first enter the loop we do some memory book keeping to see
+* how much free space there is in the target SV. (This sub assumes that
+* it is operating on the same SV most of the time via $_ and that it is
+* going to be able to reuse the same pv buffer each call.) If there is
+* "enough" room then we set "shortbuffered" to how much space there is
+* and start reading forward.
+*
+* 2. When we scan forward we copy from the read-ahead buffer to the target
+* SV's pv buffer. While we go we watch for the end of the read-ahead buffer,
+* and the end of the of pv, as well as for the "rslast", which is the last
+* char of the separator.
+*
+* 3. When scanning forward if we see rslast then we jump backwards in *pv*
+* (which has a "complete" record up to the point we saw rslast) and check
+* it to see if it matches the separator. If it does we are done. If it doesn't
+* we continue on with the scan/copy.
+*
+* 4. If we run out of read-ahead buffer (cnt goes to 0) then we have to get
+* the IO system to read the next buffer. We do this by doing a getc(), which
+* returns a single char read (or EOF), and prefills the buffer, and also
+* allows us to find out how full the buffer is.  We use this information to
+* SvGROW() the sv to the size remaining in the buffer, after which we copy
+* the returned single char into the target sv, and then go back into scan
+* forward mode.
+*
+* 5. If we run out of write-buffer then we SvGROW() it by the size of the
+* remaining space in the read-buffer.
+*
+* Note that this code despite its twisty-turny nature is pretty darn slick.
+* It manages single byte separators, multi-byte cross boundary separators,
+* and cross-read-buffer separators cleanly and efficiently at the cost
+* of potentially greatly overallocating the target SV.
+*
+* Yves
+*/
+/* get the number of bytes remaining in the read-ahead buffer
+* on first call on a given fp this will return 0.*/
+cnt = PerlIO_get_cnt(fp);
+/* make sure we have the room */
+if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
+	/* Not room for all of it
+	   if we are looking for a separator and room for some
+	 */
+	if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
+	    /* just process what we have room for */
+	    shortbuffered = cnt - SvLEN(sv) + append + 1;
+	    cnt -= shortbuffered;
+	}
+	else {
+/* ensure that the target sv has enough room to hold
+* the rest of the read-ahead buffer */
+	    shortbuffered = 0;
+	    /* remember that cnt can be negative */
+	    SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
+	}
+}
+else {
+/* we have enough room to hold the full buffer, lets scream */
+	shortbuffered = 0;
+}
+/* extract the pointer to sv's string buffer, offset by append as necessary */
+bp = (STDCHAR*)SvPVX_const(sv) + append;  /* move these two too to registers */
+/* extract the point to the read-ahead buffer */
+ptr = (STDCHAR*)PerlIO_get_ptr(fp);
+/* some trace debug output */
+DEBUG_P(PerlIO_printf(Perl_debug_log,
+	"Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
+DEBUG_P(PerlIO_printf(Perl_debug_log,
+	"Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%"IVdf", base=%"
+	 UVuf"\n",
+	       PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp),
+	       PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
+for (;;) {
+screamer:
+/* if there is stuff left in the read-ahead buffer */
+	if (cnt > 0) {
+/* if there is a separator */
+	    if (rslen) {
+/* loop until we hit the end of the read-ahead buffer */
+		while (cnt > 0) {		     /* this     |  eat */
+/* scan forward copying and searching for rslast as we go */
+		    cnt--;
+		    if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
+			goto thats_all_folks;	     /* screams  |  sed :-) */
+		}
+	    }
+	    else {
+/* no separator, slurp the full buffer */
+	        Copy(ptr, bp, cnt, char);	     /* this     |  eat */
+		bp += cnt;			     /* screams  |  dust */
+		ptr += cnt;			     /* louder   |  sed :-) */
+		cnt = 0;
+		assert (!shortbuffered);
+		goto cannot_be_shortbuffered;
+	    }
+	}
+	if (shortbuffered) {		/* oh well, must extend */
+/* we didnt have enough room to fit the line into the target buffer
+* so we must extend the target buffer and keep going */
+	    cnt = shortbuffered;
+	    shortbuffered = 0;
+	    bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
+	    SvCUR_set(sv, bpx);
+/* extned the target sv's buffer so it can hold the full read-ahead buffer */
+	    SvGROW(sv, SvLEN(sv) + append + cnt + 2);
+	    bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
+	    continue;
+	}
+cannot_be_shortbuffered:
+/* we need to refill the read-ahead buffer if possible */
+	DEBUG_P(PerlIO_printf(Perl_debug_log,
+			     "Screamer: going to getc, ptr=%"UVuf", cnt=%"IVdf"\n",
+			      PTR2UV(ptr),(IV)cnt));
+	PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
+	DEBUG_Pv(PerlIO_printf(Perl_debug_log,
+	   "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%"IVdf", base=%"UVuf"\n",
+	    PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp),
+	    PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
+/*
+call PerlIO_getc() to let it prefill the lookahead buffer
+This used to call 'filbuf' in stdio form, but as that behaves like
+getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
+another abstraction.
+Note we have to deal with the char in 'i' if we are not at EOF
+*/
+	i   = PerlIO_getc(fp);		/* get more characters */
+	DEBUG_Pv(PerlIO_printf(Perl_debug_log,
+	   "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%"IVdf", base=%"UVuf"\n",
+	    PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp),
+	    PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
+/* find out how much is left in the read-ahead buffer, and rextract its pointer */
+	cnt = PerlIO_get_cnt(fp);
+	ptr = (STDCHAR*)PerlIO_get_ptr(fp);	/* reregisterize cnt and ptr */
+	DEBUG_P(PerlIO_printf(Perl_debug_log,
+	    "Screamer: after getc, ptr=%"UVuf", cnt=%"IVdf"\n",
+	    PTR2UV(ptr),(IV)cnt));
+	if (i == EOF)			/* all done for ever? */
+	    goto thats_really_all_folks;
+/* make sure we have enough space in the target sv */
+	bpx = bp - (STDCHAR*)SvPVX_const(sv);	/* box up before relocation */
+	SvCUR_set(sv, bpx);
+	SvGROW(sv, bpx + cnt + 2);
+	bp = (STDCHAR*)SvPVX_const(sv) + bpx;	/* unbox after relocation */
+/* copy of the char we got from getc() */
+	*bp++ = (STDCHAR)i;		/* store character from PerlIO_getc */
+/* make sure we deal with the i being the last character of a separator */
+	if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
+	    goto thats_all_folks;
+}
+thats_all_folks:
+/* check if we have actually found the separator - only really applies
+* when rslen > 1 */
+if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
+	  memNE((char*)bp - rslen, rsptr, rslen))
+	goto screamer;				/* go back to the fray */
+thats_really_all_folks:
+if (shortbuffered)
+	cnt += shortbuffered;
+	DEBUG_P(PerlIO_printf(Perl_debug_log,
+	     "Screamer: quitting, ptr=%"UVuf", cnt=%"IVdf"\n",PTR2UV(ptr),(IV)cnt));
+PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt);	/* put these back or we're in trouble */
+DEBUG_P(PerlIO_printf(Perl_debug_log,
+	"Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%"IVdf", base=%"UVuf
+	"\n",
+	PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp),
+	PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
+*bp = '\0';
+SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv));	/* set length */
+DEBUG_P(PerlIO_printf(Perl_debug_log,
+	"Screamer: done, len=%ld, string=|%.*s|\n",
+	(long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
+}
+else
+{
+/*The big, slow, and stupid way. */
+#ifdef USE_HEAP_INSTEAD_OF_STACK	/* Even slower way. */
+	STDCHAR *buf = NULL;
+	Newx(buf, 8192, STDCHAR);
+	assert(buf);
+#else
+	STDCHAR buf[8192];
+#endif
+screamer2:
+	if (rslen) {
+const STDCHAR * const bpe = buf + sizeof(buf);
+	    bp = buf;
+	    while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
+		; /* keep reading */
+	    cnt = bp - buf;
+	}
+	else {
+	    cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
+	    /* Accommodate broken VAXC compiler, which applies U8 cast to
+	     * both args of ?: operator, causing EOF to change into 255
+	     */
+	    if (cnt > 0)
+		 i = (U8)buf[cnt - 1];
+	    else
+		 i = EOF;
+	}
+	if (cnt < 0)
+	    cnt = 0;  /* we do need to re-set the sv even when cnt <= 0 */
+	if (append)
+sv_catpvn_nomg(sv, (char *) buf, cnt);
+	else
+sv_setpvn(sv, (char *) buf, cnt);   /* "nomg" is implied */
+	if (i != EOF &&			/* joy */
+	    (!rslen ||
+	     SvCUR(sv) < rslen ||
+	     memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
+	{
+	    append = -1;
+	    /*
+	     * If we're reading from a TTY and we get a short read,
+	     * indicating that the user hit his EOF character, we need
+	     * to notice it now, because if we try to read from the TTY
+	     * again, the EOF condition will disappear.
+	     *
+	     * The comparison of cnt to sizeof(buf) is an optimization
+	     * that prevents unnecessary calls to feof().
+	     *
+	     * - jik 9/25/96
+	     */
+	    if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
+		goto screamer2;
+	}
+#ifdef USE_HEAP_INSTEAD_OF_STACK
+	Safefree(buf);
+#endif
+}
+if (rspara) {		/* have to do this both before and after */
+while (i != EOF) {	/* to make sure file boundaries work right */
+	    i = PerlIO_getc(fp);
+	    if (i != '\n') {
+		PerlIO_ungetc(fp,i);
+		break;
+	    }
+	}
+}
+return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
+}
+/*
+=for apidoc sv_inc
+Auto-increment of the value in the SV, doing string to numeric conversion
+if necessary.  Handles 'get' magic and operator overloading.
+=cut
+*/
+void
+Perl_sv_inc(pTHX_ SV *const sv)
+{
+if (!sv)
+	return;
+SvGETMAGIC(sv);
+sv_inc_nomg(sv);
+}
+/*
+=for apidoc sv_inc_nomg
+Auto-increment of the value in the SV, doing string to numeric conversion
+if necessary.  Handles operator overloading.  Skips handling 'get' magic.
+=cut
+*/
+void
+Perl_sv_inc_nomg(pTHX_ SV *const sv)
+{
+char *d;
+int flags;
+if (!sv)
+	return;
+if (SvTHINKFIRST(sv)) {
+	if (SvREADONLY(sv)) {
+		Perl_croak_no_modify();
+	}
+	if (SvROK(sv)) {
+	    IV i;
+	    if (SvAMAGIC(sv) && AMG_CALLunary(sv, inc_amg))
+		return;
+	    i = PTR2IV(SvRV(sv));
+	    sv_unref(sv);
+	    sv_setiv(sv, i);
+	}
+	else sv_force_normal_flags(sv, 0);
+}
+flags = SvFLAGS(sv);
+if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
+	/* It's (privately or publicly) a float, but not tested as an
+	   integer, so test it to see. */
+	(void) SvIV(sv);
+	flags = SvFLAGS(sv);
+}
+if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
+	/* It's publicly an integer, or privately an integer-not-float */
+#ifdef PERL_PRESERVE_IVUV
+oops_its_int:
+#endif
+	if (SvIsUV(sv)) {
+	    if (SvUVX(sv) == UV_MAX)
+		sv_setnv(sv, UV_MAX_P1);
+	    else
+		(void)SvIOK_only_UV(sv);
+		SvUV_set(sv, SvUVX(sv) + 1);
+	} else {
+	    if (SvIVX(sv) == IV_MAX)
+		sv_setuv(sv, (UV)IV_MAX + 1);
+	    else {
+		(void)SvIOK_only(sv);
+		SvIV_set(sv, SvIVX(sv) + 1);
+	    }
+	}
+	return;
+}
+if (flags & SVp_NOK) {
+	const NV was = SvNVX(sv);
+	if (LIKELY(!Perl_isinfnan(was)) &&
+NV_OVERFLOWS_INTEGERS_AT &&
+	    was >= NV_OVERFLOWS_INTEGERS_AT) {
+	    /* diag_listed_as: Lost precision when %s %f by 1 */
+	    Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
+			   "Lost precision when incrementing %" NVff " by 1",
+			   was);
+	}
+	(void)SvNOK_only(sv);
+SvNV_set(sv, was + 1.0);
+	return;
+}
+if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
+	if ((flags & SVTYPEMASK) < SVt_PVIV)
+	    sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
+	(void)SvIOK_only(sv);
+	SvIV_set(sv, 1);
+	return;
+}
+d = SvPVX(sv);
+while (isALPHA(*d)) d++;
+while (isDIGIT(*d)) d++;
+if (d < SvEND(sv)) {
+	const int numtype = grok_number_flags(SvPVX_const(sv), SvCUR(sv), NULL, PERL_SCAN_TRAILING);
+#ifdef PERL_PRESERVE_IVUV
+	/* Got to punt this as an integer if needs be, but we don't issue
+	   warnings. Probably ought to make the sv_iv_please() that does
+	   the conversion if possible, and silently.  */
+	if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
+	    /* Need to try really hard to see if it's an integer.
+	       9.22337203685478e+18 is an integer.
+	       but "9.22337203685478e+18" + 0 is UV=9223372036854779904
+	       so $a="9.22337203685478e+18"; $a+0; $a++
+	       needs to be the same as $a="9.22337203685478e+18"; $a++
+	       or we go insane. */
+	    (void) sv_2iv(sv);
+	    if (SvIOK(sv))
+		goto oops_its_int;
+	    /* sv_2iv *should* have made this an NV */
+	    if (flags & SVp_NOK) {
+		(void)SvNOK_only(sv);
+SvNV_set(sv, SvNVX(sv) + 1.0);
+		return;
+	    }
+	    /* I don't think we can get here. Maybe I should assert this
+	       And if we do get here I suspect that sv_setnv will croak. NWC
+	       Fall through. */
+	    DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
+				  SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
+	}
+#endif /* PERL_PRESERVE_IVUV */
+if (!numtype && ckWARN(WARN_NUMERIC))
+not_incrementable(sv);
+	sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
+	return;
+}
+d--;
+while (d >= SvPVX_const(sv)) {
+	if (isDIGIT(*d)) {
+	    if (++*d <= '9')
+		return;
+	    *(d--) = '0';
+	}
+	else {
+#ifdef EBCDIC
+	    /* MKS: The original code here died if letters weren't consecutive.
+	     * at least it didn't have to worry about non-C locales.  The
+	     * new code assumes that ('z'-'a')==('Z'-'A'), letters are
+	     * arranged in order (although not consecutively) and that only
+	     * [A-Za-z] are accepted by isALPHA in the C locale.
+	     */
+	    if (isALPHA_FOLD_NE(*d, 'z')) {
+		do { ++*d; } while (!isALPHA(*d));
+		return;
+	    }
+	    *(d--) -= 'z' - 'a';
+#else
+	    ++*d;
+	    if (isALPHA(*d))
+		return;
+	    *(d--) -= 'z' - 'a' + 1;
+#endif
+	}
+}
+/* oh,oh, the number grew */
+SvGROW(sv, SvCUR(sv) + 2);
+SvCUR_set(sv, SvCUR(sv) + 1);
+for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
+	*d = d[-1];
+if (isDIGIT(d[1]))
+	*d = '1';
+else
+	*d = d[1];
+}
+/*
+=for apidoc sv_dec
+Auto-decrement of the value in the SV, doing string to numeric conversion
+if necessary.  Handles 'get' magic and operator overloading.
+=cut
+*/
+void
+Perl_sv_dec(pTHX_ SV *const sv)
+{
+if (!sv)
+	return;
+SvGETMAGIC(sv);
+sv_dec_nomg(sv);
+}
+/*
+=for apidoc sv_dec_nomg
+Auto-decrement of the value in the SV, doing string to numeric conversion
+if necessary.  Handles operator overloading.  Skips handling 'get' magic.
+=cut
+*/
+void
+Perl_sv_dec_nomg(pTHX_ SV *const sv)
+{
+int flags;
+if (!sv)
+	return;
+if (SvTHINKFIRST(sv)) {
+	if (SvREADONLY(sv)) {
+		Perl_croak_no_modify();
+	}
+	if (SvROK(sv)) {
+	    IV i;
+	    if (SvAMAGIC(sv) && AMG_CALLunary(sv, dec_amg))
+		return;
+	    i = PTR2IV(SvRV(sv));
+	    sv_unref(sv);
+	    sv_setiv(sv, i);
+	}
+	else sv_force_normal_flags(sv, 0);
+}
+/* Unlike sv_inc we don't have to worry about string-never-numbers
+and keeping them magic. But we mustn't warn on punting */
+flags = SvFLAGS(sv);
+if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
+	/* It's publicly an integer, or privately an integer-not-float */
+#ifdef PERL_PRESERVE_IVUV
+oops_its_int:
+#endif
+	if (SvIsUV(sv)) {
+	    if (SvUVX(sv) == 0) {
+		(void)SvIOK_only(sv);
+		SvIV_set(sv, -1);
+	    }
+	    else {
+		(void)SvIOK_only_UV(sv);
+		SvUV_set(sv, SvUVX(sv) - 1);
+	    }
+	} else {
+	    if (SvIVX(sv) == IV_MIN) {
+		sv_setnv(sv, (NV)IV_MIN);
+		goto oops_its_num;
+	    }
+	    else {
+		(void)SvIOK_only(sv);
+		SvIV_set(sv, SvIVX(sv) - 1);
+	    }
+	}
+	return;
+}
+if (flags & SVp_NOK) {
+oops_its_num:
+	{
+	    const NV was = SvNVX(sv);
+	    if (LIKELY(!Perl_isinfnan(was)) &&
+NV_OVERFLOWS_INTEGERS_AT &&
+		was <= -NV_OVERFLOWS_INTEGERS_AT) {
+		/* diag_listed_as: Lost precision when %s %f by 1 */
+		Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
+			       "Lost precision when decrementing %" NVff " by 1",
+			       was);
+	    }
+	    (void)SvNOK_only(sv);
+	    SvNV_set(sv, was - 1.0);
+	    return;
+	}
+}
+if (!(flags & SVp_POK)) {
+	if ((flags & SVTYPEMASK) < SVt_PVIV)
+	    sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
+	SvIV_set(sv, -1);
+	(void)SvIOK_only(sv);
+	return;
+}
+#ifdef PERL_PRESERVE_IVUV
+{
+	const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
+	if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
+	    /* Need to try really hard to see if it's an integer.
+	       9.22337203685478e+18 is an integer.
+	       but "9.22337203685478e+18" + 0 is UV=9223372036854779904
+	       so $a="9.22337203685478e+18"; $a+0; $a--
+	       needs to be the same as $a="9.22337203685478e+18"; $a--
+	       or we go insane. */
+	    (void) sv_2iv(sv);
+	    if (SvIOK(sv))
+		goto oops_its_int;
+	    /* sv_2iv *should* have made this an NV */
+	    if (flags & SVp_NOK) {
+		(void)SvNOK_only(sv);
+SvNV_set(sv, SvNVX(sv) - 1.0);
+		return;
+	    }
+	    /* I don't think we can get here. Maybe I should assert this
+	       And if we do get here I suspect that sv_setnv will croak. NWC
+	       Fall through. */
+	    DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
+				  SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
+	}
+}
+#endif /* PERL_PRESERVE_IVUV */
+sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0);	/* punt */
+}
+/* this define is used to eliminate a chunk of duplicated but shared logic
+* it has the suffix __SV_C to signal that it isnt API, and isnt meant to be
+* used anywhere but here - yves
+*/
+#define PUSH_EXTEND_MORTAL__SV_C(AnSv) \
+STMT_START {      \
+	SSize_t ix = ++PL_tmps_ix;		\
+	if (UNLIKELY(ix >= PL_tmps_max))	\
+	    ix = tmps_grow_p(ix);			\
+	PL_tmps_stack[ix] = (AnSv); \
+} STMT_END
+/*
+=for apidoc sv_mortalcopy
+Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
+The new SV is marked as mortal.  It will be destroyed "soon", either by an
+explicit call to FREETMPS, or by an implicit call at places such as
+statement boundaries.  See also C<sv_newmortal> and C<sv_2mortal>.
+=cut
+*/
+/* Make a string that will exist for the duration of the expression
+* evaluation.  Actually, it may have to last longer than that, but
+* hopefully we won't free it until it has been assigned to a
+* permanent location. */
+SV *
+Perl_sv_mortalcopy_flags(pTHX_ SV *const oldstr, U32 flags)
+{
+SV *sv;
+if (flags & SV_GMAGIC)
+	SvGETMAGIC(oldstr); /* before new_SV, in case it dies */
+new_SV(sv);
+sv_setsv_flags(sv,oldstr,flags & ~SV_GMAGIC);
+PUSH_EXTEND_MORTAL__SV_C(sv);
+SvTEMP_on(sv);
+return sv;
+}
+/*
+=for apidoc sv_newmortal
+Creates a new null SV which is mortal.  The reference count of the SV is
+set to 1.  It will be destroyed "soon", either by an explicit call to
+FREETMPS, or by an implicit call at places such as statement boundaries.
+See also C<sv_mortalcopy> and C<sv_2mortal>.
+=cut
+*/
+SV *
+Perl_sv_newmortal(pTHX)
+{
+SV *sv;
+new_SV(sv);
+SvFLAGS(sv) = SVs_TEMP;
+PUSH_EXTEND_MORTAL__SV_C(sv);
+return sv;
+}
+/*
+=for apidoc newSVpvn_flags
+Creates a new SV and copies a string (which may contain C<NUL> (C<\0>)
+characters) into it.  The reference count for the
+SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
+string.  You are responsible for ensuring that the source string is at least
+C<len> bytes long.  If the C<s> argument is NULL the new SV will be undefined.
+Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
+If C<SVs_TEMP> is set, then C<sv_2mortal()> is called on the result before
+returning.  If C<SVf_UTF8> is set, C<s>
+is considered to be in UTF-8 and the
+C<SVf_UTF8> flag will be set on the new SV.
+C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
+#define newSVpvn_utf8(s, len, u)			\
+	newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
+=cut
+*/
+SV *
+Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
+{
+SV *sv;
+/* All the flags we don't support must be zero.
+And we're new code so I'm going to assert this from the start.  */
+assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
+new_SV(sv);
+sv_setpvn(sv,s,len);
+/* This code used to do a sv_2mortal(), however we now unroll the call to
+* sv_2mortal() and do what it does ourselves here.  Since we have asserted
+* that flags can only have the SVf_UTF8 and/or SVs_TEMP flags set above we
+* can use it to enable the sv flags directly (bypassing SvTEMP_on), which
+* in turn means we dont need to mask out the SVf_UTF8 flag below, which
+* means that we eliminate quite a few steps than it looks - Yves
+* (explaining patch by gfx) */
+SvFLAGS(sv) |= flags;
+if(flags & SVs_TEMP){
+	PUSH_EXTEND_MORTAL__SV_C(sv);
+}
+return sv;
+}
+/*
+=for apidoc sv_2mortal
+Marks an existing SV as mortal.  The SV will be destroyed "soon", either
+by an explicit call to FREETMPS, or by an implicit call at places such as
+statement boundaries.  SvTEMP() is turned on which means that the SV's
+string buffer can be "stolen" if this SV is copied.  See also C<sv_newmortal>
+and C<sv_mortalcopy>.
+=cut
+*/
+SV *
+Perl_sv_2mortal(pTHX_ SV *const sv)
+{
+dVAR;
+if (!sv)
+	return sv;
+if (SvIMMORTAL(sv))
+	return sv;
+PUSH_EXTEND_MORTAL__SV_C(sv);
+SvTEMP_on(sv);
+return sv;
+}
+/*
+=for apidoc newSVpv
+Creates a new SV and copies a string (which may contain C<NUL> (C<\0>)
+characters) into it.  The reference count for the
+SV is set to 1.  If C<len> is zero, Perl will compute the length using
+strlen(), (which means if you use this option, that C<s> can't have embedded
+C<NUL> characters and has to have a terminating C<NUL> byte).
+For efficiency, consider using C<newSVpvn> instead.
+=cut
+*/
+SV *
+Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
+{
+SV *sv;
+new_SV(sv);
+sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
+return sv;
+}
+/*
+=for apidoc newSVpvn
+Creates a new SV and copies a string into it, which may contain C<NUL> characters
+(C<\0>) and other binary data.  The reference count for the SV is set to 1.
+Note that if C<len> is zero, Perl will create a zero length (Perl) string.  You
+are responsible for ensuring that the source buffer is at least
+C<len> bytes long.  If the C<buffer> argument is NULL the new SV will be
+undefined.
+=cut
+*/
+SV *
+Perl_newSVpvn(pTHX_ const char *const buffer, const STRLEN len)
+{
+SV *sv;
+new_SV(sv);
+sv_setpvn(sv,buffer,len);
+return sv;
+}
+/*
+=for apidoc newSVhek
+Creates a new SV from the hash key structure.  It will generate scalars that
+point to the shared string table where possible.  Returns a new (undefined)
+SV if the hek is NULL.
+=cut
+*/
+SV *
+Perl_newSVhek(pTHX_ const HEK *const hek)
+{
+if (!hek) {
+	SV *sv;
+	new_SV(sv);
+	return sv;
+}
+if (HEK_LEN(hek) == HEf_SVKEY) {
+	return newSVsv(*(SV**)HEK_KEY(hek));
+} else {
+	const int flags = HEK_FLAGS(hek);
+	if (flags & HVhek_WASUTF8) {
+	    /* Trouble :-)
+	       Andreas would like keys he put in as utf8 to come back as utf8
+	    */
+	    STRLEN utf8_len = HEK_LEN(hek);
+	    SV * const sv = newSV_type(SVt_PV);
+	    char *as_utf8 = (char *)bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
+	    /* bytes_to_utf8() allocates a new string, which we can repurpose: */
+	    sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
+	    SvUTF8_on (sv);
+	    return sv;
+} else if (flags & HVhek_UNSHARED) {
+/* A hash that isn't using shared hash keys has to have
+	       the flag in every key so that we know not to try to call
+	       share_hek_hek on it.  */
+	    SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
+	    if (HEK_UTF8(hek))
+		SvUTF8_on (sv);
+	    return sv;
+	}
+	/* This will be overwhelminly the most common case.  */
+	{
+	    /* Inline most of newSVpvn_share(), because share_hek_hek() is far
+	       more efficient than sharepvn().  */
+	    SV *sv;
+	    new_SV(sv);
+	    sv_upgrade(sv, SVt_PV);
+	    SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
+	    SvCUR_set(sv, HEK_LEN(hek));
+	    SvLEN_set(sv, 0);
+	    SvIsCOW_on(sv);
+	    SvPOK_on(sv);
+	    if (HEK_UTF8(hek))
+		SvUTF8_on(sv);
+	    return sv;
+	}
+}
+}
+/*
+=for apidoc newSVpvn_share
+Creates a new SV with its SvPVX_const pointing to a shared string in the string
+table.  If the string does not already exist in the table, it is
+created first.  Turns on the SvIsCOW flag (or READONLY
+and FAKE in 5.16 and earlier).  If the C<hash> parameter
+is non-zero, that value is used; otherwise the hash is computed.
+The string's hash can later be retrieved from the SV
+with the C<SvSHARED_HASH()> macro.  The idea here is
+that as the string table is used for shared hash keys these strings will have
+SvPVX_const == HeKEY and hash lookup will avoid string compare.
+=cut
+*/
+SV *
+Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
+{
+dVAR;
+SV *sv;
+bool is_utf8 = FALSE;
+const char *const orig_src = src;
+if (len < 0) {
+	STRLEN tmplen = -len;
+is_utf8 = TRUE;
+	/* See the note in hv.c:hv_fetch() --jhi */
+	src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
+	len = tmplen;
+}
+if (!hash)
+	PERL_HASH(hash, src, len);
+new_SV(sv);
+/* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
+changes here, update it there too.  */
+sv_upgrade(sv, SVt_PV);
+SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
+SvCUR_set(sv, len);
+SvLEN_set(sv, 0);
+SvIsCOW_on(sv);
+SvPOK_on(sv);
+if (is_utf8)
+SvUTF8_on(sv);
+if (src != orig_src)
+	Safefree(src);
+return sv;
+}
+/*
+=for apidoc newSVpv_share
+Like C<newSVpvn_share>, but takes a C<NUL>-terminated string instead of a
+string/length pair.
+=cut
+*/
+SV *
+Perl_newSVpv_share(pTHX_ const char *src, U32 hash)
+{
+return newSVpvn_share(src, strlen(src), hash);
+}
+#if defined(PERL_IMPLICIT_CONTEXT)
+/* pTHX_ magic can't cope with varargs, so this is a no-context
+* version of the main function, (which may itself be aliased to us).
+* Don't access this version directly.
+*/
+SV *
+Perl_newSVpvf_nocontext(const char *const pat, ...)
+{
+dTHX;
+SV *sv;
+va_list args;
+PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
+va_start(args, pat);
+sv = vnewSVpvf(pat, &args);
+va_end(args);
+return sv;
+}
+#endif
+/*
+=for apidoc newSVpvf
+Creates a new SV and initializes it with the string formatted like
+C<sprintf>.
+=cut
+*/
+SV *
+Perl_newSVpvf(pTHX_ const char *const pat, ...)
+{
+SV *sv;
+va_list args;
+PERL_ARGS_ASSERT_NEWSVPVF;
+va_start(args, pat);
+sv = vnewSVpvf(pat, &args);
+va_end(args);
+return sv;
+}
+/* backend for newSVpvf() and newSVpvf_nocontext() */
+SV *
+Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
+{
+SV *sv;
+PERL_ARGS_ASSERT_VNEWSVPVF;
+new_SV(sv);
+sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
+return sv;
+}
+/*
+=for apidoc newSVnv
+Creates a new SV and copies a floating point value into it.
+The reference count for the SV is set to 1.
+=cut
+*/
+SV *
+Perl_newSVnv(pTHX_ const NV n)
+{
+SV *sv;
+new_SV(sv);
+sv_setnv(sv,n);
+return sv;
+}
+/*
+=for apidoc newSViv
+Creates a new SV and copies an integer into it.  The reference count for the
+SV is set to 1.
+=cut
+*/
+SV *
+Perl_newSViv(pTHX_ const IV i)
+{
+SV *sv;
+new_SV(sv);
+/* Inlining ONLY the small relevant subset of sv_setiv here
+* for performance. Makes a significant difference. */
+/* We're starting from SVt_FIRST, so provided that's
+* actual 0, we don't have to unset any SV type flags
+* to promote to SVt_IV. */
+STATIC_ASSERT_STMT(SVt_FIRST == 0);
+SET_SVANY_FOR_BODYLESS_IV(sv);
+SvFLAGS(sv) |= SVt_IV;
+(void)SvIOK_on(sv);
+SvIV_set(sv, i);
+SvTAINT(sv);
+return sv;
+}
+/*
+=for apidoc newSVuv
+Creates a new SV and copies an unsigned integer into it.
+The reference count for the SV is set to 1.
+=cut
+*/
+SV *
+Perl_newSVuv(pTHX_ const UV u)
+{
+SV *sv;
+/* Inlining ONLY the small relevant subset of sv_setuv here
+* for performance. Makes a significant difference. */
+/* Using ivs is more efficient than using uvs - see sv_setuv */
+if (u <= (UV)IV_MAX) {
+	return newSViv((IV)u);
+}
+new_SV(sv);
+/* We're starting from SVt_FIRST, so provided that's
+* actual 0, we don't have to unset any SV type flags
+* to promote to SVt_IV. */
+STATIC_ASSERT_STMT(SVt_FIRST == 0);
+SET_SVANY_FOR_BODYLESS_IV(sv);
+SvFLAGS(sv) |= SVt_IV;
+(void)SvIOK_on(sv);
+(void)SvIsUV_on(sv);
+SvUV_set(sv, u);
+SvTAINT(sv);
+return sv;
+}
+/*
+=for apidoc newSV_type
+Creates a new SV, of the type specified.  The reference count for the new SV
+is set to 1.
+=cut
+*/
+SV *
+Perl_newSV_type(pTHX_ const svtype type)
+{
+SV *sv;
+new_SV(sv);
+ASSUME(SvTYPE(sv) == SVt_FIRST);
+if(type != SVt_FIRST)
+	sv_upgrade(sv, type);
+return sv;
+}
+/*
+=for apidoc newRV_noinc
+Creates an RV wrapper for an SV.  The reference count for the original
+SV is B<not> incremented.
+=cut
+*/
+SV *
+Perl_newRV_noinc(pTHX_ SV *const tmpRef)
+{
+SV *sv;
+PERL_ARGS_ASSERT_NEWRV_NOINC;
+new_SV(sv);
+/* We're starting from SVt_FIRST, so provided that's
+* actual 0, we don't have to unset any SV type flags
+* to promote to SVt_IV. */
+STATIC_ASSERT_STMT(SVt_FIRST == 0);
+SET_SVANY_FOR_BODYLESS_IV(sv);
+SvFLAGS(sv) |= SVt_IV;
+SvROK_on(sv);
+SvIV_set(sv, 0);
+SvTEMP_off(tmpRef);
+SvRV_set(sv, tmpRef);
+return sv;
+}
+/* newRV_inc is the official function name to use now.
+* newRV_inc is in fact #defined to newRV in sv.h
+*/
+SV *
+Perl_newRV(pTHX_ SV *const sv)
+{
+PERL_ARGS_ASSERT_NEWRV;
+return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
+}
+/*
+=for apidoc newSVsv
+Creates a new SV which is an exact duplicate of the original SV.
+(Uses C<sv_setsv>.)
+=cut
+*/
+SV *
+Perl_newSVsv(pTHX_ SV *const old)
+{
+SV *sv;
+if (!old)
+	return NULL;
+if (SvTYPE(old) == (svtype)SVTYPEMASK) {
+	Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
+	return NULL;
+}
+/* Do this here, otherwise we leak the new SV if this croaks. */
+SvGETMAGIC(old);
+new_SV(sv);
+/* SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
+with SvTEMP_off and SvTEMP_on round a call to sv_setsv.  */
+sv_setsv_flags(sv, old, SV_NOSTEAL);
+return sv;
+}
+/*
+=for apidoc sv_reset
+Underlying implementation for the C<reset> Perl function.
+Note that the perl-level function is vaguely deprecated.
+=cut
+*/
+void
+Perl_sv_reset(pTHX_ const char *s, HV *const stash)
+{
+PERL_ARGS_ASSERT_SV_RESET;
+sv_resetpvn(*s ? s : NULL, strlen(s), stash);
+}
+void
+Perl_sv_resetpvn(pTHX_ const char *s, STRLEN len, HV * const stash)
+{
+char todo[PERL_UCHAR_MAX+1];
+const char *send;
+if (!stash || SvTYPE(stash) != SVt_PVHV)
+	return;
+if (!s) {		/* reset ?? searches */
+	MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
+	if (mg) {
+	    const U32 count = mg->mg_len / sizeof(PMOP**);
+	    PMOP **pmp = (PMOP**) mg->mg_ptr;
+	    PMOP *const *const end = pmp + count;
+	    while (pmp < end) {
+#ifdef USE_ITHREADS
+SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
+#else
+		(*pmp)->op_pmflags &= ~PMf_USED;
+#endif
+		++pmp;
+	    }
+	}
+	return;
+}
+/* reset variables */
+if (!HvARRAY(stash))
+	return;
+Zero(todo, 256, char);
+send = s + len;
+while (s < send) {
+	I32 max;
+	I32 i = (unsigned char)*s;
+	if (s[1] == '-') {
+	    s += 2;
+	}
+	max = (unsigned char)*s++;
+	for ( ; i <= max; i++) {
+	    todo[i] = 1;
+	}
+	for (i = 0; i <= (I32) HvMAX(stash); i++) {
+	    HE *entry;
+	    for (entry = HvARRAY(stash)[i];
+		 entry;
+		 entry = HeNEXT(entry))
+	    {
+		GV *gv;
+		SV *sv;
+		if (!todo[(U8)*HeKEY(entry)])
+		    continue;
+		gv = MUTABLE_GV(HeVAL(entry));
+		sv = GvSV(gv);
+		if (sv && !SvREADONLY(sv)) {
+		    SV_CHECK_THINKFIRST_COW_DROP(sv);
+		    if (!isGV(sv)) SvOK_off(sv);
+		}
+		if (GvAV(gv)) {
+		    av_clear(GvAV(gv));
+		}
+		if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
+		    hv_clear(GvHV(gv));
+		}
+	    }
+	}
+}
+}
+/*
+=for apidoc sv_2io
+Using various gambits, try to get an IO from an SV: the IO slot if its a
+GV; or the recursive result if we're an RV; or the IO slot of the symbol
+named after the PV if we're a string.
+'Get' magic is ignored on the sv passed in, but will be called on
+C<SvRV(sv)> if sv is an RV.
+=cut
+*/
+IO*
+Perl_sv_2io(pTHX_ SV *const sv)
+{
+IO* io;
+GV* gv;
+PERL_ARGS_ASSERT_SV_2IO;
+switch (SvTYPE(sv)) {
+case SVt_PVIO:
+	io = MUTABLE_IO(sv);
+	break;
+case SVt_PVGV:
+case SVt_PVLV:
+	if (isGV_with_GP(sv)) {
+	    gv = MUTABLE_GV(sv);
+	    io = GvIO(gv);
+	    if (!io)
+		Perl_croak(aTHX_ "Bad filehandle: %"HEKf,
+HEKfARG(GvNAME_HEK(gv)));
+	    break;
+	}
+	/* FALLTHROUGH */
+default:
+	if (!SvOK(sv))
+	    Perl_croak(aTHX_ PL_no_usym, "filehandle");
+	if (SvROK(sv)) {
+	    SvGETMAGIC(SvRV(sv));
+	    return sv_2io(SvRV(sv));
+	}
+	gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
+	if (gv)
+	    io = GvIO(gv);
+	else
+	    io = 0;
+	if (!io) {
+	    SV *newsv = sv;
+	    if (SvGMAGICAL(sv)) {
+		newsv = sv_newmortal();
+		sv_setsv_nomg(newsv, sv);
+	    }
+	    Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(newsv));
+	}
+	break;
+}
+return io;
+}
+/*
+=for apidoc sv_2cv
+Using various gambits, try to get a CV from an SV; in addition, try if
+possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
+The flags in C<lref> are passed to gv_fetchsv.
+=cut
+*/
+CV *
+Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
+{
+GV *gv = NULL;
+CV *cv = NULL;
+PERL_ARGS_ASSERT_SV_2CV;
+if (!sv) {
+	*st = NULL;
+	*gvp = NULL;
+	return NULL;
+}
+switch (SvTYPE(sv)) {
+case SVt_PVCV:
+	*st = CvSTASH(sv);
+	*gvp = NULL;
+	return MUTABLE_CV(sv);
+case SVt_PVHV:
+case SVt_PVAV:
+	*st = NULL;
+	*gvp = NULL;
+	return NULL;
+default:
+	SvGETMAGIC(sv);
+	if (SvROK(sv)) {
+	    if (SvAMAGIC(sv))
+		sv = amagic_deref_call(sv, to_cv_amg);
+	    sv = SvRV(sv);
+	    if (SvTYPE(sv) == SVt_PVCV) {
+		cv = MUTABLE_CV(sv);
+		*gvp = NULL;
+		*st = CvSTASH(cv);
+		return cv;
+	    }
+	    else if(SvGETMAGIC(sv), isGV_with_GP(sv))
+		gv = MUTABLE_GV(sv);
+	    else
+		Perl_croak(aTHX_ "Not a subroutine reference");
+	}
+	else if (isGV_with_GP(sv)) {
+	    gv = MUTABLE_GV(sv);
+	}
+	else {
+	    gv = gv_fetchsv_nomg(sv, lref, SVt_PVCV);
+	}
+	*gvp = gv;
+	if (!gv) {
+	    *st = NULL;
+	    return NULL;
+	}
+	/* Some flags to gv_fetchsv mean don't really create the GV  */
+	if (!isGV_with_GP(gv)) {
+	    *st = NULL;
+	    return NULL;
+	}
+	*st = GvESTASH(gv);
+	if (lref & ~GV_ADDMG && !GvCVu(gv)) {
+	    /* XXX this is probably not what they think they're getting.
+	     * It has the same effect as "sub name;", i.e. just a forward
+	     * declaration! */
+	    newSTUB(gv,0);
+	}
+	return GvCVu(gv);
+}
+}
+/*
+=for apidoc sv_true
+Returns true if the SV has a true value by Perl's rules.
+Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
+instead use an in-line version.
+=cut
+*/
+I32
+Perl_sv_true(pTHX_ SV *const sv)
+{
+if (!sv)
+	return 0;
+if (SvPOK(sv)) {
+	const XPV* const tXpv = (XPV*)SvANY(sv);
+	if (tXpv &&
+		(tXpv->xpv_cur > 1 ||
+		(tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
+	    return 1;
+	else
+	    return 0;
+}
+else {
+	if (SvIOK(sv))
+	    return SvIVX(sv) != 0;
+	else {
+	    if (SvNOK(sv))
+		return SvNVX(sv) != 0.0;
+	    else
+		return sv_2bool(sv);
+	}
+}
+}
+/*
+=for apidoc sv_pvn_force
+Get a sensible string out of the SV somehow.
+A private implementation of the C<SvPV_force> macro for compilers which
+can't cope with complex macro expressions.  Always use the macro instead.
+=for apidoc sv_pvn_force_flags
+Get a sensible string out of the SV somehow.
+If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
+appropriate, else not.  C<sv_pvn_force> and C<sv_pvn_force_nomg> are
+implemented in terms of this function.
+You normally want to use the various wrapper macros instead: see
+C<SvPV_force> and C<SvPV_force_nomg>
+=cut
+*/
+char *
+Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
+{
+PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
+if (flags & SV_GMAGIC) SvGETMAGIC(sv);
+if (SvTHINKFIRST(sv) && (!SvROK(sv) || SvREADONLY(sv)))
+sv_force_normal_flags(sv, 0);
+if (SvPOK(sv)) {
+	if (lp)
+	    *lp = SvCUR(sv);
+}
+else {
+	char *s;
+	STRLEN len;
+	if (SvTYPE(sv) > SVt_PVLV
+	    || isGV_with_GP(sv))
+	    /* diag_listed_as: Can't coerce %s to %s in %s */
+	    Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
+		OP_DESC(PL_op));
+	s = sv_2pv_flags(sv, &len, flags &~ SV_GMAGIC);
+	if (!s) {
+	  s = (char *)"";
+	}
+	if (lp)
+	    *lp = len;
+if (SvTYPE(sv) < SVt_PV ||
+s != SvPVX_const(sv)) {	/* Almost, but not quite, sv_setpvn() */
+	    if (SvROK(sv))
+		sv_unref(sv);
+	    SvUPGRADE(sv, SVt_PV);		/* Never FALSE */
+	    SvGROW(sv, len + 1);
+	    Move(s,SvPVX(sv),len,char);
+	    SvCUR_set(sv, len);
+	    SvPVX(sv)[len] = '\0';
+	}
+	if (!SvPOK(sv)) {
+	    SvPOK_on(sv);		/* validate pointer */
+	    SvTAINT(sv);
+	    DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
+				  PTR2UV(sv),SvPVX_const(sv)));
+	}
+}
+(void)SvPOK_only_UTF8(sv);
+return SvPVX_mutable(sv);
+}
+/*
+=for apidoc sv_pvbyten_force
+The backend for the C<SvPVbytex_force> macro.  Always use the macro
+instead.
+=cut
+*/
+char *
+Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
+{
+PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
+sv_pvn_force(sv,lp);
+sv_utf8_downgrade(sv,0);
+*lp = SvCUR(sv);
+return SvPVX(sv);
+}
+/*
+=for apidoc sv_pvutf8n_force
+The backend for the C<SvPVutf8x_force> macro.  Always use the macro
+instead.
+=cut
+*/
+char *
+Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
+{
+PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
+sv_pvn_force(sv,0);
+sv_utf8_upgrade_nomg(sv);
+*lp = SvCUR(sv);
+return SvPVX(sv);
+}
+/*
+=for apidoc sv_reftype
+Returns a string describing what the SV is a reference to.
+=cut
+*/
+const char *
+Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
+{
+PERL_ARGS_ASSERT_SV_REFTYPE;
+if (ob && SvOBJECT(sv)) {
+	return SvPV_nolen_const(sv_ref(NULL, sv, ob));
+}
+else {
+/* WARNING - There is code, for instance in mg.c, that assumes that
+* the only reason that sv_reftype(sv,0) would return a string starting
+* with 'L' or 'S' is that it is a LVALUE or a SCALAR.
+* Yes this a dodgy way to do type checking, but it saves practically reimplementing
+* this routine inside other subs, and it saves time.
+* Do not change this assumption without searching for "dodgy type check" in
+* the code.
+* - Yves */
+	switch (SvTYPE(sv)) {
+	case SVt_NULL:
+	case SVt_IV:
+	case SVt_NV:
+	case SVt_PV:
+	case SVt_PVIV:
+	case SVt_PVNV:
+	case SVt_PVMG:
+				if (SvVOK(sv))
+				    return "VSTRING";
+				if (SvROK(sv))
+				    return "REF";
+				else
+				    return "SCALAR";
+	case SVt_PVLV:		return (char *)  (SvROK(sv) ? "REF"
+				/* tied lvalues should appear to be
+				 * scalars for backwards compatibility */
+				: (isALPHA_FOLD_EQ(LvTYPE(sv), 't'))
+				    ? "SCALAR" : "LVALUE");
+	case SVt_PVAV:		return "ARRAY";
+	case SVt_PVHV:		return "HASH";
+	case SVt_PVCV:		return "CODE";
+	case SVt_PVGV:		return (char *) (isGV_with_GP(sv)
+				    ? "GLOB" : "SCALAR");
+	case SVt_PVFM:		return "FORMAT";
+	case SVt_PVIO:		return "IO";
+	case SVt_INVLIST:	return "INVLIST";
+	case SVt_REGEXP:	return "REGEXP";
+	default:		return "UNKNOWN";
+	}
+}
+}
+/*
+=for apidoc sv_ref
+Returns a SV describing what the SV passed in is a reference to.
+=cut
+*/
+SV *
+Perl_sv_ref(pTHX_ SV *dst, const SV *const sv, const int ob)
+{
+PERL_ARGS_ASSERT_SV_REF;
+if (!dst)
+dst = sv_newmortal();
+if (ob && SvOBJECT(sv)) {
+	HvNAME_get(SvSTASH(sv))
+? sv_sethek(dst, HvNAME_HEK(SvSTASH(sv)))
+: sv_setpvn(dst, "__ANON__", 8);
+}
+else {
+const char * reftype = sv_reftype(sv, 0);
+sv_setpv(dst, reftype);
+}
+return dst;
+}
+/*
+=for apidoc sv_isobject
+Returns a boolean indicating whether the SV is an RV pointing to a blessed
+object.  If the SV is not an RV, or if the object is not blessed, then this
+will return false.
+=cut
+*/
+int
+Perl_sv_isobject(pTHX_ SV *sv)
+{
+if (!sv)
+	return 0;
+SvGETMAGIC(sv);
+if (!SvROK(sv))
+	return 0;
+sv = SvRV(sv);
+if (!SvOBJECT(sv))
+	return 0;
+return 1;
+}
+/*
+=for apidoc sv_isa
+Returns a boolean indicating whether the SV is blessed into the specified
+class.  This does not check for subtypes; use C<sv_derived_from> to verify
+an inheritance relationship.
+=cut
+*/
+int
+Perl_sv_isa(pTHX_ SV *sv, const char *const name)
+{
+const char *hvname;
+PERL_ARGS_ASSERT_SV_ISA;
+if (!sv)
+	return 0;
+SvGETMAGIC(sv);
+if (!SvROK(sv))
+	return 0;
+sv = SvRV(sv);
+if (!SvOBJECT(sv))
+	return 0;
+hvname = HvNAME_get(SvSTASH(sv));
+if (!hvname)
+	return 0;
+return strEQ(hvname, name);
+}
+/*
+=for apidoc newSVrv
+Creates a new SV for the existing RV, C<rv>, to point to.  If C<rv> is not an
+RV then it will be upgraded to one.  If C<classname> is non-null then the new
+SV will be blessed in the specified package.  The new SV is returned and its
+reference count is 1.  The reference count 1 is owned by C<rv>.
+=cut
+*/
+SV*
+Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
+{
+SV *sv;
+PERL_ARGS_ASSERT_NEWSVRV;
+new_SV(sv);
+SV_CHECK_THINKFIRST_COW_DROP(rv);
+if (UNLIKELY( SvTYPE(rv) >= SVt_PVMG )) {
+	const U32 refcnt = SvREFCNT(rv);
+	SvREFCNT(rv) = 0;
+	sv_clear(rv);
+	SvFLAGS(rv) = 0;
+	SvREFCNT(rv) = refcnt;
+	sv_upgrade(rv, SVt_IV);
+} else if (SvROK(rv)) {
+	SvREFCNT_dec(SvRV(rv));
+} else {
+	prepare_SV_for_RV(rv);
+}
+SvOK_off(rv);
+SvRV_set(rv, sv);
+SvROK_on(rv);
+if (classname) {
+	HV* const stash = gv_stashpv(classname, GV_ADD);
+	(void)sv_bless(rv, stash);
+}
+return sv;
+}
+SV *
+Perl_newSVavdefelem(pTHX_ AV *av, SSize_t ix, bool extendible)
+{
+SV * const lv = newSV_type(SVt_PVLV);
+PERL_ARGS_ASSERT_NEWSVAVDEFELEM;
+LvTYPE(lv) = 'y';
+sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
+LvTARG(lv) = SvREFCNT_inc_simple_NN(av);
+LvSTARGOFF(lv) = ix;
+LvTARGLEN(lv) = extendible ? 1 : (STRLEN)UV_MAX;
+return lv;
+}
+/*
+=for apidoc sv_setref_pv
+Copies a pointer into a new SV, optionally blessing the SV.  The C<rv>
+argument will be upgraded to an RV.  That RV will be modified to point to
+the new SV.  If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
+into the SV.  The C<classname> argument indicates the package for the
+blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
+will have a reference count of 1, and the RV will be returned.
+Do not use with other Perl types such as HV, AV, SV, CV, because those
+objects will become corrupted by the pointer copy process.
+Note that C<sv_setref_pvn> copies the string while this copies the pointer.
+=cut
+*/
+SV*
+Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
+{
+PERL_ARGS_ASSERT_SV_SETREF_PV;
+if (!pv) {
+	sv_setsv(rv, &PL_sv_undef);
+	SvSETMAGIC(rv);
+}
+else
+	sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
+return rv;
+}
+/*
+=for apidoc sv_setref_iv
+Copies an integer into a new SV, optionally blessing the SV.  The C<rv>
+argument will be upgraded to an RV.  That RV will be modified to point to
+the new SV.  The C<classname> argument indicates the package for the
+blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
+will have a reference count of 1, and the RV will be returned.
+=cut
+*/
+SV*
+Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
+{
+PERL_ARGS_ASSERT_SV_SETREF_IV;
+sv_setiv(newSVrv(rv,classname), iv);
+return rv;
+}
+/*
+=for apidoc sv_setref_uv
+Copies an unsigned integer into a new SV, optionally blessing the SV.  The C<rv>
+argument will be upgraded to an RV.  That RV will be modified to point to
+the new SV.  The C<classname> argument indicates the package for the
+blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
+will have a reference count of 1, and the RV will be returned.
+=cut
+*/
+SV*
+Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
+{
+PERL_ARGS_ASSERT_SV_SETREF_UV;
+sv_setuv(newSVrv(rv,classname), uv);
+return rv;
+}
+/*
+=for apidoc sv_setref_nv
+Copies a double into a new SV, optionally blessing the SV.  The C<rv>
+argument will be upgraded to an RV.  That RV will be modified to point to
+the new SV.  The C<classname> argument indicates the package for the
+blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
+will have a reference count of 1, and the RV will be returned.
+=cut
+*/
+SV*
+Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
+{
+PERL_ARGS_ASSERT_SV_SETREF_NV;
+sv_setnv(newSVrv(rv,classname), nv);
+return rv;
+}
+/*
+=for apidoc sv_setref_pvn
+Copies a string into a new SV, optionally blessing the SV.  The length of the
+string must be specified with C<n>.  The C<rv> argument will be upgraded to
+an RV.  That RV will be modified to point to the new SV.  The C<classname>
+argument indicates the package for the blessing.  Set C<classname> to
+C<NULL> to avoid the blessing.  The new SV will have a reference count
+of 1, and the RV will be returned.
+Note that C<sv_setref_pv> copies the pointer while this copies the string.
+=cut
+*/
+SV*
+Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
+const char *const pv, const STRLEN n)
+{
+PERL_ARGS_ASSERT_SV_SETREF_PVN;
+sv_setpvn(newSVrv(rv,classname), pv, n);
+return rv;
+}
+/*
+=for apidoc sv_bless
+Blesses an SV into a specified package.  The SV must be an RV.  The package
+must be designated by its stash (see C<gv_stashpv()>).  The reference count
+of the SV is unaffected.
+=cut
+*/
+SV*
+Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
+{
+SV *tmpRef;
+HV *oldstash = NULL;
+PERL_ARGS_ASSERT_SV_BLESS;
+SvGETMAGIC(sv);
+if (!SvROK(sv))
+Perl_croak(aTHX_ "Can't bless non-reference value");
+tmpRef = SvRV(sv);
+if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY|SVf_PROTECT)) {
+	if (SvREADONLY(tmpRef))
+	    Perl_croak_no_modify();
+	if (SvOBJECT(tmpRef)) {
+	    oldstash = SvSTASH(tmpRef);
+	}
+}
+SvOBJECT_on(tmpRef);
+SvUPGRADE(tmpRef, SVt_PVMG);
+SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
+SvREFCNT_dec(oldstash);
+if(SvSMAGICAL(tmpRef))
+if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
+mg_set(tmpRef);
+return sv;
+}
+/* Downgrades a PVGV to a PVMG. If it's actually a PVLV, we leave the type
+* as it is after unglobbing it.
+*/
+PERL_STATIC_INLINE void
+S_sv_unglob(pTHX_ SV *const sv, U32 flags)
+{
+void *xpvmg;
+HV *stash;
+SV * const temp = flags & SV_COW_DROP_PV ? NULL : sv_newmortal();
+PERL_ARGS_ASSERT_SV_UNGLOB;
+assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV);
+SvFAKE_off(sv);
+if (!(flags & SV_COW_DROP_PV))
+	gv_efullname3(temp, MUTABLE_GV(sv), "*");
+SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
+if (GvGP(sv)) {
+if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
+	   && HvNAME_get(stash))
+mro_method_changed_in(stash);
+	gp_free(MUTABLE_GV(sv));
+}
+if (GvSTASH(sv)) {
+	sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv);
+	GvSTASH(sv) = NULL;
+}
+GvMULTI_off(sv);
+if (GvNAME_HEK(sv)) {
+	unshare_hek(GvNAME_HEK(sv));
+}
+isGV_with_GP_off(sv);
+if(SvTYPE(sv) == SVt_PVGV) {
+	/* need to keep SvANY(sv) in the right arena */
+	xpvmg = new_XPVMG();
+	StructCopy(SvANY(sv), xpvmg, XPVMG);
+	del_XPVGV(SvANY(sv));
+	SvANY(sv) = xpvmg;
+	SvFLAGS(sv) &= ~SVTYPEMASK;
+	SvFLAGS(sv) |= SVt_PVMG;
+}
+/* Intentionally not calling any local SET magic, as this isn't so much a
+set operation as merely an internal storage change.  */
+if (flags & SV_COW_DROP_PV) SvOK_off(sv);
+else sv_setsv_flags(sv, temp, 0);
+if ((const GV *)sv == PL_last_in_gv)
+	PL_last_in_gv = NULL;
+else if ((const GV *)sv == PL_statgv)
+	PL_statgv = NULL;
+}
+/*
+=for apidoc sv_unref_flags
+Unsets the RV status of the SV, and decrements the reference count of
+whatever was being referenced by the RV.  This can almost be thought of
+as a reversal of C<newSVrv>.  The C<cflags> argument can contain
+C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
+(otherwise the decrementing is conditional on the reference count being
+different from one or the reference being a readonly SV).
+See C<SvROK_off>.
+=cut
+*/
+void
+Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
+{
+SV* const target = SvRV(ref);
+PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
+if (SvWEAKREF(ref)) {
+	sv_del_backref(target, ref);
+	SvWEAKREF_off(ref);
+	SvRV_set(ref, NULL);
+	return;
+}
+SvRV_set(ref, NULL);
+SvROK_off(ref);
+/* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
+assigned to as BEGIN {$a = \"Foo"} will fail.  */
+if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
+	SvREFCNT_dec_NN(target);
+else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
+	sv_2mortal(target);	/* Schedule for freeing later */
+}
+/*
+=for apidoc sv_untaint
+Untaint an SV.  Use C<SvTAINTED_off> instead.
+=cut
+*/
+void
+Perl_sv_untaint(pTHX_ SV *const sv)
+{
+PERL_ARGS_ASSERT_SV_UNTAINT;
+PERL_UNUSED_CONTEXT;
+if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+	MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
+	if (mg)
+	    mg->mg_len &= ~1;
+}
+}
+/*
+=for apidoc sv_tainted
+Test an SV for taintedness.  Use C<SvTAINTED> instead.
+=cut
+*/
+bool
+Perl_sv_tainted(pTHX_ SV *const sv)
+{
+PERL_ARGS_ASSERT_SV_TAINTED;
+PERL_UNUSED_CONTEXT;
+if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+	const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
+	if (mg && (mg->mg_len & 1) )
+	    return TRUE;
+}
+return FALSE;
+}
+/*
+=for apidoc sv_setpviv
+Copies an integer into the given SV, also updating its string value.
+Does not handle 'set' magic.  See C<sv_setpviv_mg>.
+=cut
+*/
+void
+Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
+{
+char buf[TYPE_CHARS(UV)];
+char *ebuf;
+char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
+PERL_ARGS_ASSERT_SV_SETPVIV;
+sv_setpvn(sv, ptr, ebuf - ptr);
+}
+/*
+=for apidoc sv_setpviv_mg
+Like C<sv_setpviv>, but also handles 'set' magic.
+=cut
+*/
+void
+Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
+{
+PERL_ARGS_ASSERT_SV_SETPVIV_MG;
+sv_setpviv(sv, iv);
+SvSETMAGIC(sv);
+}
+#if defined(PERL_IMPLICIT_CONTEXT)
+/* pTHX_ magic can't cope with varargs, so this is a no-context
+* version of the main function, (which may itself be aliased to us).
+* Don't access this version directly.
+*/
+void
+Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
+{
+dTHX;
+va_list args;
+PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
+va_start(args, pat);
+sv_vsetpvf(sv, pat, &args);
+va_end(args);
+}
+/* pTHX_ magic can't cope with varargs, so this is a no-context
+* version of the main function, (which may itself be aliased to us).
+* Don't access this version directly.
+*/
+void
+Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
+{
+dTHX;
+va_list args;
+PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
+va_start(args, pat);
+sv_vsetpvf_mg(sv, pat, &args);
+va_end(args);
+}
+#endif
+/*
+=for apidoc sv_setpvf
+Works like C<sv_catpvf> but copies the text into the SV instead of
+appending it.  Does not handle 'set' magic.  See C<sv_setpvf_mg>.
+=cut
+*/
+void
+Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
+{
+va_list args;
+PERL_ARGS_ASSERT_SV_SETPVF;
+va_start(args, pat);
+sv_vsetpvf(sv, pat, &args);
+va_end(args);
+}
+/*
+=for apidoc sv_vsetpvf
+Works like C<sv_vcatpvf> but copies the text into the SV instead of
+appending it.  Does not handle 'set' magic.  See C<sv_vsetpvf_mg>.
+Usually used via its frontend C<sv_setpvf>.
+=cut
+*/
+void
+Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
+{
+PERL_ARGS_ASSERT_SV_VSETPVF;
+sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
+}
+/*
+=for apidoc sv_setpvf_mg
+Like C<sv_setpvf>, but also handles 'set' magic.
+=cut
+*/
+void
+Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
+{
+va_list args;
+PERL_ARGS_ASSERT_SV_SETPVF_MG;
+va_start(args, pat);
+sv_vsetpvf_mg(sv, pat, &args);
+va_end(args);
+}
+/*
+=for apidoc sv_vsetpvf_mg
+Like C<sv_vsetpvf>, but also handles 'set' magic.
+Usually used via its frontend C<sv_setpvf_mg>.
+=cut
+*/
+void
+Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
+{
+PERL_ARGS_ASSERT_SV_VSETPVF_MG;
+sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
+SvSETMAGIC(sv);
+}
+#if defined(PERL_IMPLICIT_CONTEXT)
+/* pTHX_ magic can't cope with varargs, so this is a no-context
+* version of the main function, (which may itself be aliased to us).
+* Don't access this version directly.
+*/
+void
+Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
+{
+dTHX;
+va_list args;
+PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
+va_start(args, pat);
+sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
+va_end(args);
+}
+/* pTHX_ magic can't cope with varargs, so this is a no-context
+* version of the main function, (which may itself be aliased to us).
+* Don't access this version directly.
+*/
+void
+Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
+{
+dTHX;
+va_list args;
+PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
+va_start(args, pat);
+sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
+SvSETMAGIC(sv);
+va_end(args);
+}
+#endif
+/*
+=for apidoc sv_catpvf
+Processes its arguments like C<sprintf> and appends the formatted
+output to an SV.  If the appended data contains "wide" characters
+(including, but not limited to, SVs with a UTF-8 PV formatted with %s,
+and characters >255 formatted with %c), the original SV might get
+upgraded to UTF-8.  Handles 'get' magic, but not 'set' magic.  See
+C<sv_catpvf_mg>.  If the original SV was UTF-8, the pattern should be
+valid UTF-8; if the original SV was bytes, the pattern should be too.
+=cut */
+void
+Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
+{
+va_list args;
+PERL_ARGS_ASSERT_SV_CATPVF;
+va_start(args, pat);
+sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
+va_end(args);
+}
+/*
+=for apidoc sv_vcatpvf
+Processes its arguments like C<vsprintf> and appends the formatted output
+to an SV.  Does not handle 'set' magic.  See C<sv_vcatpvf_mg>.
+Usually used via its frontend C<sv_catpvf>.
+=cut
+*/
+void
+Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
+{
+PERL_ARGS_ASSERT_SV_VCATPVF;
+sv_vcatpvfn_flags(sv, pat, strlen(pat), args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
+}
+/*
+=for apidoc sv_catpvf_mg
+Like C<sv_catpvf>, but also handles 'set' magic.
+=cut
+*/
+void
+Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
+{
+va_list args;
+PERL_ARGS_ASSERT_SV_CATPVF_MG;
+va_start(args, pat);
+sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
+SvSETMAGIC(sv);
+va_end(args);
+}
+/*
+=for apidoc sv_vcatpvf_mg
+Like C<sv_vcatpvf>, but also handles 'set' magic.
+Usually used via its frontend C<sv_catpvf_mg>.
+=cut
+*/
+void
+Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
+{
+PERL_ARGS_ASSERT_SV_VCATPVF_MG;
+sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
+SvSETMAGIC(sv);
+}
+/*
+=for apidoc sv_vsetpvfn
+Works like C<sv_vcatpvfn> but copies the text into the SV instead of
+appending it.
+Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
+=cut
+*/
+void
+Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
+va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
+{
+PERL_ARGS_ASSERT_SV_VSETPVFN;
+sv_setpvs(sv, "");
+sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, 0);
+}
+/*
+* Warn of missing argument to sprintf, and then return a defined value
+* to avoid inappropriate "use of uninit" warnings [perl #71000].
+*/
+STATIC SV*
+S_vcatpvfn_missing_argument(pTHX) {
+if (ckWARN(WARN_MISSING)) {
+	Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s",
+		PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
+}
+return &PL_sv_no;
+}
+STATIC I32
+S_expect_number(pTHX_ char **const pattern)
+{
+I32 var = 0;
+PERL_ARGS_ASSERT_EXPECT_NUMBER;
+switch (**pattern) {
+case '1': case '2': case '3':
+case '4': case '5': case '6':
+case '7': case '8': case '9':
+	var = *(*pattern)++ - '0';
+	while (isDIGIT(**pattern)) {
+	    const I32 tmp = var * 10 + (*(*pattern)++ - '0');
+	    if (tmp < var)
+		Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn"));
+	    var = tmp;
+	}
+}
+return var;
+}
+STATIC char *
+S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
+{
+const int neg = nv < 0;
+UV uv;
+PERL_ARGS_ASSERT_F0CONVERT;
+if (UNLIKELY(Perl_isinfnan(nv))) {
+STRLEN n = S_infnan_2pv(nv, endbuf - *len, *len, 0);
+*len = n;
+return endbuf - n;
+}
+if (neg)
+	nv = -nv;
+if (nv < UV_MAX) {
+	char *p = endbuf;
+	nv += 0.5;
+	uv = (UV)nv;
+	if (uv & 1 && uv == nv)
+	    uv--;			/* Round to even */
+	do {
+	    const unsigned dig = uv % 10;
+	    *--p = '0' + dig;
+	} while (uv /= 10);
+	if (neg)
+	    *--p = '-';
+	*len = endbuf - p;
+	return p;
+}
+return NULL;
+}
+/*
+=for apidoc sv_vcatpvfn
+=for apidoc sv_vcatpvfn_flags
+Processes its arguments like C<vsprintf> and appends the formatted output
+to an SV.  Uses an array of SVs if the C style variable argument list is
+missing (NULL).  When running with taint checks enabled, indicates via
+C<maybe_tainted> if results are untrustworthy (often due to the use of
+locales).
+If called as C<sv_vcatpvfn> or flags include C<SV_GMAGIC>, calls get magic.
+Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
+=cut
+*/
+#define VECTORIZE_ARGS	vecsv = va_arg(*args, SV*);\
+			vecstr = (U8*)SvPV_const(vecsv,veclen);\
+			vec_utf8 = DO_UTF8(vecsv);
+/* XXX maybe_tainted is never assigned to, so the doc above is lying. */
+void
+Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
+va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
+{
+PERL_ARGS_ASSERT_SV_VCATPVFN;
+sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, SV_GMAGIC|SV_SMAGIC);
+}
+#ifdef LONGDOUBLE_DOUBLEDOUBLE
+/* The first double can be as large as 2**1023, or '1' x '0' x 1023.
+* The second double can be as small as 2**-1074, or '0' x 1073 . '1'.
+* The sum of them can be '1' . '0' x 2096 . '1', with implied radix point
+* after the first 1023 zero bits.
+*
+* XXX The 2098 is quite large (262.25 bytes) and therefore some sort
+* of dynamically growing buffer might be better, start at just 16 bytes
+* (for example) and grow only when necessary.  Or maybe just by looking
+* at the exponents of the two doubles? */
+#  define DOUBLEDOUBLE_MAXBITS 2098
+#endif
+/* vhex will contain the values (0..15) of the hex digits ("nybbles"
+* of 4 bits); 1 for the implicit 1, and the mantissa bits, four bits
+* per xdigit.  For the double-double case, this can be rather many.
+* The non-double-double-long-double overshoots since all bits of NV
+* are not mantissa bits, there are also exponent bits. */
+#ifdef LONGDOUBLE_DOUBLEDOUBLE
+#  define VHEX_SIZE (3+DOUBLEDOUBLE_MAXBITS/4)
+#else
+#  define VHEX_SIZE (1+(NVSIZE * 8)/4)
+#endif
+/* If we do not have a known long double format, (including not using
+* long doubles, or long doubles being equal to doubles) then we will
+* fall back to the ldexp/frexp route, with which we can retrieve at
+* most as many bits as our widest unsigned integer type is.  We try
+* to get a 64-bit unsigned integer even if we are not using a 64-bit UV.
+*
+* (If you want to test the case of UVSIZE == 4, NVSIZE == 8,
+*  set the MANTISSATYPE to int and the MANTISSASIZE to 4.)
+*/
+#if defined(HAS_QUAD) && defined(Uquad_t)
+#  define MANTISSATYPE Uquad_t
+#  define MANTISSASIZE 8
+#else
+#  define MANTISSATYPE UV
+#  define MANTISSASIZE UVSIZE
+#endif
+#if defined(DOUBLE_LITTLE_ENDIAN) || defined(LONGDOUBLE_LITTLE_ENDIAN)
+#  define HEXTRACT_LITTLE_ENDIAN
+#elif defined(DOUBLE_BIG_ENDIAN) || defined(LONGDOUBLE_BIG_ENDIAN)
+#  define HEXTRACT_BIG_ENDIAN
+#else
+#  define HEXTRACT_MIX_ENDIAN
+#endif
+/* S_hextract() is a helper for Perl_sv_vcatpvfn_flags, for extracting
+* the hexadecimal values (for %a/%A).  The nv is the NV where the value
+* are being extracted from (either directly from the long double in-memory
+* presentation, or from the uquad computed via frexp+ldexp).  frexp also
+* is used to update the exponent.  vhex is the pointer to the beginning
+* of the output buffer (of VHEX_SIZE).
+*
+* The tricky part is that S_hextract() needs to be called twice:
+* the first time with vend as NULL, and the second time with vend as
+* the pointer returned by the first call.  What happens is that on
+* the first round the output size is computed, and the intended
+* extraction sanity checked.  On the second round the actual output
+* (the extraction of the hexadecimal values) takes place.
+* Sanity failures cause fatal failures during both rounds. */
+STATIC U8*
+S_hextract(pTHX_ const NV nv, int* exponent, U8* vhex, U8* vend)
+{
+U8* v = vhex;
+int ix;
+int ixmin = 0, ixmax = 0;
+/* XXX Inf/NaN/denormal handling in the HEXTRACT_IMPLICIT_BIT,
+* and elsewhere. */
+/* These macros are just to reduce typos, they have multiple
+* repetitions below, but usually only one (or sometimes two)
+* of them is really being used. */
+/* HEXTRACT_OUTPUT() extracts the high nybble first. */
+#define HEXTRACT_OUTPUT_HI(ix) (*v++ = nvp[ix] >> 4)
+#define HEXTRACT_OUTPUT_LO(ix) (*v++ = nvp[ix] & 0xF)
+#define HEXTRACT_OUTPUT(ix) \
+STMT_START { \
+HEXTRACT_OUTPUT_HI(ix); HEXTRACT_OUTPUT_LO(ix); \
+} STMT_END
+#define HEXTRACT_COUNT(ix, c) \
+STMT_START { \
+v += c; if (ix < ixmin) ixmin = ix; else if (ix > ixmax) ixmax = ix; \
+} STMT_END
+#define HEXTRACT_BYTE(ix) \
+STMT_START { \
+if (vend) HEXTRACT_OUTPUT(ix); else HEXTRACT_COUNT(ix, 2); \
+} STMT_END
+#define HEXTRACT_LO_NYBBLE(ix) \
+STMT_START { \
+if (vend) HEXTRACT_OUTPUT_LO(ix); else HEXTRACT_COUNT(ix, 1); \
+} STMT_END
+/* HEXTRACT_TOP_NYBBLE is just convenience disguise,
+* to make it look less odd when the top bits of a NV
+* are extracted using HEXTRACT_LO_NYBBLE: the highest
+* order bits can be in the "low nybble" of a byte. */
+#define HEXTRACT_TOP_NYBBLE(ix) HEXTRACT_LO_NYBBLE(ix)
+#define HEXTRACT_BYTES_LE(a, b) \
+for (ix = a; ix >= b; ix--) { HEXTRACT_BYTE(ix); }
+#define HEXTRACT_BYTES_BE(a, b) \
+for (ix = a; ix <= b; ix++) { HEXTRACT_BYTE(ix); }
+#define HEXTRACT_IMPLICIT_BIT(nv) \
+STMT_START { \
+if (vend) *v++ = ((nv) == 0.0) ? 0 : 1; else v++; \
+} STMT_END
+/* Most formats do.  Those which don't should undef this. */
+#define HEXTRACT_HAS_IMPLICIT_BIT
+/* Many formats do.  Those which don't should undef this. */
+#define HEXTRACT_HAS_TOP_NYBBLE
+/* HEXTRACTSIZE is the maximum number of xdigits. */
+#if defined(USE_LONG_DOUBLE) && defined(LONGDOUBLE_DOUBLEDOUBLE)
+#  define HEXTRACTSIZE (2+DOUBLEDOUBLE_MAXBITS/4)
+#else
+#  define HEXTRACTSIZE 2 * NVSIZE
+#endif
+const U8* vmaxend = vhex + HEXTRACTSIZE;
+PERL_UNUSED_VAR(ix); /* might happen */
+(void)Perl_frexp(PERL_ABS(nv), exponent);
+if (vend && (vend <= vhex || vend > vmaxend)) {
+/* diag_listed_as: Hexadecimal float: internal error (%s) */
+Perl_croak(aTHX_ "Hexadecimal float: internal error (entry)");
+}
+{
+/* First check if using long doubles. */
+#if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE)
+#  if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN
+/* Used in e.g. VMS and HP-UX IA-64, e.g. -0.1L:
+* 9a 99 99 99 99 99 99 99 99 99 99 99 99 99 fb 3f */
+/* The bytes 13..0 are the mantissa/fraction,
+* the 15,14 are the sign+exponent. */
+const U8* nvp = (const U8*)(&nv);
+HEXTRACT_IMPLICIT_BIT(nv);
+#   undef HEXTRACT_HAS_TOP_NYBBLE
+HEXTRACT_BYTES_LE(13, 0);
+#  elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN
+/* Used in e.g. Solaris Sparc and HP-UX PA-RISC, e.g. -0.1L:
+* bf fb 99 99 99 99 99 99 99 99 99 99 99 99 99 9a */
+/* The bytes 2..15 are the mantissa/fraction,
+* the 0,1 are the sign+exponent. */
+const U8* nvp = (const U8*)(&nv);
+HEXTRACT_IMPLICIT_BIT(nv);
+#   undef HEXTRACT_HAS_TOP_NYBBLE
+HEXTRACT_BYTES_BE(2, 15);
+#  elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN
+/* x86 80-bit "extended precision", 64 bits of mantissa / fraction /
+* significand, 15 bits of exponent, 1 bit of sign.  NVSIZE can
+* be either 12 (ILP32, Solaris x86) or 16 (LP64, Linux and OS X),
+* meaning that 2 or 6 bytes are empty padding. */
+/* The bytes 7..0 are the mantissa/fraction */
+const U8* nvp = (const U8*)(&nv);
+#    undef HEXTRACT_HAS_IMPLICIT_BIT
+#    undef HEXTRACT_HAS_TOP_NYBBLE
+HEXTRACT_BYTES_LE(7, 0);
+#  elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN
+/* Does this format ever happen? (Wikipedia says the Motorola
+* 6888x math coprocessors used format _like_ this but padded
+* to 96 bits with 16 unused bits between the exponent and the
+* mantissa.) */
+const U8* nvp = (const U8*)(&nv);
+#    undef HEXTRACT_HAS_IMPLICIT_BIT
+#    undef HEXTRACT_HAS_TOP_NYBBLE
+HEXTRACT_BYTES_BE(0, 7);
+#  else
+#    define HEXTRACT_FALLBACK
+/* Double-double format: two doubles next to each other.
+* The first double is the high-order one, exactly like
+* it would be for a "lone" double.  The second double
+* is shifted down using the exponent so that that there
+* are no common bits.  The tricky part is that the value
+* of the double-double is the SUM of the two doubles and
+* the second one can be also NEGATIVE.
+*
+* Because of this tricky construction the bytewise extraction we
+* use for the other long double formats doesn't work, we must
+* extract the values bit by bit.
+*
+* The little-endian double-double is used .. somewhere?
+*
+* The big endian double-double is used in e.g. PPC/Power (AIX)
+* and MIPS (SGI).
+*
+* The mantissa bits are in two separate stretches, e.g. for -0.1L:
+* 9a 99 99 99 99 99 59 bc 9a 99 99 99 99 99 b9 3f (LE)
+* 3f b9 99 99 99 99 99 9a bc 59 99 99 99 99 99 9a (BE)
+*/
+#  endif
+#else /* #if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE) */
+/* Using normal doubles, not long doubles.
+*
+* We generate 4-bit xdigits (nybble/nibble) instead of 8-bit
+* bytes, since we might need to handle printf precision, and
+* also need to insert the radix. */
+#  if NVSIZE == 8
+#    ifdef HEXTRACT_LITTLE_ENDIAN
+/* 0 1 2 3 4 5 6 7 (MSB = 7, LSB = 0, 6+7 = exponent+sign) */
+const U8* nvp = (const U8*)(&nv);
+HEXTRACT_IMPLICIT_BIT(nv);
+HEXTRACT_TOP_NYBBLE(6);
+HEXTRACT_BYTES_LE(5, 0);
+#    elif defined(HEXTRACT_BIG_ENDIAN)
+/* 7 6 5 4 3 2 1 0 (MSB = 7, LSB = 0, 6+7 = exponent+sign) */
+const U8* nvp = (const U8*)(&nv);
+HEXTRACT_IMPLICIT_BIT(nv);
+HEXTRACT_TOP_NYBBLE(1);
+HEXTRACT_BYTES_BE(2, 7);
+#    elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_LE_BE
+/* 4 5 6 7 0 1 2 3 (MSB = 7, LSB = 0, 6:7 = nybble:exponent:sign) */
+const U8* nvp = (const U8*)(&nv);
+HEXTRACT_IMPLICIT_BIT(nv);
+HEXTRACT_TOP_NYBBLE(2); /* 6 */
+HEXTRACT_BYTE(1); /* 5 */
+HEXTRACT_BYTE(0); /* 4 */
+HEXTRACT_BYTE(7); /* 3 */
+HEXTRACT_BYTE(6); /* 2 */
+HEXTRACT_BYTE(5); /* 1 */
+HEXTRACT_BYTE(4); /* 0 */
+#    elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_BE_LE
+/* 3 2 1 0 7 6 5 4 (MSB = 7, LSB = 0, 7:6 = sign:exponent:nybble) */
+const U8* nvp = (const U8*)(&nv);
+HEXTRACT_IMPLICIT_BIT(nv);
+HEXTRACT_TOP_NYBBLE(5); /* 6 */
+HEXTRACT_BYTE(6); /* 5 */
+HEXTRACT_BYTE(7); /* 4 */
+HEXTRACT_BYTE(0); /* 3 */
+HEXTRACT_BYTE(1); /* 2 */
+HEXTRACT_BYTE(2); /* 1 */
+HEXTRACT_BYTE(3); /* 0 */
+#    else
+#      define HEXTRACT_FALLBACK
+#    endif
+#  else
+#    define HEXTRACT_FALLBACK
+#  endif
+#endif /* #if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE) #else */
+#  ifdef HEXTRACT_FALLBACK
+#    undef HEXTRACT_HAS_TOP_NYBBLE /* Meaningless, but consistent. */
+/* The fallback is used for the double-double format, and
+* for unknown long double formats, and for unknown double
+* formats, or in general unknown NV formats. */
+if (nv == (NV)0.0) {
+if (vend)
+*v++ = 0;
+else
+v++;
+*exponent = 0;
+}
+else {
+NV d = nv < 0 ? -nv : nv;
+NV e = (NV)1.0;
+U8 ha = 0x0; /* hexvalue accumulator */
+U8 hd = 0x8; /* hexvalue digit */
+/* Shift d and e (and update exponent) so that e <= d < 2*e,
+* this is essentially manual frexp(). Multiplying by 0.5 and
+* doubling should be lossless in binary floating point. */
+*exponent = 1;
+while (e > d) {
+e *= (NV)0.5;
+(*exponent)--;
+}
+/* Now d >= e */
+while (d >= e + e) {
+e += e;
+(*exponent)++;
+}
+/* Now e <= d < 2*e */
+/* First extract the leading hexdigit (the implicit bit). */
+if (d >= e) {
+d -= e;
+if (vend)
+*v++ = 1;
+else
+v++;
+}
+else {
+if (vend)
+*v++ = 0;
+else
+v++;
+}
+e *= (NV)0.5;
+/* Then extract the remaining hexdigits. */
+while (d > (NV)0.0) {
+if (d >= e) {
+ha |= hd;
+d -= e;
+}
+if (hd == 1) {
+/* Output or count in groups of four bits,
+* that is, when the hexdigit is down to one. */
+if (vend)
+*v++ = ha;
+else
+v++;
+/* Reset the hexvalue. */
+ha = 0x0;
+hd = 0x8;
+}
+else
+hd >>= 1;
+e *= (NV)0.5;
+}
+/* Flush possible pending hexvalue. */
+if (ha) {
+if (vend)
+*v++ = ha;
+else
+v++;
+}
+}
+#  endif
+}
+/* Croak for various reasons: if the output pointer escaped the
+* output buffer, if the extraction index escaped the extraction
+* buffer, or if the ending output pointer didn't match the
+* previously computed value. */
+if (v <= vhex || v - vhex >= VHEX_SIZE ||
+/* For double-double the ixmin and ixmax stay at zero,
+* which is convenient since the HEXTRACTSIZE is tricky
+* for double-double. */
+ixmin < 0 || ixmax >= NVSIZE ||
+(vend && v != vend)) {
+/* diag_listed_as: Hexadecimal float: internal error (%s) */
+Perl_croak(aTHX_ "Hexadecimal float: internal error (overflow)");
+}
+return v;
+}
+void
+Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
+va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted,
+const U32 flags)
+{
+char *p;
+char *q;
+const char *patend;
+STRLEN origlen;
+I32 svix = 0;
+static const char nullstr[] = "(null)";
+SV *argsv = NULL;
+bool has_utf8 = DO_UTF8(sv);    /* has the result utf8? */
+const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
+SV *nsv = NULL;
+/* Times 4: a decimal digit takes more than 3 binary digits.
+* NV_DIG: mantissa takes than many decimal digits.
+* Plus 32: Playing safe. */
+char ebuf[IV_DIG * 4 + NV_DIG + 32];
+bool no_redundant_warning = FALSE; /* did we use any explicit format parameter index? */
+bool hexfp = FALSE; /* hexadecimal floating point? */
+DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
+PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS;
+PERL_UNUSED_ARG(maybe_tainted);
+if (flags & SV_GMAGIC)
+SvGETMAGIC(sv);
+/* no matter what, this is a string now */
+(void)SvPV_force_nomg(sv, origlen);
+/* special-case "", "%s", and "%-p" (SVf - see below) */
+if (patlen == 0) {
+	if (svmax && ckWARN(WARN_REDUNDANT))
+	    Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s",
+			PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
+	return;
+}
+if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
+	if (svmax > 1 && ckWARN(WARN_REDUNDANT))
+	    Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s",
+			PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
+	if (args) {
+	    const char * const s = va_arg(*args, char*);
+	    sv_catpv_nomg(sv, s ? s : nullstr);
+	}
+	else if (svix < svmax) {
+	    /* we want get magic on the source but not the target. sv_catsv can't do that, though */
+	    SvGETMAGIC(*svargs);
+	    sv_catsv_nomg(sv, *svargs);
+	}
+	else
+	    S_vcatpvfn_missing_argument(aTHX);
+	return;
+}
+if (args && patlen == 3 && pat[0] == '%' &&
+		pat[1] == '-' && pat[2] == 'p') {
+	if (svmax > 1 && ckWARN(WARN_REDUNDANT))
+	    Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s",
+			PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
+	argsv = MUTABLE_SV(va_arg(*args, void*));
+	sv_catsv_nomg(sv, argsv);
+	return;
+}
+#if !defined(USE_LONG_DOUBLE) && !defined(USE_QUADMATH)
+/* special-case "%.<number>[gf]" */
+if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
+	 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
+	unsigned digits = 0;
+	const char *pp;
+	pp = pat + 2;
+	while (*pp >= '0' && *pp <= '9')
+	    digits = 10 * digits + (*pp++ - '0');
+	/* XXX: Why do this `svix < svmax` test? Couldn't we just
+	   format the first argument and WARN_REDUNDANT if svmax > 1?
+	   Munged by Nicholas Clark in v5.13.0-209-g95ea86d */
+	if (pp - pat == (int)patlen - 1 && svix < svmax) {
+	    const NV nv = SvNV(*svargs);
+if (LIKELY(!Perl_isinfnan(nv))) {
+if (*pp == 'g') {
+/* Add check for digits != 0 because it seems that some
+gconverts are buggy in this case, and we don't yet have
+a Configure test for this.  */
+if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
+/* 0, point, slack */
+STORE_LC_NUMERIC_SET_TO_NEEDED();
+SNPRINTF_G(nv, ebuf, size, digits);
+sv_catpv_nomg(sv, ebuf);
+if (*ebuf)	/* May return an empty string for digits==0 */
+return;
+}
+} else if (!digits) {
+STRLEN l;
+if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
+sv_catpvn_nomg(sv, p, l);
+return;
+}
+}
+}
+	}
+}
+#endif /* !USE_LONG_DOUBLE */
+if (!args && svix < svmax && DO_UTF8(*svargs))
+	has_utf8 = TRUE;
+patend = (char*)pat + patlen;
+for (p = (char*)pat; p < patend; p = q) {
+	bool alt = FALSE;
+	bool left = FALSE;
+	bool vectorize = FALSE;
+	bool vectorarg = FALSE;
+	bool vec_utf8 = FALSE;
+	char fill = ' ';
+	char plus = 0;
+	char intsize = 0;
+	STRLEN width = 0;
+	STRLEN zeros = 0;
+	bool has_precis = FALSE;
+	STRLEN precis = 0;
+	const I32 osvix = svix;
+	bool is_utf8 = FALSE;  /* is this item utf8?   */
+#ifdef HAS_LDBL_SPRINTF_BUG
+	/* This is to try to fix a bug with irix/nonstop-ux/powerux and
+	   with sfio - Allen <allens@cpan.org> */
+	bool fix_ldbl_sprintf_bug = FALSE;
+#endif
+	char esignbuf[4];
+	U8 utf8buf[UTF8_MAXBYTES+1];
+	STRLEN esignlen = 0;
+	const char *eptr = NULL;
+	const char *fmtstart;
+	STRLEN elen = 0;
+	SV *vecsv = NULL;
+	const U8 *vecstr = NULL;
+	STRLEN veclen = 0;
+	char c = 0;
+	int i;
+	unsigned base = 0;
+	IV iv = 0;
+	UV uv = 0;
+	/* We need a long double target in case HAS_LONG_DOUBLE,
+* even without USE_LONG_DOUBLE, so that we can printf with
+* long double formats, even without NV being long double.
+* But we call the target 'fv' instead of 'nv', since most of
+* the time it is not (most compilers these days recognize
+* "long double", even if only as a synonym for "double").
+	*/
+#if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE && \
+	defined(PERL_PRIgldbl) && !defined(USE_QUADMATH)
+	long double fv;
+#  ifdef Perl_isfinitel
+#    define FV_ISFINITE(x) Perl_isfinitel(x)
+#  endif
+#  define FV_GF PERL_PRIgldbl
+#    if defined(__VMS) && defined(__ia64) && defined(__IEEE_FLOAT)
+/* Work around breakage in OTS$CVT_FLOAT_T_X */
+#      define NV_TO_FV(nv,fv) STMT_START {                   \
+double _dv = nv;  \
+fv = Perl_isnan(_dv) ? LDBL_QNAN : _dv; \
+} STMT_END
+#    else
+#      define NV_TO_FV(nv,fv) (fv)=(nv)
+#    endif
+#else
+	NV fv;
+#  define FV_GF NVgf
+#  define NV_TO_FV(nv,fv) (fv)=(nv)
+#endif
+#ifndef FV_ISFINITE
+#  define FV_ISFINITE(x) Perl_isfinite((NV)(x))
+#endif
+NV nv;
+	STRLEN have;
+	STRLEN need;
+	STRLEN gap;
+	const char *dotstr = ".";
+	STRLEN dotstrlen = 1;
+	I32 efix = 0; /* explicit format parameter index */
+	I32 ewix = 0; /* explicit width index */
+	I32 epix = 0; /* explicit precision index */
+	I32 evix = 0; /* explicit vector index */
+	bool asterisk = FALSE;
+bool infnan = FALSE;
+	/* echo everything up to the next format specification */
+	for (q = p; q < patend && *q != '%'; ++q) ;
+	if (q > p) {
+	    if (has_utf8 && !pat_utf8)
+		sv_catpvn_nomg_utf8_upgrade(sv, p, q - p, nsv);
+	    else
+		sv_catpvn_nomg(sv, p, q - p);
+	    p = q;
+	}
+	if (q++ >= patend)
+	    break;
+	fmtstart = q;
+/*
+We allow format specification elements in this order:
+	\d+\$              explicit format parameter index
+	[-+ 0#]+           flags
+	v|\*(\d+\$)?v      vector with optional (optionally specified) arg
+	0		   flag (as above): repeated to allow "v02"
+	\d+|\*(\d+\$)?     width using optional (optionally specified) arg
+	\.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
+	[hlqLV]            size
+[%bcdefginopsuxDFOUX] format (mandatory)
+*/
+	if (args) {
+/*
+	As of perl5.9.3, printf format checking is on by default.
+	Internally, perl uses %p formats to provide an escape to
+	some extended formatting.  This block deals with those
+	extensions: if it does not match, (char*)q is reset and
+	the normal format processing code is used.
+	Currently defined extensions are:
+		%p		include pointer address (standard)
+		%-p	(SVf)	include an SV (previously %_)
+		%-<num>p	include an SV with precision <num>
+		%2p		include a HEK
+		%3p		include a HEK with precision of 256
+		%4p		char* preceded by utf8 flag and length
+		%<num>p		(where num is 1 or > 4) reserved for future
+				extensions
+	Robin Barker 2005-07-14 (but modified since)
+		%1p	(VDf)	removed.  RMB 2007-10-19
+*/
+	    char* r = q;
+	    bool sv = FALSE;
+	    STRLEN n = 0;
+	    if (*q == '-')
+		sv = *q++;
+	    else if (strnEQ(q, UTF8f, sizeof(UTF8f)-1)) { /* UTF8f */
+		/* The argument has already gone through cBOOL, so the cast
+		   is safe. */
+		is_utf8 = (bool)va_arg(*args, int);
+		elen = va_arg(*args, UV);
+if ((IV)elen < 0) {
+/* check if utf8 length is larger than 0 when cast to IV */
+assert( (IV)elen >= 0 ); /* in DEBUGGING build we want to crash */
+elen= 0; /* otherwise we want to treat this as an empty string */
+}
+		eptr = va_arg(*args, char *);
+		q += sizeof(UTF8f)-1;
+		goto string;
+	    }
+	    n = expect_number(&q);
+	    if (*q++ == 'p') {
+		if (sv) {			/* SVf */
+		    if (n) {
+			precis = n;
+			has_precis = TRUE;
+		    }
+		    argsv = MUTABLE_SV(va_arg(*args, void*));
+		    eptr = SvPV_const(argsv, elen);
+		    if (DO_UTF8(argsv))
+			is_utf8 = TRUE;
+		    goto string;
+		}
+		else if (n==2 || n==3) {	/* HEKf */
+		    HEK * const hek = va_arg(*args, HEK *);
+		    eptr = HEK_KEY(hek);
+		    elen = HEK_LEN(hek);
+		    if (HEK_UTF8(hek)) is_utf8 = TRUE;
+		    if (n==3) precis = 256, has_precis = TRUE;
+		    goto string;
+		}
+		else if (n) {
+		    Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
+				     "internal %%<num>p might conflict with future printf extensions");
+		}
+	    }
+	    q = r;
+	}
+	if ( (width = expect_number(&q)) ) {
+	    if (*q == '$') {
+		++q;
+		efix = width;
+		if (!no_redundant_warning)
+		    /* I've forgotten if it's a better
+		       micro-optimization to always set this or to
+		       only set it if it's unset */
+		    no_redundant_warning = TRUE;
+	    } else {
+		goto gotwidth;
+	    }
+	}
+	/* FLAGS */
+	while (*q) {
+	    switch (*q) {
+	    case ' ':
+	    case '+':
+		if (plus == '+' && *q == ' ') /* '+' over ' ' */
+		    q++;
+		else
+		    plus = *q++;
+		continue;
+	    case '-':
+		left = TRUE;
+		q++;
+		continue;
+	    case '0':
+		fill = *q++;
+		continue;
+	    case '#':
+		alt = TRUE;
+		q++;
+		continue;
+	    default:
+		break;
+	    }
+	    break;
+	}
+tryasterisk:
+	if (*q == '*') {
+	    q++;
+	    if ( (ewix = expect_number(&q)) ) {
+		if (*q++ == '$')
+no_redundant_warning = TRUE;
+else
+		    goto unknown;
+}
+	    asterisk = TRUE;
+	}
+	if (*q == 'v') {
+	    q++;
+	    if (vectorize)
+		goto unknown;
+	    if ((vectorarg = asterisk)) {
+		evix = ewix;
+		ewix = 0;
+		asterisk = FALSE;
+	    }
+	    vectorize = TRUE;
+	    goto tryasterisk;
+	}
+	if (!asterisk)
+	{
+	    if( *q == '0' )
+		fill = *q++;
+	    width = expect_number(&q);
+	}
+	if (vectorize && vectorarg) {
+	    /* vectorizing, but not with the default "." */
+	    if (args)
+		vecsv = va_arg(*args, SV*);
+	    else if (evix) {
+		vecsv = (evix > 0 && evix <= svmax)
+		    ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX);
+	    } else {
+		vecsv = svix < svmax
+		    ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
+	    }
+	    dotstr = SvPV_const(vecsv, dotstrlen);
+	    /* Keep the DO_UTF8 test *after* the SvPV call, else things go
+	       bad with tied or overloaded values that return UTF8.  */
+	    if (DO_UTF8(vecsv))
+		is_utf8 = TRUE;
+	    else if (has_utf8) {
+		vecsv = sv_mortalcopy(vecsv);
+		sv_utf8_upgrade(vecsv);
+		dotstr = SvPV_const(vecsv, dotstrlen);
+		is_utf8 = TRUE;
+	    }
+	}
+	if (asterisk) {
+	    if (args)
+		i = va_arg(*args, int);
+	    else
+		i = (ewix ? ewix <= svmax : svix < svmax) ?
+		    SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
+	    left |= (i < 0);
+	    width = (i < 0) ? -i : i;
+	}
+gotwidth:
+	/* PRECISION */
+	if (*q == '.') {
+	    q++;
+	    if (*q == '*') {
+		q++;
+		if ( ((epix = expect_number(&q))) && (*q++ != '$') )
+		    goto unknown;
+		/* XXX: todo, support specified precision parameter */
+		if (epix)
+		    goto unknown;
+		if (args)
+		    i = va_arg(*args, int);
+		else
+		    i = (ewix ? ewix <= svmax : svix < svmax)
+			? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
+		precis = i;
+		has_precis = !(i < 0);
+	    }
+	    else {
+		precis = 0;
+		while (isDIGIT(*q))
+		    precis = precis * 10 + (*q++ - '0');
+		has_precis = TRUE;
+	    }
+	}
+	if (vectorize) {
+	    if (args) {
+		VECTORIZE_ARGS
+	    }
+	    else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
+		vecsv = svargs[efix ? efix-1 : svix++];
+		vecstr = (U8*)SvPV_const(vecsv,veclen);
+		vec_utf8 = DO_UTF8(vecsv);
+		/* if this is a version object, we need to convert
+		 * back into v-string notation and then let the
+		 * vectorize happen normally
+		 */
+		if (sv_isobject(vecsv) && sv_derived_from(vecsv, "version")) {
+		    if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
+			Perl_ck_warner_d(aTHX_ packWARN(WARN_PRINTF),
+			"vector argument not supported with alpha versions");
+			goto vdblank;
+		    }
+		    vecsv = sv_newmortal();
+		    scan_vstring((char *)vecstr, (char *)vecstr + veclen,
+				 vecsv);
+		    vecstr = (U8*)SvPV_const(vecsv, veclen);
+		    vec_utf8 = DO_UTF8(vecsv);
+		}
+	    }
+	    else {
+	      vdblank:
+		vecstr = (U8*)"";
+		veclen = 0;
+	    }
+	}
+	/* SIZE */
+	switch (*q) {
+#ifdef WIN32
+	case 'I':			/* Ix, I32x, and I64x */
+#  ifdef USE_64_BIT_INT
+	    if (q[1] == '6' && q[2] == '4') {
+		q += 3;
+		intsize = 'q';
+		break;
+	    }
+#  endif
+	    if (q[1] == '3' && q[2] == '2') {
+		q += 3;
+		break;
+	    }
+#  ifdef USE_64_BIT_INT
+	    intsize = 'q';
+#  endif
+	    q++;
+	    break;
+#endif
+#if (IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)) || \
+(IVSIZE == 4 && !defined(HAS_LONG_DOUBLE))
+	case 'L':			/* Ld */
+	    /* FALLTHROUGH */
+#  ifdef USE_QUADMATH
+case 'Q':
+	    /* FALLTHROUGH */
+#  endif
+#  if IVSIZE >= 8
+	case 'q':			/* qd */
+#  endif
+	    intsize = 'q';
+	    q++;
+	    break;
+#endif
+	case 'l':
+	    ++q;
+#if (IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)) || \
+(IVSIZE == 4 && !defined(HAS_LONG_DOUBLE))
+	    if (*q == 'l') {	/* lld, llf */
+		intsize = 'q';
+		++q;
+	    }
+	    else
+#endif
+		intsize = 'l';
+	    break;
+	case 'h':
+	    if (*++q == 'h') {	/* hhd, hhu */
+		intsize = 'c';
+		++q;
+	    }
+	    else
+		intsize = 'h';
+	    break;
+	case 'V':
+	case 'z':
+	case 't':
+#ifdef I_STDINT
+case 'j':
+#endif
+	    intsize = *q++;
+	    break;
+	}
+	/* CONVERSION */
+	if (*q == '%') {
+	    eptr = q++;
+	    elen = 1;
+	    if (vectorize) {
+		c = '%';
+		goto unknown;
+	    }
+	    goto string;
+	}
+	if (!vectorize && !args) {
+	    if (efix) {
+		const I32 i = efix-1;
+		argsv = (i >= 0 && i < svmax)
+		    ? svargs[i] : S_vcatpvfn_missing_argument(aTHX);
+	    } else {
+		argsv = (svix >= 0 && svix < svmax)
+		    ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
+	    }
+	}
+if (argsv && strchr("BbcDdiOopuUXx",*q)) {
+/* XXX va_arg(*args) case? need peek, use va_copy? */
+SvGETMAGIC(argsv);
+if (UNLIKELY(SvAMAGIC(argsv)))
+argsv = sv_2num(argsv);
+infnan = UNLIKELY(isinfnansv(argsv));
+}
+	switch (c = *q++) {
+	    /* STRINGS */
+	case 'c':
+	    if (vectorize)
+		goto unknown;
+if (infnan)
+Perl_croak(aTHX_ "Cannot printf %"NVgf" with '%c'",
+/* no va_arg() case */
+SvNV_nomg(argsv), (int)c);
+	    uv = (args) ? va_arg(*args, int) : SvIV_nomg(argsv);
+	    if ((uv > 255 ||
+		 (!UVCHR_IS_INVARIANT(uv) && SvUTF8(sv)))
+		&& !IN_BYTES) {
+		eptr = (char*)utf8buf;
+		elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
+		is_utf8 = TRUE;
+	    }
+	    else {
+		c = (char)uv;
+		eptr = &c;
+		elen = 1;
+	    }
+	    goto string;
+	case 's':
+	    if (vectorize)
+		goto unknown;
+	    if (args) {
+		eptr = va_arg(*args, char*);
+		if (eptr)
+		    elen = strlen(eptr);
+		else {
+		    eptr = (char *)nullstr;
+		    elen = sizeof nullstr - 1;
+		}
+	    }
+	    else {
+		eptr = SvPV_const(argsv, elen);
+		if (DO_UTF8(argsv)) {
+		    STRLEN old_precis = precis;
+		    if (has_precis && precis < elen) {
+			STRLEN ulen = sv_or_pv_len_utf8(argsv, eptr, elen);
+			STRLEN p = precis > ulen ? ulen : precis;
+			precis = sv_or_pv_pos_u2b(argsv, eptr, p, 0);
+							/* sticks at end */
+		    }
+		    if (width) { /* fudge width (can't fudge elen) */
+			if (has_precis && precis < elen)
+			    width += precis - old_precis;
+			else
+			    width +=
+				elen - sv_or_pv_len_utf8(argsv,eptr,elen);
+		    }
+		    is_utf8 = TRUE;
+		}
+	    }
+	string:
+	    if (has_precis && precis < elen)
+		elen = precis;
+	    break;
+	    /* INTEGERS */
+	case 'p':
+if (infnan) {
+goto floating_point;
+}
+	    if (alt || vectorize)
+		goto unknown;
+	    uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
+	    base = 16;
+	    goto integer;
+	case 'D':
+#ifdef IV_IS_QUAD
+	    intsize = 'q';
+#else
+	    intsize = 'l';
+#endif
+	    /* FALLTHROUGH */
+	case 'd':
+	case 'i':
+if (infnan) {
+goto floating_point;
+}
+	    if (vectorize) {
+		STRLEN ulen;
+		if (!veclen)
+		    continue;
+		if (vec_utf8)
+		    uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
+					UTF8_ALLOW_ANYUV);
+		else {
+		    uv = *vecstr;
+		    ulen = 1;
+		}
+		vecstr += ulen;
+		veclen -= ulen;
+		if (plus)
+		     esignbuf[esignlen++] = plus;
+	    }
+	    else if (args) {
+		switch (intsize) {
+		case 'c':	iv = (char)va_arg(*args, int); break;
+		case 'h':	iv = (short)va_arg(*args, int); break;
+		case 'l':	iv = va_arg(*args, long); break;
+		case 'V':	iv = va_arg(*args, IV); break;
+		case 'z':	iv = va_arg(*args, SSize_t); break;
+#ifdef HAS_PTRDIFF_T
+		case 't':	iv = va_arg(*args, ptrdiff_t); break;
+#endif
+		default:	iv = va_arg(*args, int); break;
+#ifdef I_STDINT
+		case 'j':	iv = va_arg(*args, intmax_t); break;
+#endif
+		case 'q':
+#if IVSIZE >= 8
+				iv = va_arg(*args, Quad_t); break;
+#else
+				goto unknown;
+#endif
+		}
+	    }
+	    else {
+		IV tiv = SvIV_nomg(argsv); /* work around GCC bug #13488 */
+		switch (intsize) {
+		case 'c':	iv = (char)tiv; break;
+		case 'h':	iv = (short)tiv; break;
+		case 'l':	iv = (long)tiv; break;
+		case 'V':
+		default:	iv = tiv; break;
+		case 'q':
+#if IVSIZE >= 8
+				iv = (Quad_t)tiv; break;
+#else
+				goto unknown;
+#endif
+		}
+	    }
+	    if ( !vectorize )	/* we already set uv above */
+	    {
+		if (iv >= 0) {
+		    uv = iv;
+		    if (plus)
+			esignbuf[esignlen++] = plus;
+		}
+		else {
+		    uv = (iv == IV_MIN) ? (UV)iv : (UV)(-iv);
+		    esignbuf[esignlen++] = '-';
+		}
+	    }
+	    base = 10;
+	    goto integer;
+	case 'U':
+#ifdef IV_IS_QUAD
+	    intsize = 'q';
+#else
+	    intsize = 'l';
+#endif
+	    /* FALLTHROUGH */
+	case 'u':
+	    base = 10;
+	    goto uns_integer;
+	case 'B':
+	case 'b':
+	    base = 2;
+	    goto uns_integer;
+	case 'O':
+#ifdef IV_IS_QUAD
+	    intsize = 'q';
+#else
+	    intsize = 'l';
+#endif
+	    /* FALLTHROUGH */
+	case 'o':
+	    base = 8;
+	    goto uns_integer;
+	case 'X':
+	case 'x':
+	    base = 16;
+	uns_integer:
+if (infnan) {
+goto floating_point;
+}
+	    if (vectorize) {
+		STRLEN ulen;
+	vector:
+		if (!veclen)
+		    continue;
+		if (vec_utf8)
+		    uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
+					UTF8_ALLOW_ANYUV);
+		else {
+		    uv = *vecstr;
+		    ulen = 1;
+		}
+		vecstr += ulen;
+		veclen -= ulen;
+	    }
+	    else if (args) {
+		switch (intsize) {
+		case 'c':  uv = (unsigned char)va_arg(*args, unsigned); break;
+		case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
+		case 'l':  uv = va_arg(*args, unsigned long); break;
+		case 'V':  uv = va_arg(*args, UV); break;
+		case 'z':  uv = va_arg(*args, Size_t); break;
+#ifdef HAS_PTRDIFF_T
+	        case 't':  uv = va_arg(*args, ptrdiff_t); break; /* will sign extend, but there is no uptrdiff_t, so oh well */
+#endif
+#ifdef I_STDINT
+		case 'j':  uv = va_arg(*args, uintmax_t); break;
+#endif
+		default:   uv = va_arg(*args, unsigned); break;
+		case 'q':
+#if IVSIZE >= 8
+			   uv = va_arg(*args, Uquad_t); break;
+#else
+			   goto unknown;
+#endif
+		}
+	    }
+	    else {
+		UV tuv = SvUV_nomg(argsv); /* work around GCC bug #13488 */
+		switch (intsize) {
+		case 'c':	uv = (unsigned char)tuv; break;
+		case 'h':	uv = (unsigned short)tuv; break;
+		case 'l':	uv = (unsigned long)tuv; break;
+		case 'V':
+		default:	uv = tuv; break;
+		case 'q':
+#if IVSIZE >= 8
+				uv = (Uquad_t)tuv; break;
+#else
+				goto unknown;
+#endif
+		}
+	    }
+	integer:
+	    {
+		char *ptr = ebuf + sizeof ebuf;
+		bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
+unsigned dig;
+		zeros = 0;
+		switch (base) {
+		case 16:
+		    p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
+		    do {
+			dig = uv & 15;
+			*--ptr = p[dig];
+		    } while (uv >>= 4);
+		    if (tempalt) {
+			esignbuf[esignlen++] = '0';
+			esignbuf[esignlen++] = c;  /* 'x' or 'X' */
+		    }
+		    break;
+		case 8:
+		    do {
+			dig = uv & 7;
+			*--ptr = '0' + dig;
+		    } while (uv >>= 3);
+		    if (alt && *ptr != '0')
+			*--ptr = '0';
+		    break;
+		case 2:
+		    do {
+			dig = uv & 1;
+			*--ptr = '0' + dig;
+		    } while (uv >>= 1);
+		    if (tempalt) {
+			esignbuf[esignlen++] = '0';
+			esignbuf[esignlen++] = c;
+		    }
+		    break;
+		default:		/* it had better be ten or less */
+		    do {
+			dig = uv % base;
+			*--ptr = '0' + dig;
+		    } while (uv /= base);
+		    break;
+		}
+		elen = (ebuf + sizeof ebuf) - ptr;
+		eptr = ptr;
+		if (has_precis) {
+		    if (precis > elen)
+			zeros = precis - elen;
+		    else if (precis == 0 && elen == 1 && *eptr == '0'
+			     && !(base == 8 && alt)) /* "%#.0o" prints "0" */
+			elen = 0;
+		/* a precision nullifies the 0 flag. */
+		    if (fill == '0')
+			fill = ' ';
+		}
+	    }
+	    break;
+	    /* FLOATING POINT */
+floating_point:
+	case 'F':
+	    c = 'f';		/* maybe %F isn't supported here */
+	    /* FALLTHROUGH */
+	case 'e': case 'E':
+	case 'f':
+	case 'g': case 'G':
+	case 'a': case 'A':
+	    if (vectorize)
+		goto unknown;
+	    /* This is evil, but floating point is even more evil */
+	    /* for SV-style calling, we can only get NV
+	       for C-style calling, we assume %f is double;
+	       for simplicity we allow any of %Lf, %llf, %qf for long double
+	    */
+	    switch (intsize) {
+	    case 'V':
+#if defined(USE_LONG_DOUBLE) || defined(USE_QUADMATH)
+		intsize = 'q';
+#endif
+		break;
+/* [perl #20339] - we should accept and ignore %lf rather than die */
+	    case 'l':
+		/* FALLTHROUGH */
+	    default:
+#if defined(USE_LONG_DOUBLE) || defined(USE_QUADMATH)
+		intsize = args ? 0 : 'q';
+#endif
+		break;
+	    case 'q':
+#if defined(HAS_LONG_DOUBLE)
+		break;
+#else
+		/* FALLTHROUGH */
+#endif
+	    case 'c':
+	    case 'h':
+	    case 'z':
+	    case 't':
+	    case 'j':
+		goto unknown;
+	    }
+/* Now we need (long double) if intsize == 'q', else (double). */
+if (args) {
+/* Note: do not pull NVs off the va_list with va_arg()
+* (pull doubles instead) because if you have a build
+* with long doubles, you would always be pulling long
+* doubles, which would badly break anyone using only
+* doubles (i.e. the majority of builds). In other
+* words, you cannot mix doubles and long doubles.
+* The only case where you can pull off long doubles
+* is when the format specifier explicitly asks so with
+* e.g. "%Lg". */
+#ifdef USE_QUADMATH
+fv = intsize == 'q' ?
+va_arg(*args, NV) : va_arg(*args, double);
+nv = fv;
+#elif LONG_DOUBLESIZE > DOUBLESIZE
+if (intsize == 'q') {
+fv = va_arg(*args, long double);
+nv = fv;
+} else {
+nv = va_arg(*args, double);
+NV_TO_FV(nv, fv);
+}
+#else
+nv = va_arg(*args, double);
+fv = nv;
+#endif
+}
+else
+{
+if (!infnan) SvGETMAGIC(argsv);
+nv = SvNV_nomg(argsv);
+NV_TO_FV(nv, fv);
+}
+	    need = 0;
+	    /* frexp() (or frexpl) has some unspecified behaviour for
+* nan/inf/-inf, so let's avoid calling that on non-finites. */
+	    if (isALPHA_FOLD_NE(c, 'e') && FV_ISFINITE(fv)) {
+i = PERL_INT_MIN;
+(void)Perl_frexp((NV)fv, &i);
+if (i == PERL_INT_MIN)
+Perl_die(aTHX_ "panic: frexp: %"FV_GF, fv);
+/* Do not set hexfp earlier since we want to printf
+* Inf/NaN for Inf/NaN, not their hexfp. */
+hexfp = isALPHA_FOLD_EQ(c, 'a');
+if (UNLIKELY(hexfp)) {
+/* This seriously overshoots in most cases, but
+* better the undershooting.  Firstly, all bytes
+* of the NV are not mantissa, some of them are
+* exponent.  Secondly, for the reasonably common
+* long doubles case, the "80-bit extended", two
+* or six bytes of the NV are unused. */
+need +=
+(fv < 0) ? 1 : 0 + /* possible unary minus */
+2 + /* "0x" */
+1 + /* the very unlikely carry */
+1 + /* "1" */
+1 + /* "." */
+2 * NVSIZE + /* 2 hexdigits for each byte */
+2 + /* "p+" */
+6 + /* exponent: sign, plus up to 16383 (quad fp) */
+1;   /* \0 */
+#ifdef LONGDOUBLE_DOUBLEDOUBLE
+/* However, for the "double double", we need more.
+* Since each double has their own exponent, the
+* doubles may float (haha) rather far from each
+* other, and the number of required bits is much
+* larger, up to total of DOUBLEDOUBLE_MAXBITS bits.
+* See the definition of DOUBLEDOUBLE_MAXBITS.
+*
+* Need 2 hexdigits for each byte. */
+need += (DOUBLEDOUBLE_MAXBITS/8 + 1) * 2;
+/* the size for the exponent already added */
+#endif
+#ifdef USE_LOCALE_NUMERIC
+STORE_LC_NUMERIC_SET_TO_NEEDED();
+if (PL_numeric_radix_sv && IN_LC(LC_NUMERIC))
+need += SvLEN(PL_numeric_radix_sv);
+RESTORE_LC_NUMERIC();
+#endif
+}
+else if (i > 0) {
+need = BIT_DIGITS(i);
+} /* if i < 0, the number of digits is hard to predict. */
+	    }
+	    need += has_precis ? precis : 6; /* known default */
+	    if (need < width)
+		need = width;
+#ifdef HAS_LDBL_SPRINTF_BUG
+	    /* This is to try to fix a bug with irix/nonstop-ux/powerux and
+	       with sfio - Allen <allens@cpan.org> */
+#  ifdef DBL_MAX
+#    define MY_DBL_MAX DBL_MAX
+#  else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
+#    if DOUBLESIZE >= 8
+#      define MY_DBL_MAX 1.7976931348623157E+308L
+#    else
+#      define MY_DBL_MAX 3.40282347E+38L
+#    endif
+#  endif
+#  ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
+#    define MY_DBL_MAX_BUG 1L
+#  else
+#    define MY_DBL_MAX_BUG MY_DBL_MAX
+#  endif
+#  ifdef DBL_MIN
+#    define MY_DBL_MIN DBL_MIN
+#  else  /* XXX guessing! -Allen */
+#    if DOUBLESIZE >= 8
+#      define MY_DBL_MIN 2.2250738585072014E-308L
+#    else
+#      define MY_DBL_MIN 1.17549435E-38L
+#    endif
+#  endif
+	    if ((intsize == 'q') && (c == 'f') &&
+		((fv < MY_DBL_MAX_BUG) && (fv > -MY_DBL_MAX_BUG)) &&
+		(need < DBL_DIG)) {
+		/* it's going to be short enough that
+		 * long double precision is not needed */
+		if ((fv <= 0L) && (fv >= -0L))
+		    fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
+		else {
+		    /* would use Perl_fp_class as a double-check but not
+		     * functional on IRIX - see perl.h comments */
+		    if ((fv >= MY_DBL_MIN) || (fv <= -MY_DBL_MIN)) {
+			/* It's within the range that a double can represent */
+#if defined(DBL_MAX) && !defined(DBL_MIN)
+			if ((fv >= ((long double)1/DBL_MAX)) ||
+			    (fv <= (-(long double)1/DBL_MAX)))
+#endif
+			fix_ldbl_sprintf_bug = TRUE;
+		    }
+		}
+		if (fix_ldbl_sprintf_bug == TRUE) {
+		    double temp;
+		    intsize = 0;
+		    temp = (double)fv;
+		    fv = (NV)temp;
+		}
+	    }
+#  undef MY_DBL_MAX
+#  undef MY_DBL_MAX_BUG
+#  undef MY_DBL_MIN
+#endif /* HAS_LDBL_SPRINTF_BUG */
+	    need += 20; /* fudge factor */
+	    if (PL_efloatsize < need) {
+		Safefree(PL_efloatbuf);
+		PL_efloatsize = need + 20; /* more fudge */
+		Newx(PL_efloatbuf, PL_efloatsize, char);
+		PL_efloatbuf[0] = '\0';
+	    }
+	    if ( !(width || left || plus || alt) && fill != '0'
+		 && has_precis && intsize != 'q'	/* Shortcuts */
+&& LIKELY(!Perl_isinfnan((NV)fv)) ) {
+		/* See earlier comment about buggy Gconvert when digits,
+		   aka precis is 0  */
+		if ( c == 'g' && precis ) {
+STORE_LC_NUMERIC_SET_TO_NEEDED();
+SNPRINTF_G(fv, PL_efloatbuf, PL_efloatsize, precis);
+		    /* May return an empty string for digits==0 */
+		    if (*PL_efloatbuf) {
+			elen = strlen(PL_efloatbuf);
+			goto float_converted;
+		    }
+		} else if ( c == 'f' && !precis ) {
+		    if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
+			break;
+		}
+	    }
+if (UNLIKELY(hexfp)) {
+/* Hexadecimal floating point. */
+char* p = PL_efloatbuf;
+U8 vhex[VHEX_SIZE];
+U8* v = vhex; /* working pointer to vhex */
+U8* vend; /* pointer to one beyond last digit of vhex */
+U8* vfnz = NULL; /* first non-zero */
+U8* vlnz = NULL; /* last non-zero */
+const bool lower = (c == 'a');
+/* At output the values of vhex (up to vend) will
+* be mapped through the xdig to get the actual
+* human-readable xdigits. */
+const char* xdig = PL_hexdigit;
+int zerotail = 0; /* how many extra zeros to append */
+int exponent = 0; /* exponent of the floating point input */
+bool hexradix = FALSE; /* should we output the radix */
+/* XXX: denormals, NaN, Inf.
+*
+* For example with denormals, (assuming the vanilla
+* 64-bit double): the exponent is zero. 1xp-1074 is
+* the smallest denormal and the smallest double, it
+* should be output as 0x0.0000000000001p-1022 to
+* match its internal structure. */
+vend = S_hextract(aTHX_ nv, &exponent, vhex, NULL);
+S_hextract(aTHX_ nv, &exponent, vhex, vend);
+#if NVSIZE > DOUBLESIZE
+#  ifdef HEXTRACT_HAS_IMPLICIT_BIT
+/* In this case there is an implicit bit,
+* and therefore the exponent is shifted shift by one. */
+exponent--;
+#  else
+/* In this case there is no implicit bit,
+* and the exponent is shifted by the first xdigit. */
+exponent -= 4;
+#  endif
+#endif
+if (fv < 0
+|| Perl_signbit(nv)
+)
+*p++ = '-';
+else if (plus)
+*p++ = plus;
+*p++ = '0';
+if (lower) {
+*p++ = 'x';
+}
+else {
+*p++ = 'X';
+xdig += 16; /* Use uppercase hex. */
+}
+/* Find the first non-zero xdigit. */
+for (v = vhex; v < vend; v++) {
+if (*v) {
+vfnz = v;
+break;
+}
+}
+if (vfnz) {
+/* Find the last non-zero xdigit. */
+for (v = vend - 1; v >= vhex; v--) {
+if (*v) {
+vlnz = v;
+break;
+}
+}
+#if NVSIZE == DOUBLESIZE
+if (fv != 0.0)
+exponent--;
+#endif
+if (precis > 0) {
+if ((SSize_t)(precis + 1) < vend - vhex) {
+bool round;
+v = vhex + precis + 1;
+/* Round away from zero: if the tail
+* beyond the precis xdigits is equal to
+* or greater than 0x8000... */
+round = *v > 0x8;
+if (!round && *v == 0x8) {
+for (v++; v < vend; v++) {
+if (*v) {
+round = TRUE;
+break;
+}
+}
+}
+if (round) {
+for (v = vhex + precis; v >= vhex; v--) {
+if (*v < 0xF) {
+(*v)++;
+break;
+}
+*v = 0;
+if (v == vhex) {
+/* If the carry goes all the way to
+* the front, we need to output
+* a single '1'. This goes against
+* the "xdigit and then radix"
+* but since this is "cannot happen"
+* category, that is probably good. */
+*p++ = xdig[1];
+}
+}
+}
+/* The new effective "last non zero". */
+vlnz = vhex + precis;
+}
+else {
+zerotail = precis - (vlnz - vhex);
+}
+}
+v = vhex;
+*p++ = xdig[*v++];
+/* If there are non-zero xdigits, the radix
+* is output after the first one. */
+if (vfnz < vlnz) {
+hexradix = TRUE;
+}
+}
+else {
+*p++ = '0';
+exponent = 0;
+zerotail = precis;
+}
+/* The radix is always output if precis, or if alt. */
+if (precis > 0 || alt) {
+hexradix = TRUE;
+}
+if (hexradix) {
+#ifndef USE_LOCALE_NUMERIC
+*p++ = '.';
+#else
+STORE_LC_NUMERIC_SET_TO_NEEDED();
+if (PL_numeric_radix_sv && IN_LC(LC_NUMERIC)) {
+STRLEN n;
+const char* r = SvPV(PL_numeric_radix_sv, n);
+Copy(r, p, n, char);
+p += n;
+}
+else {
+*p++ = '.';
+}
+RESTORE_LC_NUMERIC();
+#endif
+}
+if (vlnz) {
+while (v <= vlnz)
+*p++ = xdig[*v++];
+}
+if (zerotail > 0) {
+while (zerotail--) {
+*p++ = '0';
+}
+}
+elen = p - PL_efloatbuf;
+elen += my_snprintf(p, PL_efloatsize - elen,
+"%c%+d", lower ? 'p' : 'P',
+exponent);
+if (elen < width) {
+if (left) {
+/* Pad the back with spaces. */
+memset(PL_efloatbuf + elen, ' ', width - elen);
+}
+else if (fill == '0') {
+/* Insert the zeros between the "0x" and
+* the digits, otherwise we end up with
+* "0000xHHH..." */
+STRLEN nzero = width - elen;
+char* zerox = PL_efloatbuf + 2;
+Move(zerox, zerox + nzero,  elen - 2, char);
+memset(zerox, fill, nzero);
+}
+else {
+/* Move it to the right. */
+Move(PL_efloatbuf, PL_efloatbuf + width - elen,
+elen, char);
+/* Pad the front with spaces. */
+memset(PL_efloatbuf, ' ', width - elen);
+}
+elen = width;
+}
+}
+else {
+elen = S_infnan_2pv(nv, PL_efloatbuf, PL_efloatsize, plus);
+if (elen) {
+/* Not affecting infnan output: precision, alt, fill. */
+if (elen < width) {
+if (left) {
+/* Pack the back with spaces. */
+memset(PL_efloatbuf + elen, ' ', width - elen);
+} else {
+/* Move it to the right. */
+Move(PL_efloatbuf, PL_efloatbuf + width - elen,
+elen, char);
+/* Pad the front with spaces. */
+memset(PL_efloatbuf, ' ', width - elen);
+}
+elen = width;
+}
+}
+}
+if (elen == 0) {
+char *ptr = ebuf + sizeof ebuf;
+*--ptr = '\0';
+*--ptr = c;
+#if defined(USE_QUADMATH)
+		if (intsize == 'q') {
+/* "g" -> "Qg" */
+*--ptr = 'Q';
+}
+/* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
+#elif defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
+		/* Note that this is HAS_LONG_DOUBLE and PERL_PRIfldbl,
+		 * not USE_LONG_DOUBLE and NVff.  In other words,
+		 * this needs to work without USE_LONG_DOUBLE. */
+		if (intsize == 'q') {
+		    /* Copy the one or more characters in a long double
+		     * format before the 'base' ([efgEFG]) character to
+		     * the format string. */
+		    static char const ldblf[] = PERL_PRIfldbl;
+		    char const *p = ldblf + sizeof(ldblf) - 3;
+		    while (p >= ldblf) { *--ptr = *p--; }
+		}
+#endif
+		if (has_precis) {
+		    base = precis;
+		    do { *--ptr = '0' + (base % 10); } while (base /= 10);
+		    *--ptr = '.';
+		}
+		if (width) {
+		    base = width;
+		    do { *--ptr = '0' + (base % 10); } while (base /= 10);
+		}
+		if (fill == '0')
+		    *--ptr = fill;
+		if (left)
+		    *--ptr = '-';
+		if (plus)
+		    *--ptr = plus;
+		if (alt)
+		    *--ptr = '#';
+		*--ptr = '%';
+		/* No taint.  Otherwise we are in the strange situation
+		 * where printf() taints but print($float) doesn't.
+		 * --jhi */
+STORE_LC_NUMERIC_SET_TO_NEEDED();
+/* hopefully the above makes ptr a very constrained format
+* that is safe to use, even though it's not literal */
+GCC_DIAG_IGNORE(-Wformat-nonliteral);
+#ifdef USE_QUADMATH
+{
+const char* qfmt = quadmath_format_single(ptr);
+if (!qfmt)
+Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", ptr);
+elen = quadmath_snprintf(PL_efloatbuf, PL_efloatsize,
+qfmt, nv);
+if ((IV)elen == -1)
+Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
+if (qfmt != ptr)
+Safefree(qfmt);
+}
+#elif defined(HAS_LONG_DOUBLE)
+elen = ((intsize == 'q')
+? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, fv)
+: my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)fv));
+#else
+elen = my_sprintf(PL_efloatbuf, ptr, fv);
+#endif
+GCC_DIAG_RESTORE;
+	    }
+	float_converted:
+	    eptr = PL_efloatbuf;
+assert((IV)elen > 0); /* here zero elen is bad */
+#ifdef USE_LOCALE_NUMERIC
+/* If the decimal point character in the string is UTF-8, make the
+* output utf8 */
+if (PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
+&& instr(eptr, SvPVX_const(PL_numeric_radix_sv)))
+{
+is_utf8 = TRUE;
+}
+#endif
+	    break;
+	    /* SPECIAL */
+	case 'n':
+	    if (vectorize)
+		goto unknown;
+	    i = SvCUR(sv) - origlen;
+	    if (args) {
+		switch (intsize) {
+		case 'c':	*(va_arg(*args, char*)) = i; break;
+		case 'h':	*(va_arg(*args, short*)) = i; break;
+		default:	*(va_arg(*args, int*)) = i; break;
+		case 'l':	*(va_arg(*args, long*)) = i; break;
+		case 'V':	*(va_arg(*args, IV*)) = i; break;
+		case 'z':	*(va_arg(*args, SSize_t*)) = i; break;
+#ifdef HAS_PTRDIFF_T
+		case 't':	*(va_arg(*args, ptrdiff_t*)) = i; break;
+#endif
+#ifdef I_STDINT
+		case 'j':	*(va_arg(*args, intmax_t*)) = i; break;
+#endif
+		case 'q':
+#if IVSIZE >= 8
+				*(va_arg(*args, Quad_t*)) = i; break;
+#else
+				goto unknown;
+#endif
+		}
+	    }
+	    else
+		sv_setuv_mg(argsv, has_utf8 ? (UV)sv_len_utf8(sv) : (UV)i);
+	    continue;	/* not "break" */
+	    /* UNKNOWN */
+	default:
+unknown:
+	    if (!args
+		&& (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
+		&& ckWARN(WARN_PRINTF))
+	    {
+		SV * const msg = sv_newmortal();
+		Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
+			  (PL_op->op_type == OP_PRTF) ? "" : "s");
+		if (fmtstart < patend) {
+		    const char * const fmtend = q < patend ? q : patend;
+		    const char * f;
+		    sv_catpvs(msg, "\"%");
+		    for (f = fmtstart; f < fmtend; f++) {
+			if (isPRINT(*f)) {
+			    sv_catpvn_nomg(msg, f, 1);
+			} else {
+			    Perl_sv_catpvf(aTHX_ msg,
+					   "\\%03"UVof, (UV)*f & 0xFF);
+			}
+		    }
+		    sv_catpvs(msg, "\"");
+		} else {
+		    sv_catpvs(msg, "end of string");
+		}
+		Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
+	    }
+	    /* output mangled stuff ... */
+	    if (c == '\0')
+		--q;
+	    eptr = p;
+	    elen = q - p;
+	    /* ... right here, because formatting flags should not apply */
+	    SvGROW(sv, SvCUR(sv) + elen + 1);
+	    p = SvEND(sv);
+	    Copy(eptr, p, elen, char);
+	    p += elen;
+	    *p = '\0';
+	    SvCUR_set(sv, p - SvPVX_const(sv));
+	    svix = osvix;
+	    continue;	/* not "break" */
+	}
+	if (is_utf8 != has_utf8) {
+	    if (is_utf8) {
+		if (SvCUR(sv))
+		    sv_utf8_upgrade(sv);
+	    }
+	    else {
+		const STRLEN old_elen = elen;
+		SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
+		sv_utf8_upgrade(nsv);
+		eptr = SvPVX_const(nsv);
+		elen = SvCUR(nsv);
+		if (width) { /* fudge width (can't fudge elen) */
+		    width += elen - old_elen;
+		}
+		is_utf8 = TRUE;
+	    }
+	}
+assert((IV)elen >= 0); /* here zero elen is fine */
+	have = esignlen + zeros + elen;
+	if (have < zeros)
+	    croak_memory_wrap();
+	need = (have > width ? have : width);
+	gap = need - have;
+	if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
+	    croak_memory_wrap();
+	SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
+	p = SvEND(sv);
+	if (esignlen && fill == '0') {
+	    int i;
+	    for (i = 0; i < (int)esignlen; i++)
+		*p++ = esignbuf[i];
+	}
+	if (gap && !left) {
+	    memset(p, fill, gap);
+	    p += gap;
+	}
+	if (esignlen && fill != '0') {
+	    int i;
+	    for (i = 0; i < (int)esignlen; i++)
+		*p++ = esignbuf[i];
+	}
+	if (zeros) {
+	    int i;
+	    for (i = zeros; i; i--)
+		*p++ = '0';
+	}
+	if (elen) {
+	    Copy(eptr, p, elen, char);
+	    p += elen;
+	}
+	if (gap && left) {
+	    memset(p, ' ', gap);
+	    p += gap;
+	}
+	if (vectorize) {
+	    if (veclen) {
+		Copy(dotstr, p, dotstrlen, char);
+		p += dotstrlen;
+	    }
+	    else
+		vectorize = FALSE;		/* done iterating over vecstr */
+	}
+	if (is_utf8)
+	    has_utf8 = TRUE;
+	if (has_utf8)
+	    SvUTF8_on(sv);
+	*p = '\0';
+	SvCUR_set(sv, p - SvPVX_const(sv));
+	if (vectorize) {
+	    esignlen = 0;
+	    goto vector;
+	}
+}
+/* Now that we've consumed all our printf format arguments (svix)
+* do we have things left on the stack that we didn't use?
+*/
+if (!no_redundant_warning && svmax >= svix + 1 && ckWARN(WARN_REDUNDANT)) {
+	Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s",
+		PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
+}
+SvTAINT(sv);
+RESTORE_LC_NUMERIC();   /* Done outside loop, so don't have to save/restore
+each iteration. */
+}
+/* =========================================================================
+=head1 Cloning an interpreter
+=cut
+All the macros and functions in this section are for the private use of
+the main function, perl_clone().
+The foo_dup() functions make an exact copy of an existing foo thingy.
+During the course of a cloning, a hash table is used to map old addresses
+to new addresses.  The table is created and manipulated with the
+ptr_table_* functions.
+* =========================================================================*/
+#if defined(USE_ITHREADS)
+/* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
+#ifndef GpREFCNT_inc
+#  define GpREFCNT_inc(gp)	((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
+#endif
+/* Certain cases in Perl_ss_dup have been merged, by relying on the fact
+that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
+If this changes, please unmerge ss_dup.
+Likewise, sv_dup_inc_multiple() relies on this fact.  */
+#define sv_dup_inc_NN(s,t)	SvREFCNT_inc_NN(sv_dup_inc(s,t))
+#define av_dup(s,t)	MUTABLE_AV(sv_dup((const SV *)s,t))
+#define av_dup_inc(s,t)	MUTABLE_AV(sv_dup_inc((const SV *)s,t))
+#define hv_dup(s,t)	MUTABLE_HV(sv_dup((const SV *)s,t))
+#define hv_dup_inc(s,t)	MUTABLE_HV(sv_dup_inc((const SV *)s,t))
+#define cv_dup(s,t)	MUTABLE_CV(sv_dup((const SV *)s,t))
+#define cv_dup_inc(s,t)	MUTABLE_CV(sv_dup_inc((const SV *)s,t))
+#define io_dup(s,t)	MUTABLE_IO(sv_dup((const SV *)s,t))
+#define io_dup_inc(s,t)	MUTABLE_IO(sv_dup_inc((const SV *)s,t))
+#define gv_dup(s,t)	MUTABLE_GV(sv_dup((const SV *)s,t))
+#define gv_dup_inc(s,t)	MUTABLE_GV(sv_dup_inc((const SV *)s,t))
+#define SAVEPV(p)	((p) ? savepv(p) : NULL)
+#define SAVEPVN(p,n)	((p) ? savepvn(p,n) : NULL)
+/* clone a parser */
+yy_parser *
+Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
+{
+yy_parser *parser;
+PERL_ARGS_ASSERT_PARSER_DUP;
+if (!proto)
+	return NULL;
+/* look for it in the table first */
+parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
+if (parser)
+	return parser;
+/* create anew and remember what it is */
+Newxz(parser, 1, yy_parser);
+ptr_table_store(PL_ptr_table, proto, parser);
+/* XXX these not yet duped */
+parser->old_parser = NULL;
+parser->stack = NULL;
+parser->ps = NULL;
+parser->stack_size = 0;
+/* XXX parser->stack->state = 0; */
+/* XXX eventually, just Copy() most of the parser struct ? */
+parser->lex_brackets = proto->lex_brackets;
+parser->lex_casemods = proto->lex_casemods;
+parser->lex_brackstack = savepvn(proto->lex_brackstack,
+		    (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
+parser->lex_casestack = savepvn(proto->lex_casestack,
+		    (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
+parser->lex_defer	= proto->lex_defer;
+parser->lex_dojoin	= proto->lex_dojoin;
+parser->lex_formbrack = proto->lex_formbrack;
+parser->lex_inpat	= proto->lex_inpat;
+parser->lex_inwhat	= proto->lex_inwhat;
+parser->lex_op	= proto->lex_op;
+parser->lex_repl	= sv_dup_inc(proto->lex_repl, param);
+parser->lex_starts	= proto->lex_starts;
+parser->lex_stuff	= sv_dup_inc(proto->lex_stuff, param);
+parser->multi_close	= proto->multi_close;
+parser->multi_open	= proto->multi_open;
+parser->multi_start	= proto->multi_start;
+parser->multi_end	= proto->multi_end;
+parser->preambled	= proto->preambled;
+parser->sublex_info	= proto->sublex_info; /* XXX not quite right */
+parser->linestr	= sv_dup_inc(proto->linestr, param);
+parser->expect	= proto->expect;
+parser->copline	= proto->copline;
+parser->last_lop_op	= proto->last_lop_op;
+parser->lex_state	= proto->lex_state;
+parser->rsfp	= fp_dup(proto->rsfp, '<', param);
+/* rsfp_filters entries have fake IoDIRP() */
+parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
+parser->in_my	= proto->in_my;
+parser->in_my_stash	= hv_dup(proto->in_my_stash, param);
+parser->error_count	= proto->error_count;
+parser->linestr	= sv_dup_inc(proto->linestr, param);
+{
+	char * const ols = SvPVX(proto->linestr);
+	char * const ls  = SvPVX(parser->linestr);
+	parser->bufptr	    = ls + (proto->bufptr >= ols ?
+				    proto->bufptr -  ols : 0);
+	parser->oldbufptr   = ls + (proto->oldbufptr >= ols ?
+				    proto->oldbufptr -  ols : 0);
+	parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
+				    proto->oldoldbufptr -  ols : 0);
+	parser->linestart   = ls + (proto->linestart >= ols ?
+				    proto->linestart -  ols : 0);
+	parser->last_uni    = ls + (proto->last_uni >= ols ?
+				    proto->last_uni -  ols : 0);
+	parser->last_lop    = ls + (proto->last_lop >= ols ?
+				    proto->last_lop -  ols : 0);
+	parser->bufend	    = ls + SvCUR(parser->linestr);
+}
+Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
+Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
+Copy(proto->nexttype, parser->nexttype, 5,	I32);
+parser->nexttoke	= proto->nexttoke;
+/* XXX should clone saved_curcop here, but we aren't passed
+* proto_perl; so do it in perl_clone_using instead */
+return parser;
+}
+/* duplicate a file handle */
+PerlIO *
+Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
+{
+PerlIO *ret;
+PERL_ARGS_ASSERT_FP_DUP;
+PERL_UNUSED_ARG(type);
+if (!fp)
+	return (PerlIO*)NULL;
+/* look for it in the table first */
+ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
+if (ret)
+	return ret;
+/* create anew and remember what it is */
+ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
+ptr_table_store(PL_ptr_table, fp, ret);
+return ret;
+}
+/* duplicate a directory handle */
+DIR *
+Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param)
+{
+DIR *ret;
+#if defined(HAS_FCHDIR) && defined(HAS_TELLDIR) && defined(HAS_SEEKDIR)
+DIR *pwd;
+const Direntry_t *dirent;
+char smallbuf[256];
+char *name = NULL;
+STRLEN len = 0;
+long pos;
+#endif
+PERL_UNUSED_CONTEXT;
+PERL_ARGS_ASSERT_DIRP_DUP;
+if (!dp)
+	return (DIR*)NULL;
+/* look for it in the table first */
+ret = (DIR*)ptr_table_fetch(PL_ptr_table, dp);
+if (ret)
+	return ret;
+#if defined(HAS_FCHDIR) && defined(HAS_TELLDIR) && defined(HAS_SEEKDIR)
+PERL_UNUSED_ARG(param);
+/* create anew */
+/* open the current directory (so we can switch back) */
+if (!(pwd = PerlDir_open("."))) return (DIR *)NULL;
+/* chdir to our dir handle and open the present working directory */
+if (fchdir(my_dirfd(dp)) < 0 || !(ret = PerlDir_open("."))) {
+	PerlDir_close(pwd);
+	return (DIR *)NULL;
+}
+/* Now we should have two dir handles pointing to the same dir. */
+/* Be nice to the calling code and chdir back to where we were. */
+/* XXX If this fails, then what? */
+PERL_UNUSED_RESULT(fchdir(my_dirfd(pwd)));
+/* We have no need of the pwd handle any more. */
+PerlDir_close(pwd);
+#ifdef DIRNAMLEN
+# define d_namlen(d) (d)->d_namlen
+#else
+# define d_namlen(d) strlen((d)->d_name)
+#endif
+/* Iterate once through dp, to get the file name at the current posi-
+tion. Then step back. */
+pos = PerlDir_tell(dp);
+if ((dirent = PerlDir_read(dp))) {
+	len = d_namlen(dirent);
+	if (len <= sizeof smallbuf) name = smallbuf;
+	else Newx(name, len, char);
+	Move(dirent->d_name, name, len, char);
+}
+PerlDir_seek(dp, pos);
+/* Iterate through the new dir handle, till we find a file with the
+right name. */
+if (!dirent) /* just before the end */
+	for(;;) {
+	    pos = PerlDir_tell(ret);
+	    if (PerlDir_read(ret)) continue; /* not there yet */
+	    PerlDir_seek(ret, pos); /* step back */
+	    break;
+	}
+else {
+	const long pos0 = PerlDir_tell(ret);
+	for(;;) {
+	    pos = PerlDir_tell(ret);
+	    if ((dirent = PerlDir_read(ret))) {
+		if (len == (STRLEN)d_namlen(dirent)
+&& memEQ(name, dirent->d_name, len)) {
+		    /* found it */
+		    PerlDir_seek(ret, pos); /* step back */
+		    break;
+		}
+		/* else we are not there yet; keep iterating */
+	    }
+	    else { /* This is not meant to happen. The best we can do is
+	              reset the iterator to the beginning. */
+		PerlDir_seek(ret, pos0);
+		break;
+	    }
+	}
+}
+#undef d_namlen
+if (name && name != smallbuf)
+	Safefree(name);
+#endif
+#ifdef WIN32
+ret = win32_dirp_dup(dp, param);
+#endif
+/* pop it in the pointer table */
+if (ret)
+	ptr_table_store(PL_ptr_table, dp, ret);
+return ret;
+}
+/* duplicate a typeglob */
+GP *
+Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
+{
+GP *ret;
+PERL_ARGS_ASSERT_GP_DUP;
+if (!gp)
+	return (GP*)NULL;
+/* look for it in the table first */
+ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
+if (ret)
+	return ret;
+/* create anew and remember what it is */
+Newxz(ret, 1, GP);
+ptr_table_store(PL_ptr_table, gp, ret);
+/* clone */
+/* ret->gp_refcnt must be 0 before any other dups are called. We're relying
+on Newxz() to do this for us.  */
+ret->gp_sv		= sv_dup_inc(gp->gp_sv, param);
+ret->gp_io		= io_dup_inc(gp->gp_io, param);
+ret->gp_form	= cv_dup_inc(gp->gp_form, param);
+ret->gp_av		= av_dup_inc(gp->gp_av, param);
+ret->gp_hv		= hv_dup_inc(gp->gp_hv, param);
+ret->gp_egv	= gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
+ret->gp_cv		= cv_dup_inc(gp->gp_cv, param);
+ret->gp_cvgen	= gp->gp_cvgen;
+ret->gp_line	= gp->gp_line;
+ret->gp_file_hek	= hek_dup(gp->gp_file_hek, param);
+return ret;
+}
+/* duplicate a chain of magic */
+MAGIC *
+Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
+{
+MAGIC *mgret = NULL;
+MAGIC **mgprev_p = &mgret;
+PERL_ARGS_ASSERT_MG_DUP;
+for (; mg; mg = mg->mg_moremagic) {
+	MAGIC *nmg;
+	if ((param->flags & CLONEf_JOIN_IN)
+		&& mg->mg_type == PERL_MAGIC_backref)
+	    /* when joining, we let the individual SVs add themselves to
+	     * backref as needed. */
+	    continue;
+	Newx(nmg, 1, MAGIC);
+	*mgprev_p = nmg;
+	mgprev_p = &(nmg->mg_moremagic);
+	/* There was a comment "XXX copy dynamic vtable?" but as we don't have
+	   dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates
+	   from the original commit adding Perl_mg_dup() - revision 4538.
+	   Similarly there is the annotation "XXX random ptr?" next to the
+	   assignment to nmg->mg_ptr.  */
+	*nmg = *mg;
+	/* FIXME for plugins
+	if (nmg->mg_type == PERL_MAGIC_qr) {
+	    nmg->mg_obj	= MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param));
+	}
+	else
+	*/
+	nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
+			  ? nmg->mg_type == PERL_MAGIC_backref
+				/* The backref AV has its reference
+				 * count deliberately bumped by 1 */
+				? SvREFCNT_inc(av_dup_inc((const AV *)
+						    nmg->mg_obj, param))
+				: sv_dup_inc(nmg->mg_obj, param)
+			  : sv_dup(nmg->mg_obj, param);
+	if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
+	    if (nmg->mg_len > 0) {
+		nmg->mg_ptr	= SAVEPVN(nmg->mg_ptr, nmg->mg_len);
+		if (nmg->mg_type == PERL_MAGIC_overload_table &&
+			AMT_AMAGIC((AMT*)nmg->mg_ptr))
+		{
+		    AMT * const namtp = (AMT*)nmg->mg_ptr;
+		    sv_dup_inc_multiple((SV**)(namtp->table),
+					(SV**)(namtp->table), NofAMmeth, param);
+		}
+	    }
+	    else if (nmg->mg_len == HEf_SVKEY)
+		nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
+	}
+	if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {
+	    nmg->mg_virtual->svt_dup(aTHX_ nmg, param);
+	}
+}
+return mgret;
+}
+#endif /* USE_ITHREADS */
+struct ptr_tbl_arena {
+struct ptr_tbl_arena *next;
+struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers.  */
+};
+/* create a new pointer-mapping table */
+PTR_TBL_t *
+Perl_ptr_table_new(pTHX)
+{
+PTR_TBL_t *tbl;
+PERL_UNUSED_CONTEXT;
+Newx(tbl, 1, PTR_TBL_t);
+tbl->tbl_max	= 511;
+tbl->tbl_items	= 0;
+tbl->tbl_arena	= NULL;
+tbl->tbl_arena_next	= NULL;
+tbl->tbl_arena_end	= NULL;
+Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
+return tbl;
+}
+#define PTR_TABLE_HASH(ptr) \
+((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
+/* map an existing pointer using a table */
+STATIC PTR_TBL_ENT_t *
+S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
+{
+PTR_TBL_ENT_t *tblent;
+const UV hash = PTR_TABLE_HASH(sv);
+PERL_ARGS_ASSERT_PTR_TABLE_FIND;
+tblent = tbl->tbl_ary[hash & tbl->tbl_max];
+for (; tblent; tblent = tblent->next) {
+	if (tblent->oldval == sv)
+	    return tblent;
+}
+return NULL;
+}
+void *
+Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
+{
+PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
+PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
+PERL_UNUSED_CONTEXT;
+return tblent ? tblent->newval : NULL;
+}
+/* add a new entry to a pointer-mapping table 'tbl'.  In hash terms, 'oldsv' is
+* the key; 'newsv' is the value.  The names "old" and "new" are specific to
+* the core's typical use of ptr_tables in thread cloning. */
+void
+Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
+{
+PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
+PERL_ARGS_ASSERT_PTR_TABLE_STORE;
+PERL_UNUSED_CONTEXT;
+if (tblent) {
+	tblent->newval = newsv;
+} else {
+	const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
+	if (tbl->tbl_arena_next == tbl->tbl_arena_end) {
+	    struct ptr_tbl_arena *new_arena;
+	    Newx(new_arena, 1, struct ptr_tbl_arena);
+	    new_arena->next = tbl->tbl_arena;
+	    tbl->tbl_arena = new_arena;
+	    tbl->tbl_arena_next = new_arena->array;
+	    tbl->tbl_arena_end = C_ARRAY_END(new_arena->array);
+	}
+	tblent = tbl->tbl_arena_next++;
+	tblent->oldval = oldsv;
+	tblent->newval = newsv;
+	tblent->next = tbl->tbl_ary[entry];
+	tbl->tbl_ary[entry] = tblent;
+	tbl->tbl_items++;
+	if (tblent->next && tbl->tbl_items > tbl->tbl_max)
+	    ptr_table_split(tbl);
+}
+}
+/* double the hash bucket size of an existing ptr table */
+void
+Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
+{
+PTR_TBL_ENT_t **ary = tbl->tbl_ary;
+const UV oldsize = tbl->tbl_max + 1;
+UV newsize = oldsize * 2;
+UV i;
+PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
+PERL_UNUSED_CONTEXT;
+Renew(ary, newsize, PTR_TBL_ENT_t*);
+Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
+tbl->tbl_max = --newsize;
+tbl->tbl_ary = ary;
+for (i=0; i < oldsize; i++, ary++) {
+	PTR_TBL_ENT_t **entp = ary;
+	PTR_TBL_ENT_t *ent = *ary;
+	PTR_TBL_ENT_t **curentp;
+	if (!ent)
+	    continue;
+	curentp = ary + oldsize;
+	do {
+	    if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
+		*entp = ent->next;
+		ent->next = *curentp;
+		*curentp = ent;
+	    }
+	    else
+		entp = &ent->next;
+	    ent = *entp;
+	} while (ent);
+}
+}
+/* remove all the entries from a ptr table */
+/* Deprecated - will be removed post 5.14 */
+void
+Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
+{
+PERL_UNUSED_CONTEXT;
+if (tbl && tbl->tbl_items) {
+	struct ptr_tbl_arena *arena = tbl->tbl_arena;
+	Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent **);
+	while (arena) {
+	    struct ptr_tbl_arena *next = arena->next;
+	    Safefree(arena);
+	    arena = next;
+	};
+	tbl->tbl_items = 0;
+	tbl->tbl_arena = NULL;
+	tbl->tbl_arena_next = NULL;
+	tbl->tbl_arena_end = NULL;
+}
+}
+/* clear and free a ptr table */
+void
+Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
+{
+struct ptr_tbl_arena *arena;
+PERL_UNUSED_CONTEXT;
+if (!tbl) {
+return;
+}
+arena = tbl->tbl_arena;
+while (arena) {
+	struct ptr_tbl_arena *next = arena->next;
+	Safefree(arena);
+	arena = next;
+}
+Safefree(tbl->tbl_ary);
+Safefree(tbl);
+}
+#if defined(USE_ITHREADS)
+void
+Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
+{
+PERL_ARGS_ASSERT_RVPV_DUP;
+assert(!isREGEXP(sstr));
+if (SvROK(sstr)) {
+	if (SvWEAKREF(sstr)) {
+	    SvRV_set(dstr, sv_dup(SvRV_const(sstr), param));
+	    if (param->flags & CLONEf_JOIN_IN) {
+		/* if joining, we add any back references individually rather
+		 * than copying the whole backref array */
+		Perl_sv_add_backref(aTHX_ SvRV(dstr), dstr);
+	    }
+	}
+	else
+	    SvRV_set(dstr, sv_dup_inc(SvRV_const(sstr), param));
+}
+else if (SvPVX_const(sstr)) {
+	/* Has something there */
+	if (SvLEN(sstr)) {
+	    /* Normal PV - clone whole allocated space */
+	    SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
+	    /* sstr may not be that normal, but actually copy on write.
+	       But we are a true, independent SV, so:  */
+	    SvIsCOW_off(dstr);
+	}
+	else {
+	    /* Special case - not normally malloced for some reason */
+	    if (isGV_with_GP(sstr)) {
+		/* Don't need to do anything here.  */
+	    }
+	    else if ((SvIsCOW(sstr))) {
+		/* A "shared" PV - clone it as "shared" PV */
+		SvPV_set(dstr,
+			 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
+					 param)));
+	    }
+	    else {
+		/* Some other special case - random pointer */
+		SvPV_set(dstr, (char *) SvPVX_const(sstr));
+	    }
+	}
+}
+else {
+	/* Copy the NULL */
+	SvPV_set(dstr, NULL);
+}
+}
+/* duplicate a list of SVs. source and dest may point to the same memory.  */
+static SV **
+S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest,
+		      SSize_t items, CLONE_PARAMS *const param)
+{
+PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE;
+while (items-- > 0) {
+	*dest++ = sv_dup_inc(*source++, param);
+}
+return dest;
+}
+/* duplicate an SV of any type (including AV, HV etc) */
+static SV *
+S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
+{
+dVAR;
+SV *dstr;
+PERL_ARGS_ASSERT_SV_DUP_COMMON;
+if (SvTYPE(sstr) == (svtype)SVTYPEMASK) {
+#ifdef DEBUG_LEAKING_SCALARS_ABORT
+	abort();
+#endif
+	return NULL;
+}
+/* look for it in the table first */
+dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr));
+if (dstr)
+	return dstr;
+if(param->flags & CLONEf_JOIN_IN) {
+/** We are joining here so we don't want do clone
+	    something that is bad **/
+	if (SvTYPE(sstr) == SVt_PVHV) {
+	    const HEK * const hvname = HvNAME_HEK(sstr);
+	    if (hvname) {
+		/** don't clone stashes if they already exist **/
+		dstr = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname),
+HEK_UTF8(hvname) ? SVf_UTF8 : 0));
+		ptr_table_store(PL_ptr_table, sstr, dstr);
+		return dstr;
+	    }
+}
+	else if (SvTYPE(sstr) == SVt_PVGV && !SvFAKE(sstr)) {
+	    HV *stash = GvSTASH(sstr);
+	    const HEK * hvname;
+	    if (stash && (hvname = HvNAME_HEK(stash))) {
+		/** don't clone GVs if they already exist **/
+		SV **svp;
+		stash = gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname),
+				    HEK_UTF8(hvname) ? SVf_UTF8 : 0);
+		svp = hv_fetch(
+			stash, GvNAME(sstr),
+			GvNAMEUTF8(sstr)
+			    ? -GvNAMELEN(sstr)
+			    :  GvNAMELEN(sstr),
+			0
+		      );
+		if (svp && *svp && SvTYPE(*svp) == SVt_PVGV) {
+		    ptr_table_store(PL_ptr_table, sstr, *svp);
+		    return *svp;
+		}
+	    }
+}
+}
+/* create anew and remember what it is */
+new_SV(dstr);
+#ifdef DEBUG_LEAKING_SCALARS
+dstr->sv_debug_optype = sstr->sv_debug_optype;
+dstr->sv_debug_line = sstr->sv_debug_line;
+dstr->sv_debug_inpad = sstr->sv_debug_inpad;
+dstr->sv_debug_parent = (SV*)sstr;
+FREE_SV_DEBUG_FILE(dstr);
+dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
+#endif
+ptr_table_store(PL_ptr_table, sstr, dstr);
+/* clone */
+SvFLAGS(dstr)	= SvFLAGS(sstr);
+SvFLAGS(dstr)	&= ~SVf_OOK;		/* don't propagate OOK hack */
+SvREFCNT(dstr)	= 0;			/* must be before any other dups! */
+#ifdef DEBUGGING
+if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
+	PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
+		      (void*)PL_watch_pvx, SvPVX_const(sstr));
+#endif
+/* don't clone objects whose class has asked us not to */
+if (SvOBJECT(sstr)
+&& ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE))
+{
+	SvFLAGS(dstr) = 0;
+	return dstr;
+}
+switch (SvTYPE(sstr)) {
+case SVt_NULL:
+	SvANY(dstr)	= NULL;
+	break;
+case SVt_IV:
+	SET_SVANY_FOR_BODYLESS_IV(dstr);
+	if(SvROK(sstr)) {
+	    Perl_rvpv_dup(aTHX_ dstr, sstr, param);
+	} else {
+	    SvIV_set(dstr, SvIVX(sstr));
+	}
+	break;
+case SVt_NV:
+#if NVSIZE <= IVSIZE
+	SET_SVANY_FOR_BODYLESS_NV(dstr);
+#else
+	SvANY(dstr)	= new_XNV();
+#endif
+	SvNV_set(dstr, SvNVX(sstr));
+	break;
+default:
+	{
+	    /* These are all the types that need complex bodies allocating.  */
+	    void *new_body;
+	    const svtype sv_type = SvTYPE(sstr);
+	    const struct body_details *const sv_type_details
+		= bodies_by_type + sv_type;
+	    switch (sv_type) {
+	    default:
+		Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
+		break;
+	    case SVt_PVGV:
+	    case SVt_PVIO:
+	    case SVt_PVFM:
+	    case SVt_PVHV:
+	    case SVt_PVAV:
+	    case SVt_PVCV:
+	    case SVt_PVLV:
+	    case SVt_REGEXP:
+	    case SVt_PVMG:
+	    case SVt_PVNV:
+	    case SVt_PVIV:
+case SVt_INVLIST:
+	    case SVt_PV:
+		assert(sv_type_details->body_size);
+		if (sv_type_details->arena) {
+		    new_body_inline(new_body, sv_type);
+		    new_body
+			= (void*)((char*)new_body - sv_type_details->offset);
+		} else {
+		    new_body = new_NOARENA(sv_type_details);
+		}
+	    }
+	    assert(new_body);
+	    SvANY(dstr) = new_body;
+#ifndef PURIFY
+	    Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
+		 ((char*)SvANY(dstr)) + sv_type_details->offset,
+		 sv_type_details->copy, char);
+#else
+	    Copy(((char*)SvANY(sstr)),
+		 ((char*)SvANY(dstr)),
+		 sv_type_details->body_size + sv_type_details->offset, char);
+#endif
+	    if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
+		&& !isGV_with_GP(dstr)
+		&& !isREGEXP(dstr)
+		&& !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP)))
+		Perl_rvpv_dup(aTHX_ dstr, sstr, param);
+	    /* The Copy above means that all the source (unduplicated) pointers
+	       are now in the destination.  We can check the flags and the
+	       pointers in either, but it's possible that there's less cache
+	       missing by always going for the destination.
+	       FIXME - instrument and check that assumption  */
+	    if (sv_type >= SVt_PVMG) {
+		if (SvMAGIC(dstr))
+		    SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
+		if (SvOBJECT(dstr) && SvSTASH(dstr))
+		    SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
+		else SvSTASH_set(dstr, 0); /* don't copy DESTROY cache */
+	    }
+	    /* The cast silences a GCC warning about unhandled types.  */
+	    switch ((int)sv_type) {
+	    case SVt_PV:
+		break;
+	    case SVt_PVIV:
+		break;
+	    case SVt_PVNV:
+		break;
+	    case SVt_PVMG:
+		break;
+	    case SVt_REGEXP:
+	      duprex:
+		/* FIXME for plugins */
+		dstr->sv_u.svu_rx = ((REGEXP *)dstr)->sv_any;
+		re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
+		break;
+	    case SVt_PVLV:
+		/* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
+		if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
+		    LvTARG(dstr) = dstr;
+		else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
+		    LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
+		else
+		    LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
+		if (isREGEXP(sstr)) goto duprex;
+	    case SVt_PVGV:
+		/* non-GP case already handled above */
+		if(isGV_with_GP(sstr)) {
+		    GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
+		    /* Don't call sv_add_backref here as it's going to be
+		       created as part of the magic cloning of the symbol
+		       table--unless this is during a join and the stash
+		       is not actually being cloned.  */
+		    /* Danger Will Robinson - GvGP(dstr) isn't initialised
+		       at the point of this comment.  */
+		    GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
+		    if (param->flags & CLONEf_JOIN_IN)
+			Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
+		    GvGP_set(dstr, gp_dup(GvGP(sstr), param));
+		    (void)GpREFCNT_inc(GvGP(dstr));
+		}
+		break;
+	    case SVt_PVIO:
+		/* PL_parser->rsfp_filters entries have fake IoDIRP() */
+		if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
+		    /* I have no idea why fake dirp (rsfps)
+		       should be treated differently but otherwise
+		       we end up with leaks -- sky*/
+		    IoTOP_GV(dstr)      = gv_dup_inc(IoTOP_GV(dstr), param);
+		    IoFMT_GV(dstr)      = gv_dup_inc(IoFMT_GV(dstr), param);
+		    IoBOTTOM_GV(dstr)   = gv_dup_inc(IoBOTTOM_GV(dstr), param);
+		} else {
+		    IoTOP_GV(dstr)      = gv_dup(IoTOP_GV(dstr), param);
+		    IoFMT_GV(dstr)      = gv_dup(IoFMT_GV(dstr), param);
+		    IoBOTTOM_GV(dstr)   = gv_dup(IoBOTTOM_GV(dstr), param);
+		    if (IoDIRP(dstr)) {
+			IoDIRP(dstr)	= dirp_dup(IoDIRP(dstr), param);
+		    } else {
+			NOOP;
+			/* IoDIRP(dstr) is already a copy of IoDIRP(sstr)  */
+		    }
+		    IoIFP(dstr)	= fp_dup(IoIFP(sstr), IoTYPE(dstr), param);
+		}
+		if (IoOFP(dstr) == IoIFP(sstr))
+		    IoOFP(dstr) = IoIFP(dstr);
+		else
+		    IoOFP(dstr)	= fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
+		IoTOP_NAME(dstr)	= SAVEPV(IoTOP_NAME(dstr));
+		IoFMT_NAME(dstr)	= SAVEPV(IoFMT_NAME(dstr));
+		IoBOTTOM_NAME(dstr)	= SAVEPV(IoBOTTOM_NAME(dstr));
+		break;
+	    case SVt_PVAV:
+		/* avoid cloning an empty array */
+		if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) {
+		    SV **dst_ary, **src_ary;
+		    SSize_t items = AvFILLp((const AV *)sstr) + 1;
+		    src_ary = AvARRAY((const AV *)sstr);
+		    Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
+		    ptr_table_store(PL_ptr_table, src_ary, dst_ary);
+		    AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
+		    AvALLOC((const AV *)dstr) = dst_ary;
+		    if (AvREAL((const AV *)sstr)) {
+			dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items,
+						      param);
+		    }
+		    else {
+			while (items-- > 0)
+			    *dst_ary++ = sv_dup(*src_ary++, param);
+		    }
+		    items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
+		    while (items-- > 0) {
+			*dst_ary++ = NULL;
+		    }
+		}
+		else {
+		    AvARRAY(MUTABLE_AV(dstr))	= NULL;
+		    AvALLOC((const AV *)dstr)	= (SV**)NULL;
+		    AvMAX(  (const AV *)dstr)	= -1;
+		    AvFILLp((const AV *)dstr)	= -1;
+		}
+		break;
+	    case SVt_PVHV:
+		if (HvARRAY((const HV *)sstr)) {
+		    STRLEN i = 0;
+		    const bool sharekeys = !!HvSHAREKEYS(sstr);
+		    XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
+		    XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
+		    char *darray;
+		    Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
+			+ (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
+			char);
+		    HvARRAY(dstr) = (HE**)darray;
+		    while (i <= sxhv->xhv_max) {
+			const HE * const source = HvARRAY(sstr)[i];
+			HvARRAY(dstr)[i] = source
+			    ? he_dup(source, sharekeys, param) : 0;
+			++i;
+		    }
+		    if (SvOOK(sstr)) {
+			const struct xpvhv_aux * const saux = HvAUX(sstr);
+			struct xpvhv_aux * const daux = HvAUX(dstr);
+			/* This flag isn't copied.  */
+			SvOOK_on(dstr);
+			if (saux->xhv_name_count) {
+			    HEK ** const sname = saux->xhv_name_u.xhvnameu_names;
+			    const I32 count
+			     = saux->xhv_name_count < 0
+			        ? -saux->xhv_name_count
+			        :  saux->xhv_name_count;
+			    HEK **shekp = sname + count;
+			    HEK **dhekp;
+			    Newx(daux->xhv_name_u.xhvnameu_names, count, HEK *);
+			    dhekp = daux->xhv_name_u.xhvnameu_names + count;
+			    while (shekp-- > sname) {
+				dhekp--;
+				*dhekp = hek_dup(*shekp, param);
+			    }
+			}
+			else {
+			    daux->xhv_name_u.xhvnameu_name
+				= hek_dup(saux->xhv_name_u.xhvnameu_name,
+					  param);
+			}
+			daux->xhv_name_count = saux->xhv_name_count;
+			daux->xhv_fill_lazy = saux->xhv_fill_lazy;
+			daux->xhv_aux_flags = saux->xhv_aux_flags;
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+			daux->xhv_rand = saux->xhv_rand;
+			daux->xhv_last_rand = saux->xhv_last_rand;
+#endif
+			daux->xhv_riter = saux->xhv_riter;
+			daux->xhv_eiter = saux->xhv_eiter
+			    ? he_dup(saux->xhv_eiter,
+					cBOOL(HvSHAREKEYS(sstr)), param) : 0;
+			/* backref array needs refcnt=2; see sv_add_backref */
+			daux->xhv_backreferences =
+			    (param->flags & CLONEf_JOIN_IN)
+				/* when joining, we let the individual GVs and
+				 * CVs add themselves to backref as
+				 * needed. This avoids pulling in stuff
+				 * that isn't required, and simplifies the
+				 * case where stashes aren't cloned back
+				 * if they already exist in the parent
+				 * thread */
+			    ? NULL
+			    : saux->xhv_backreferences
+				? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV)
+				    ? MUTABLE_AV(SvREFCNT_inc(
+					  sv_dup_inc((const SV *)
+					    saux->xhv_backreferences, param)))
+				    : MUTABLE_AV(sv_dup((const SV *)
+					    saux->xhv_backreferences, param))
+				: 0;
+daux->xhv_mro_meta = saux->xhv_mro_meta
+? mro_meta_dup(saux->xhv_mro_meta, param)
+: 0;
+			/* Record stashes for possible cloning in Perl_clone(). */
+			if (HvNAME(sstr))
+			    av_push(param->stashes, dstr);
+		    }
+		}
+		else
+		    HvARRAY(MUTABLE_HV(dstr)) = NULL;
+		break;
+	    case SVt_PVCV:
+		if (!(param->flags & CLONEf_COPY_STACKS)) {
+		    CvDEPTH(dstr) = 0;
+		}
+		/* FALLTHROUGH */
+	    case SVt_PVFM:
+		/* NOTE: not refcounted */
+		SvANY(MUTABLE_CV(dstr))->xcv_stash =
+		    hv_dup(CvSTASH(dstr), param);
+		if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dstr))
+		    Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr);
+		if (!CvISXSUB(dstr)) {
+		    OP_REFCNT_LOCK;
+		    CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
+		    OP_REFCNT_UNLOCK;
+		    CvSLABBED_off(dstr);
+		} else if (CvCONST(dstr)) {
+		    CvXSUBANY(dstr).any_ptr =
+			sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
+		}
+		assert(!CvSLABBED(dstr));
+		if (CvDYNFILE(dstr)) CvFILE(dstr) = SAVEPV(CvFILE(dstr));
+		if (CvNAMED(dstr))
+		    SvANY((CV *)dstr)->xcv_gv_u.xcv_hek =
+			hek_dup(CvNAME_HEK((CV *)sstr), param);
+		/* don't dup if copying back - CvGV isn't refcounted, so the
+		 * duped GV may never be freed. A bit of a hack! DAPM */
+		else
+		  SvANY(MUTABLE_CV(dstr))->xcv_gv_u.xcv_gv =
+		    CvCVGV_RC(dstr)
+		    ? gv_dup_inc(CvGV(sstr), param)
+		    : (param->flags & CLONEf_JOIN_IN)
+			? NULL
+			: gv_dup(CvGV(sstr), param);
+		if (!CvISXSUB(sstr)) {
+		    PADLIST * padlist = CvPADLIST(sstr);
+		    if(padlist)
+			padlist = padlist_dup(padlist, param);
+		    CvPADLIST_set(dstr, padlist);
+		} else
+/* unthreaded perl can't sv_dup so we dont support unthreaded's CvHSCXT */
+		    PoisonPADLIST(dstr);
+		CvOUTSIDE(dstr)	=
+		    CvWEAKOUTSIDE(sstr)
+		    ? cv_dup(    CvOUTSIDE(dstr), param)
+		    : cv_dup_inc(CvOUTSIDE(dstr), param);
+		break;
+	    }
+	}
+}
+return dstr;
+}
+SV *
+Perl_sv_dup_inc(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
+{
+PERL_ARGS_ASSERT_SV_DUP_INC;
+return sstr ? SvREFCNT_inc(sv_dup_common(sstr, param)) : NULL;
+}
+SV *
+Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
+{
+SV *dstr = sstr ? sv_dup_common(sstr, param) : NULL;
+PERL_ARGS_ASSERT_SV_DUP;
+/* Track every SV that (at least initially) had a reference count of 0.
+We need to do this by holding an actual reference to it in this array.
+If we attempt to cheat, turn AvREAL_off(), and store only pointers
+(akin to the stashes hash, and the perl stack), we come unstuck if
+a weak reference (or other SV legitimately SvREFCNT() == 0 for this
+thread) is manipulated in a CLONE method, because CLONE runs before the
+unreferenced array is walked to find SVs still with SvREFCNT() == 0
+(and fix things up by giving each a reference via the temps stack).
+Instead, during CLONE, if the 0-referenced SV has SvREFCNT_inc() and
+then SvREFCNT_dec(), it will be cleaned up (and added to the free list)
+before the walk of unreferenced happens and a reference to that is SV
+added to the temps stack. At which point we have the same SV considered
+to be in use, and free to be re-used. Not good.
+*/
+if (dstr && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dstr)) {
+	assert(param->unreferenced);
+	av_push(param->unreferenced, SvREFCNT_inc(dstr));
+}
+return dstr;
+}
+/* duplicate a context */
+PERL_CONTEXT *
+Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
+{
+PERL_CONTEXT *ncxs;
+PERL_ARGS_ASSERT_CX_DUP;
+if (!cxs)
+	return (PERL_CONTEXT*)NULL;
+/* look for it in the table first */
+ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
+if (ncxs)
+	return ncxs;
+/* create anew and remember what it is */
+Newx(ncxs, max + 1, PERL_CONTEXT);
+ptr_table_store(PL_ptr_table, cxs, ncxs);
+Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
+while (ix >= 0) {
+	PERL_CONTEXT * const ncx = &ncxs[ix];
+	if (CxTYPE(ncx) == CXt_SUBST) {
+	    Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
+	}
+	else {
+	    ncx->blk_oldcop = (COP*)any_dup(ncx->blk_oldcop, param->proto_perl);
+	    switch (CxTYPE(ncx)) {
+	    case CXt_SUB:
+		ncx->blk_sub.cv		= (ncx->blk_sub.olddepth == 0
+					   ? cv_dup_inc(ncx->blk_sub.cv, param)
+					   : cv_dup(ncx->blk_sub.cv,param));
+		if(CxHASARGS(ncx)){
+		    ncx->blk_sub.argarray = av_dup_inc(ncx->blk_sub.argarray,param);
+		    ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,param);
+		} else {
+		    ncx->blk_sub.argarray = NULL;
+		    ncx->blk_sub.savearray = NULL;
+		}
+		ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
+					   ncx->blk_sub.oldcomppad);
+		break;
+	    case CXt_EVAL:
+		ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
+						      param);
+		ncx->blk_eval.cur_text	= sv_dup(ncx->blk_eval.cur_text, param);
+		ncx->blk_eval.cv = cv_dup(ncx->blk_eval.cv, param);
+		break;
+	    case CXt_LOOP_LAZYSV:
+		ncx->blk_loop.state_u.lazysv.end
+		    = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
+/* Fallthrough: duplicate lazysv.cur by using the ary.ary
+duplication code instead.
+We are taking advantage of (1) av_dup_inc and sv_dup_inc
+actually being the same function, and (2) order
+equivalence of the two unions.
+		   We can assert the later [but only at run time :-(]  */
+		assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
+			(void *) &ncx->blk_loop.state_u.lazysv.cur);
+/* FALLTHROUGH */
+	    case CXt_LOOP_FOR:
+		ncx->blk_loop.state_u.ary.ary
+		    = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
+/* FALLTHROUGH */
+	    case CXt_LOOP_LAZYIV:
+	    case CXt_LOOP_PLAIN:
+/* code common to all CXt_LOOP_* types */
+		if (CxPADLOOP(ncx)) {
+		    ncx->blk_loop.itervar_u.oldcomppad
+			= (PAD*)ptr_table_fetch(PL_ptr_table,
+					ncx->blk_loop.itervar_u.oldcomppad);
+		} else {
+		    ncx->blk_loop.itervar_u.gv
+			= gv_dup((const GV *)ncx->blk_loop.itervar_u.gv,
+				    param);
+		}
+		break;
+	    case CXt_FORMAT:
+		ncx->blk_format.cv	= cv_dup(ncx->blk_format.cv, param);
+		ncx->blk_format.gv	= gv_dup(ncx->blk_format.gv, param);
+		ncx->blk_format.dfoutgv	= gv_dup_inc(ncx->blk_format.dfoutgv,
+						     param);
+		break;
+	    case CXt_BLOCK:
+	    case CXt_NULL:
+	    case CXt_WHEN:
+	    case CXt_GIVEN:
+		break;
+	    }
+	}
+	--ix;
+}
+return ncxs;
+}
+/* duplicate a stack info structure */
+PERL_SI *
+Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
+{
+PERL_SI *nsi;
+PERL_ARGS_ASSERT_SI_DUP;
+if (!si)
+	return (PERL_SI*)NULL;
+/* look for it in the table first */
+nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
+if (nsi)
+	return nsi;
+/* create anew and remember what it is */
+Newxz(nsi, 1, PERL_SI);
+ptr_table_store(PL_ptr_table, si, nsi);
+nsi->si_stack	= av_dup_inc(si->si_stack, param);
+nsi->si_cxix	= si->si_cxix;
+nsi->si_cxmax	= si->si_cxmax;
+nsi->si_cxstack	= cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
+nsi->si_type	= si->si_type;
+nsi->si_prev	= si_dup(si->si_prev, param);
+nsi->si_next	= si_dup(si->si_next, param);
+nsi->si_markoff	= si->si_markoff;
+return nsi;
+}
+#define POPINT(ss,ix)	((ss)[--(ix)].any_i32)
+#define TOPINT(ss,ix)	((ss)[ix].any_i32)
+#define POPLONG(ss,ix)	((ss)[--(ix)].any_long)
+#define TOPLONG(ss,ix)	((ss)[ix].any_long)
+#define POPIV(ss,ix)	((ss)[--(ix)].any_iv)
+#define TOPIV(ss,ix)	((ss)[ix].any_iv)
+#define POPUV(ss,ix)	((ss)[--(ix)].any_uv)
+#define TOPUV(ss,ix)	((ss)[ix].any_uv)
+#define POPBOOL(ss,ix)	((ss)[--(ix)].any_bool)
+#define TOPBOOL(ss,ix)	((ss)[ix].any_bool)
+#define POPPTR(ss,ix)	((ss)[--(ix)].any_ptr)
+#define TOPPTR(ss,ix)	((ss)[ix].any_ptr)
+#define POPDPTR(ss,ix)	((ss)[--(ix)].any_dptr)
+#define TOPDPTR(ss,ix)	((ss)[ix].any_dptr)
+#define POPDXPTR(ss,ix)	((ss)[--(ix)].any_dxptr)
+#define TOPDXPTR(ss,ix)	((ss)[ix].any_dxptr)
+/* XXXXX todo */
+#define pv_dup_inc(p)	SAVEPV(p)
+#define pv_dup(p)	SAVEPV(p)
+#define svp_dup_inc(p,pp)	any_dup(p,pp)
+/* map any object to the new equivent - either something in the
+* ptr table, or something in the interpreter structure
+*/
+void *
+Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
+{
+void *ret;
+PERL_ARGS_ASSERT_ANY_DUP;
+if (!v)
+	return (void*)NULL;
+/* look for it in the table first */
+ret = ptr_table_fetch(PL_ptr_table, v);
+if (ret)
+	return ret;
+/* see if it is part of the interpreter structure */
+if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
+	ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
+else {
+	ret = v;
+}
+return ret;
+}
+/* duplicate the save stack */
+ANY *
+Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
+{
+dVAR;
+ANY * const ss	= proto_perl->Isavestack;
+const I32 max	= proto_perl->Isavestack_max;
+I32 ix		= proto_perl->Isavestack_ix;
+ANY *nss;
+const SV *sv;
+const GV *gv;
+const AV *av;
+const HV *hv;
+void* ptr;
+int intval;
+long longval;
+GP *gp;
+IV iv;
+I32 i;
+char *c = NULL;
+void (*dptr) (void*);
+void (*dxptr) (pTHX_ void*);
+PERL_ARGS_ASSERT_SS_DUP;
+Newxz(nss, max, ANY);
+while (ix > 0) {
+	const UV uv = POPUV(ss,ix);
+	const U8 type = (U8)uv & SAVE_MASK;
+	TOPUV(nss,ix) = uv;
+	switch (type) {
+	case SAVEt_CLEARSV:
+	case SAVEt_CLEARPADRANGE:
+	    break;
+	case SAVEt_HELEM:		/* hash element */
+	case SAVEt_SV:			/* scalar reference */
+	    sv = (const SV *)POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = SvREFCNT_inc(sv_dup_inc(sv, param));
+	    /* FALLTHROUGH */
+	case SAVEt_ITEM:			/* normal string */
+case SAVEt_GVSV:			/* scalar slot in GV */
+	    sv = (const SV *)POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = sv_dup_inc(sv, param);
+	    if (type == SAVEt_SV)
+		break;
+	    /* FALLTHROUGH */
+	case SAVEt_FREESV:
+	case SAVEt_MORTALIZESV:
+	case SAVEt_READONLY_OFF:
+	    sv = (const SV *)POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = sv_dup_inc(sv, param);
+	    break;
+	case SAVEt_FREEPADNAME:
+	    ptr = POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = padname_dup((PADNAME *)ptr, param);
+	    PadnameREFCNT((PADNAME *)TOPPTR(nss,ix))++;
+	    break;
+	case SAVEt_SHARED_PVREF:		/* char* in shared space */
+	    c = (char*)POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = savesharedpv(c);
+	    ptr = POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+	    break;
+case SAVEt_GENERIC_SVREF:		/* generic sv */
+case SAVEt_SVREF:			/* scalar reference */
+	    sv = (const SV *)POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = sv_dup_inc(sv, param);
+	    if (type == SAVEt_SVREF)
+		SvREFCNT_inc_simple_void((SV *)TOPPTR(nss,ix));
+	    ptr = POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
+	    break;
+case SAVEt_GVSLOT:		/* any slot in GV */
+	    sv = (const SV *)POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = sv_dup_inc(sv, param);
+	    ptr = POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
+	    sv = (const SV *)POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = sv_dup_inc(sv, param);
+	    break;
+case SAVEt_HV:				/* hash reference */
+case SAVEt_AV:				/* array reference */
+	    sv = (const SV *) POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = sv_dup_inc(sv, param);
+	    /* FALLTHROUGH */
+	case SAVEt_COMPPAD:
+	case SAVEt_NSTAB:
+	    sv = (const SV *) POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = sv_dup(sv, param);
+	    break;
+	case SAVEt_INT:				/* int reference */
+	    ptr = POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+	    intval = (int)POPINT(ss,ix);
+	    TOPINT(nss,ix) = intval;
+	    break;
+	case SAVEt_LONG:			/* long reference */
+	    ptr = POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+	    longval = (long)POPLONG(ss,ix);
+	    TOPLONG(nss,ix) = longval;
+	    break;
+	case SAVEt_I32:				/* I32 reference */
+	    ptr = POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+	    i = POPINT(ss,ix);
+	    TOPINT(nss,ix) = i;
+	    break;
+	case SAVEt_IV:				/* IV reference */
+	case SAVEt_STRLEN:			/* STRLEN/size_t ref */
+	    ptr = POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+	    iv = POPIV(ss,ix);
+	    TOPIV(nss,ix) = iv;
+	    break;
+	case SAVEt_HPTR:			/* HV* reference */
+	case SAVEt_APTR:			/* AV* reference */
+	case SAVEt_SPTR:			/* SV* reference */
+	    ptr = POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+	    sv = (const SV *)POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = sv_dup(sv, param);
+	    break;
+	case SAVEt_VPTR:			/* random* reference */
+	    ptr = POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+	    /* FALLTHROUGH */
+	case SAVEt_INT_SMALL:
+	case SAVEt_I32_SMALL:
+	case SAVEt_I16:				/* I16 reference */
+	case SAVEt_I8:				/* I8 reference */
+	case SAVEt_BOOL:
+	    ptr = POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+	    break;
+	case SAVEt_GENERIC_PVREF:		/* generic char* */
+	case SAVEt_PPTR:			/* char* reference */
+	    ptr = POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+	    c = (char*)POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = pv_dup(c);
+	    break;
+	case SAVEt_GP:				/* scalar reference */
+	    gp = (GP*)POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = gp = gp_dup(gp, param);
+	    (void)GpREFCNT_inc(gp);
+	    gv = (const GV *)POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = gv_dup_inc(gv, param);
+	    break;
+	case SAVEt_FREEOP:
+	    ptr = POPPTR(ss,ix);
+	    if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
+		/* these are assumed to be refcounted properly */
+		OP *o;
+		switch (((OP*)ptr)->op_type) {
+		case OP_LEAVESUB:
+		case OP_LEAVESUBLV:
+		case OP_LEAVEEVAL:
+		case OP_LEAVE:
+		case OP_SCOPE:
+		case OP_LEAVEWRITE:
+		    TOPPTR(nss,ix) = ptr;
+		    o = (OP*)ptr;
+		    OP_REFCNT_LOCK;
+		    (void) OpREFCNT_inc(o);
+		    OP_REFCNT_UNLOCK;
+		    break;
+		default:
+		    TOPPTR(nss,ix) = NULL;
+		    break;
+		}
+	    }
+	    else
+		TOPPTR(nss,ix) = NULL;
+	    break;
+	case SAVEt_FREECOPHH:
+	    ptr = POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = cophh_copy((COPHH *)ptr);
+	    break;
+	case SAVEt_ADELETE:
+	    av = (const AV *)POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = av_dup_inc(av, param);
+	    i = POPINT(ss,ix);
+	    TOPINT(nss,ix) = i;
+	    break;
+	case SAVEt_DELETE:
+	    hv = (const HV *)POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = hv_dup_inc(hv, param);
+	    i = POPINT(ss,ix);
+	    TOPINT(nss,ix) = i;
+	    /* FALLTHROUGH */
+	case SAVEt_FREEPV:
+	    c = (char*)POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = pv_dup_inc(c);
+	    break;
+	case SAVEt_STACK_POS:		/* Position on Perl stack */
+	    i = POPINT(ss,ix);
+	    TOPINT(nss,ix) = i;
+	    break;
+	case SAVEt_DESTRUCTOR:
+	    ptr = POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);	/* XXX quite arbitrary */
+	    dptr = POPDPTR(ss,ix);
+	    TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
+					any_dup(FPTR2DPTR(void *, dptr),
+						proto_perl));
+	    break;
+	case SAVEt_DESTRUCTOR_X:
+	    ptr = POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);	/* XXX quite arbitrary */
+	    dxptr = POPDXPTR(ss,ix);
+	    TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
+					 any_dup(FPTR2DPTR(void *, dxptr),
+						 proto_perl));
+	    break;
+	case SAVEt_REGCONTEXT:
+	case SAVEt_ALLOC:
+	    ix -= uv >> SAVE_TIGHT_SHIFT;
+	    break;
+	case SAVEt_AELEM:		/* array element */
+	    sv = (const SV *)POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = SvREFCNT_inc(sv_dup_inc(sv, param));
+	    i = POPINT(ss,ix);
+	    TOPINT(nss,ix) = i;
+	    av = (const AV *)POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = av_dup_inc(av, param);
+	    break;
+	case SAVEt_OP:
+	    ptr = POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = ptr;
+	    break;
+	case SAVEt_HINTS:
+	    ptr = POPPTR(ss,ix);
+	    ptr = cophh_copy((COPHH*)ptr);
+	    TOPPTR(nss,ix) = ptr;
+	    i = POPINT(ss,ix);
+	    TOPINT(nss,ix) = i;
+	    if (i & HINT_LOCALIZE_HH) {
+		hv = (const HV *)POPPTR(ss,ix);
+		TOPPTR(nss,ix) = hv_dup_inc(hv, param);
+	    }
+	    break;
+	case SAVEt_PADSV_AND_MORTALIZE:
+	    longval = (long)POPLONG(ss,ix);
+	    TOPLONG(nss,ix) = longval;
+	    ptr = POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+	    sv = (const SV *)POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = sv_dup_inc(sv, param);
+	    break;
+	case SAVEt_SET_SVFLAGS:
+	    i = POPINT(ss,ix);
+	    TOPINT(nss,ix) = i;
+	    i = POPINT(ss,ix);
+	    TOPINT(nss,ix) = i;
+	    sv = (const SV *)POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = sv_dup(sv, param);
+	    break;
+	case SAVEt_COMPILE_WARNINGS:
+	    ptr = POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
+	    break;
+	case SAVEt_PARSER:
+	    ptr = POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
+	    break;
+	case SAVEt_GP_ALIASED_SV: {
+	    GP * gp_ptr = (GP *)POPPTR(ss,ix);
+	    GP * new_gp_ptr = gp_dup(gp_ptr, param);
+	    TOPPTR(nss,ix) = new_gp_ptr;
+	    new_gp_ptr->gp_refcnt++;
+	    break;
+	}
+	default:
+	    Perl_croak(aTHX_
+		       "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
+	}
+}
+return nss;
+}
+/* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
+* flag to the result. This is done for each stash before cloning starts,
+* so we know which stashes want their objects cloned */
+static void
+do_mark_cloneable_stash(pTHX_ SV *const sv)
+{
+const HEK * const hvname = HvNAME_HEK((const HV *)sv);
+if (hvname) {
+	GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
+	SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
+	if (cloner && GvCV(cloner)) {
+	    dSP;
+	    UV status;
+	    ENTER;
+	    SAVETMPS;
+	    PUSHMARK(SP);
+	    mXPUSHs(newSVhek(hvname));
+	    PUTBACK;
+	    call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR);
+	    SPAGAIN;
+	    status = POPu;
+	    PUTBACK;
+	    FREETMPS;
+	    LEAVE;
+	    if (status)
+		SvFLAGS(sv) &= ~SVphv_CLONEABLE;
+	}
+}
+}
+/*
+=for apidoc perl_clone
+Create and return a new interpreter by cloning the current one.
+perl_clone takes these flags as parameters:
+CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
+without it we only clone the data and zero the stacks,
+with it we copy the stacks and the new perl interpreter is
+ready to run at the exact same point as the previous one.
+The pseudo-fork code uses COPY_STACKS while the
+threads->create doesn't.
+CLONEf_KEEP_PTR_TABLE -
+perl_clone keeps a ptr_table with the pointer of the old
+variable as a key and the new variable as a value,
+this allows it to check if something has been cloned and not
+clone it again but rather just use the value and increase the
+refcount.  If KEEP_PTR_TABLE is not set then perl_clone will kill
+the ptr_table using the function
+C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
+reason to keep it around is if you want to dup some of your own
+variable who are outside the graph perl scans, example of this
+code is in threads.xs create.
+CLONEf_CLONE_HOST -
+This is a win32 thing, it is ignored on unix, it tells perls
+win32host code (which is c++) to clone itself, this is needed on
+win32 if you want to run two threads at the same time,
+if you just want to do some stuff in a separate perl interpreter
+and then throw it away and return to the original one,
+you don't need to do anything.
+=cut
+*/
+/* XXX the above needs expanding by someone who actually understands it ! */
+EXTERN_C PerlInterpreter *
+perl_clone_host(PerlInterpreter* proto_perl, UV flags);
+PerlInterpreter *
+perl_clone(PerlInterpreter *proto_perl, UV flags)
+{
+dVAR;
+#ifdef PERL_IMPLICIT_SYS
+PERL_ARGS_ASSERT_PERL_CLONE;
+/* perlhost.h so we need to call into it
+to clone the host, CPerlHost should have a c interface, sky */
+if (flags & CLONEf_CLONE_HOST) {
+return perl_clone_host(proto_perl,flags);
+}
+return perl_clone_using(proto_perl, flags,
+			    proto_perl->IMem,
+			    proto_perl->IMemShared,
+			    proto_perl->IMemParse,
+			    proto_perl->IEnv,
+			    proto_perl->IStdIO,
+			    proto_perl->ILIO,
+			    proto_perl->IDir,
+			    proto_perl->ISock,
+			    proto_perl->IProc);
+}
+PerlInterpreter *
+perl_clone_using(PerlInterpreter *proto_perl, UV flags,
+		 struct IPerlMem* ipM, struct IPerlMem* ipMS,
+		 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
+		 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
+		 struct IPerlDir* ipD, struct IPerlSock* ipS,
+		 struct IPerlProc* ipP)
+{
+/* XXX many of the string copies here can be optimized if they're
+* constants; they need to be allocated as common memory and just
+* their pointers copied. */
+IV i;
+CLONE_PARAMS clone_params;
+CLONE_PARAMS* const param = &clone_params;
+PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
+PERL_ARGS_ASSERT_PERL_CLONE_USING;
+#else		/* !PERL_IMPLICIT_SYS */
+IV i;
+CLONE_PARAMS clone_params;
+CLONE_PARAMS* param = &clone_params;
+PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
+PERL_ARGS_ASSERT_PERL_CLONE;
+#endif		/* PERL_IMPLICIT_SYS */
+/* for each stash, determine whether its objects should be cloned */
+S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
+PERL_SET_THX(my_perl);
+#ifdef DEBUGGING
+PoisonNew(my_perl, 1, PerlInterpreter);
+PL_op = NULL;
+PL_curcop = NULL;
+PL_defstash = NULL; /* may be used by perl malloc() */
+PL_markstack = 0;
+PL_scopestack = 0;
+PL_scopestack_name = 0;
+PL_savestack = 0;
+PL_savestack_ix = 0;
+PL_savestack_max = -1;
+PL_sig_pending = 0;
+PL_parser = NULL;
+Zero(&PL_debug_pad, 1, struct perl_debug_pad);
+Zero(&PL_padname_undef, 1, PADNAME);
+Zero(&PL_padname_const, 1, PADNAME);
+#  ifdef DEBUG_LEAKING_SCALARS
+PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000;
+#  endif
+#else	/* !DEBUGGING */
+Zero(my_perl, 1, PerlInterpreter);
+#endif	/* DEBUGGING */
+#ifdef PERL_IMPLICIT_SYS
+/* host pointers */
+PL_Mem		= ipM;
+PL_MemShared	= ipMS;
+PL_MemParse		= ipMP;
+PL_Env		= ipE;
+PL_StdIO		= ipStd;
+PL_LIO		= ipLIO;
+PL_Dir		= ipD;
+PL_Sock		= ipS;
+PL_Proc		= ipP;
+#endif		/* PERL_IMPLICIT_SYS */
+param->flags = flags;
+/* Nothing in the core code uses this, but we make it available to
+extensions (using mg_dup).  */
+param->proto_perl = proto_perl;
+/* Likely nothing will use this, but it is initialised to be consistent
+with Perl_clone_params_new().  */
+param->new_perl = my_perl;
+param->unreferenced = NULL;
+INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
+PL_body_arenas = NULL;
+Zero(&PL_body_roots, 1, PL_body_roots);
+PL_sv_count		= 0;
+PL_sv_root		= NULL;
+PL_sv_arenaroot	= NULL;
+PL_debug		= proto_perl->Idebug;
+/* dbargs array probably holds garbage */
+PL_dbargs		= NULL;
+PL_compiling = proto_perl->Icompiling;
+/* pseudo environmental stuff */
+PL_origargc		= proto_perl->Iorigargc;
+PL_origargv		= proto_perl->Iorigargv;
+#ifndef NO_TAINT_SUPPORT
+/* Set tainting stuff before PerlIO_debug can possibly get called */
+PL_tainting		= proto_perl->Itainting;
+PL_taint_warn	= proto_perl->Itaint_warn;
+#else
+PL_tainting         = FALSE;
+PL_taint_warn	= FALSE;
+#endif
+PL_minus_c		= proto_perl->Iminus_c;
+PL_localpatches	= proto_perl->Ilocalpatches;
+PL_splitstr		= proto_perl->Isplitstr;
+PL_minus_n		= proto_perl->Iminus_n;
+PL_minus_p		= proto_perl->Iminus_p;
+PL_minus_l		= proto_perl->Iminus_l;
+PL_minus_a		= proto_perl->Iminus_a;
+PL_minus_E		= proto_perl->Iminus_E;
+PL_minus_F		= proto_perl->Iminus_F;
+PL_doswitches	= proto_perl->Idoswitches;
+PL_dowarn		= proto_perl->Idowarn;
+PL_sawalias		= proto_perl->Isawalias;
+#ifdef PERL_SAWAMPERSAND
+PL_sawampersand	= proto_perl->Isawampersand;
+#endif
+PL_unsafe		= proto_perl->Iunsafe;
+PL_perldb		= proto_perl->Iperldb;
+PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
+PL_exit_flags       = proto_perl->Iexit_flags;
+/* XXX time(&PL_basetime) when asked for? */
+PL_basetime		= proto_perl->Ibasetime;
+PL_maxsysfd		= proto_perl->Imaxsysfd;
+PL_statusvalue	= proto_perl->Istatusvalue;
+#ifdef __VMS
+PL_statusvalue_vms	= proto_perl->Istatusvalue_vms;
+#else
+PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
+#endif
+/* RE engine related */
+PL_regmatch_slab	= NULL;
+PL_reg_curpm	= NULL;
+PL_sub_generation	= proto_perl->Isub_generation;
+/* funky return mechanisms */
+PL_forkprocess	= proto_perl->Iforkprocess;
+/* internal state */
+PL_maxo		= proto_perl->Imaxo;
+PL_main_start	= proto_perl->Imain_start;
+PL_eval_root	= proto_perl->Ieval_root;
+PL_eval_start	= proto_perl->Ieval_start;
+PL_filemode		= proto_perl->Ifilemode;
+PL_lastfd		= proto_perl->Ilastfd;
+PL_oldname		= proto_perl->Ioldname;		/* XXX not quite right */
+PL_Argv		= NULL;
+PL_Cmd		= NULL;
+PL_gensym		= proto_perl->Igensym;
+PL_laststatval	= proto_perl->Ilaststatval;
+PL_laststype	= proto_perl->Ilaststype;
+PL_mess_sv		= NULL;
+PL_profiledata	= NULL;
+PL_generation	= proto_perl->Igeneration;
+PL_in_clean_objs	= proto_perl->Iin_clean_objs;
+PL_in_clean_all	= proto_perl->Iin_clean_all;
+PL_delaymagic_uid	= proto_perl->Idelaymagic_uid;
+PL_delaymagic_euid	= proto_perl->Idelaymagic_euid;
+PL_delaymagic_gid	= proto_perl->Idelaymagic_gid;
+PL_delaymagic_egid	= proto_perl->Idelaymagic_egid;
+PL_nomemok		= proto_perl->Inomemok;
+PL_an		= proto_perl->Ian;
+PL_evalseq		= proto_perl->Ievalseq;
+PL_origenviron	= proto_perl->Iorigenviron;	/* XXX not quite right */
+PL_origalen		= proto_perl->Iorigalen;
+PL_sighandlerp	= proto_perl->Isighandlerp;
+PL_runops		= proto_perl->Irunops;
+PL_subline		= proto_perl->Isubline;
+PL_cv_has_eval	= proto_perl->Icv_has_eval;
+#ifdef FCRYPT
+PL_cryptseen	= proto_perl->Icryptseen;
+#endif
+#ifdef USE_LOCALE_COLLATE
+PL_collation_ix	= proto_perl->Icollation_ix;
+PL_collation_standard	= proto_perl->Icollation_standard;
+PL_collxfrm_base	= proto_perl->Icollxfrm_base;
+PL_collxfrm_mult	= proto_perl->Icollxfrm_mult;
+#endif /* USE_LOCALE_COLLATE */
+#ifdef USE_LOCALE_NUMERIC
+PL_numeric_standard	= proto_perl->Inumeric_standard;
+PL_numeric_local	= proto_perl->Inumeric_local;
+#endif /* !USE_LOCALE_NUMERIC */
+/* Did the locale setup indicate UTF-8? */
+PL_utf8locale	= proto_perl->Iutf8locale;
+PL_in_utf8_CTYPE_locale = proto_perl->Iin_utf8_CTYPE_locale;
+/* Unicode features (see perlrun/-C) */
+PL_unicode		= proto_perl->Iunicode;
+/* Pre-5.8 signals control */
+PL_signals		= proto_perl->Isignals;
+/* times() ticks per second */
+PL_clocktick	= proto_perl->Iclocktick;
+/* Recursion stopper for PerlIO_find_layer */
+PL_in_load_module	= proto_perl->Iin_load_module;
+/* sort() routine */
+PL_sort_RealCmp	= proto_perl->Isort_RealCmp;
+/* Not really needed/useful since the reenrant_retint is "volatile",
+* but do it for consistency's sake. */
+PL_reentrant_retint	= proto_perl->Ireentrant_retint;
+/* Hooks to shared SVs and locks. */
+PL_sharehook	= proto_perl->Isharehook;
+PL_lockhook		= proto_perl->Ilockhook;
+PL_unlockhook	= proto_perl->Iunlockhook;
+PL_threadhook	= proto_perl->Ithreadhook;
+PL_destroyhook	= proto_perl->Idestroyhook;
+PL_signalhook	= proto_perl->Isignalhook;
+PL_globhook		= proto_perl->Iglobhook;
+/* swatch cache */
+PL_last_swash_hv	= NULL;	/* reinits on demand */
+PL_last_swash_klen	= 0;
+PL_last_swash_key[0]= '\0';
+PL_last_swash_tmps	= (U8*)NULL;
+PL_last_swash_slen	= 0;
+PL_srand_called	= proto_perl->Isrand_called;
+Copy(&(proto_perl->Irandom_state), &PL_random_state, 1, PL_RANDOM_STATE_TYPE);
+if (flags & CLONEf_COPY_STACKS) {
+	/* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
+	PL_tmps_ix		= proto_perl->Itmps_ix;
+	PL_tmps_max		= proto_perl->Itmps_max;
+	PL_tmps_floor		= proto_perl->Itmps_floor;
+	/* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
+	 * NOTE: unlike the others! */
+	PL_scopestack_ix	= proto_perl->Iscopestack_ix;
+	PL_scopestack_max	= proto_perl->Iscopestack_max;
+	/* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
+	 * NOTE: unlike the others! */
+	PL_savestack_ix		= proto_perl->Isavestack_ix;
+	PL_savestack_max	= proto_perl->Isavestack_max;
+}
+PL_start_env	= proto_perl->Istart_env;	/* XXXXXX */
+PL_top_env		= &PL_start_env;
+PL_op		= proto_perl->Iop;
+PL_Sv		= NULL;
+PL_Xpv		= (XPV*)NULL;
+my_perl->Ina	= proto_perl->Ina;
+PL_statbuf		= proto_perl->Istatbuf;
+PL_statcache	= proto_perl->Istatcache;
+#ifndef NO_TAINT_SUPPORT
+PL_tainted		= proto_perl->Itainted;
+#else
+PL_tainted          = FALSE;
+#endif
+PL_curpm		= proto_perl->Icurpm;	/* XXX No PMOP ref count */
+PL_chopset		= proto_perl->Ichopset;	/* XXX never deallocated */
+PL_restartjmpenv	= proto_perl->Irestartjmpenv;
+PL_restartop	= proto_perl->Irestartop;
+PL_in_eval		= proto_perl->Iin_eval;
+PL_delaymagic	= proto_perl->Idelaymagic;
+PL_phase		= proto_perl->Iphase;
+PL_localizing	= proto_perl->Ilocalizing;
+PL_hv_fetch_ent_mh	= NULL;
+PL_modcount		= proto_perl->Imodcount;
+PL_lastgotoprobe	= NULL;
+PL_dumpindent	= proto_perl->Idumpindent;
+PL_efloatbuf	= NULL;		/* reinits on demand */
+PL_efloatsize	= 0;			/* reinits on demand */
+/* regex stuff */
+PL_colorset		= 0;		/* reinits PL_colors[] */
+/*PL_colors[6]	= {0,0,0,0,0,0};*/
+/* Pluggable optimizer */
+PL_peepp		= proto_perl->Ipeepp;
+PL_rpeepp		= proto_perl->Irpeepp;
+/* op_free() hook */
+PL_opfreehook	= proto_perl->Iopfreehook;
+#ifdef USE_REENTRANT_API
+/* XXX: things like -Dm will segfault here in perlio, but doing
+*  PERL_SET_CONTEXT(proto_perl);
+* breaks too many other things
+*/
+Perl_reentrant_init(aTHX);
+#endif
+/* create SV map for pointer relocation */
+PL_ptr_table = ptr_table_new();
+/* initialize these special pointers as early as possible */
+init_constants();
+ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
+ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
+ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
+ptr_table_store(PL_ptr_table, &proto_perl->Ipadname_const,
+		    &PL_padname_const);
+/* create (a non-shared!) shared string table */
+PL_strtab		= newHV();
+HvSHAREKEYS_off(PL_strtab);
+hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
+ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
+Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*);
+/* This PV will be free'd special way so must set it same way op.c does */
+PL_compiling.cop_file    = savesharedpv(PL_compiling.cop_file);
+ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
+ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
+PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
+CopHINTHASH_set(&PL_compiling, cophh_copy(CopHINTHASH_get(&PL_compiling)));
+PL_curcop		= (COP*)any_dup(proto_perl->Icurcop, proto_perl);
+param->stashes      = newAV();  /* Setup array of objects to call clone on */
+/* This makes no difference to the implementation, as it always pushes
+and shifts pointers to other SVs without changing their reference
+count, with the array becoming empty before it is freed. However, it
+makes it conceptually clear what is going on, and will avoid some
+work inside av.c, filling slots between AvFILL() and AvMAX() with
+&PL_sv_undef, and SvREFCNT_dec()ing those.  */
+AvREAL_off(param->stashes);
+if (!(flags & CLONEf_COPY_STACKS)) {
+	param->unreferenced = newAV();
+}
+#ifdef PERLIO_LAYERS
+/* Clone PerlIO tables as soon as we can handle general xx_dup() */
+PerlIO_clone(aTHX_ proto_perl, param);
+#endif
+PL_envgv		= gv_dup_inc(proto_perl->Ienvgv, param);
+PL_incgv		= gv_dup_inc(proto_perl->Iincgv, param);
+PL_hintgv		= gv_dup_inc(proto_perl->Ihintgv, param);
+PL_origfilename	= SAVEPV(proto_perl->Iorigfilename);
+PL_xsubfilename	= proto_perl->Ixsubfilename;
+PL_diehook		= sv_dup_inc(proto_perl->Idiehook, param);
+PL_warnhook		= sv_dup_inc(proto_perl->Iwarnhook, param);
+/* switches */
+PL_patchlevel	= sv_dup_inc(proto_perl->Ipatchlevel, param);
+PL_inplace		= SAVEPV(proto_perl->Iinplace);
+PL_e_script		= sv_dup_inc(proto_perl->Ie_script, param);
+/* magical thingies */
+PL_encoding		= sv_dup(proto_perl->Iencoding, param);
+PL_lex_encoding     = sv_dup(proto_perl->Ilex_encoding, param);
+sv_setpvs(PERL_DEBUG_PAD(0), "");	/* For regex debugging. */
+sv_setpvs(PERL_DEBUG_PAD(1), "");	/* ext/re needs these */
+sv_setpvs(PERL_DEBUG_PAD(2), "");	/* even without DEBUGGING. */
+/* Clone the regex array */
+/* ORANGE FIXME for plugins, probably in the SV dup code.
+newSViv(PTR2IV(CALLREGDUPE(
+INT2PTR(REGEXP *, SvIVX(regex)), param))))
+*/
+PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
+PL_regex_pad = AvARRAY(PL_regex_padav);
+PL_stashpadmax	= proto_perl->Istashpadmax;
+PL_stashpadix	= proto_perl->Istashpadix ;
+Newx(PL_stashpad, PL_stashpadmax, HV *);
+{
+	PADOFFSET o = 0;
+	for (; o < PL_stashpadmax; ++o)
+	    PL_stashpad[o] = hv_dup(proto_perl->Istashpad[o], param);
+}
+/* shortcuts to various I/O objects */
+PL_ofsgv            = gv_dup_inc(proto_perl->Iofsgv, param);
+PL_stdingv		= gv_dup(proto_perl->Istdingv, param);
+PL_stderrgv		= gv_dup(proto_perl->Istderrgv, param);
+PL_defgv		= gv_dup(proto_perl->Idefgv, param);
+PL_argvgv		= gv_dup_inc(proto_perl->Iargvgv, param);
+PL_argvoutgv	= gv_dup(proto_perl->Iargvoutgv, param);
+PL_argvout_stack	= av_dup_inc(proto_perl->Iargvout_stack, param);
+/* shortcuts to regexp stuff */
+PL_replgv		= gv_dup_inc(proto_perl->Ireplgv, param);
+/* shortcuts to misc objects */
+PL_errgv		= gv_dup(proto_perl->Ierrgv, param);
+/* shortcuts to debugging objects */
+PL_DBgv		= gv_dup_inc(proto_perl->IDBgv, param);
+PL_DBline		= gv_dup_inc(proto_perl->IDBline, param);
+PL_DBsub		= gv_dup_inc(proto_perl->IDBsub, param);
+PL_DBsingle		= sv_dup(proto_perl->IDBsingle, param);
+PL_DBtrace		= sv_dup(proto_perl->IDBtrace, param);
+PL_DBsignal		= sv_dup(proto_perl->IDBsignal, param);
+Copy(proto_perl->IDBcontrol, PL_DBcontrol, DBVARMG_COUNT, IV);
+/* symbol tables */
+PL_defstash		= hv_dup_inc(proto_perl->Idefstash, param);
+PL_curstash		= hv_dup_inc(proto_perl->Icurstash, param);
+PL_debstash		= hv_dup(proto_perl->Idebstash, param);
+PL_globalstash	= hv_dup(proto_perl->Iglobalstash, param);
+PL_curstname	= sv_dup_inc(proto_perl->Icurstname, param);
+PL_beginav		= av_dup_inc(proto_perl->Ibeginav, param);
+PL_beginav_save	= av_dup_inc(proto_perl->Ibeginav_save, param);
+PL_checkav_save	= av_dup_inc(proto_perl->Icheckav_save, param);
+PL_unitcheckav      = av_dup_inc(proto_perl->Iunitcheckav, param);
+PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
+PL_endav		= av_dup_inc(proto_perl->Iendav, param);
+PL_checkav		= av_dup_inc(proto_perl->Icheckav, param);
+PL_initav		= av_dup_inc(proto_perl->Iinitav, param);
+PL_savebegin	= proto_perl->Isavebegin;
+PL_isarev		= hv_dup_inc(proto_perl->Iisarev, param);
+/* subprocess state */
+PL_fdpid		= av_dup_inc(proto_perl->Ifdpid, param);
+if (proto_perl->Iop_mask)
+	PL_op_mask	= SAVEPVN(proto_perl->Iop_mask, PL_maxo);
+else
+	PL_op_mask 	= NULL;
+/* PL_asserting        = proto_perl->Iasserting; */
+/* current interpreter roots */
+PL_main_cv		= cv_dup_inc(proto_perl->Imain_cv, param);
+OP_REFCNT_LOCK;
+PL_main_root	= OpREFCNT_inc(proto_perl->Imain_root);
+OP_REFCNT_UNLOCK;
+/* runtime control stuff */
+PL_curcopdb		= (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
+PL_preambleav	= av_dup_inc(proto_perl->Ipreambleav, param);
+PL_ors_sv		= sv_dup_inc(proto_perl->Iors_sv, param);
+/* interpreter atexit processing */
+PL_exitlistlen	= proto_perl->Iexitlistlen;
+if (PL_exitlistlen) {
+	Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
+	Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
+}
+else
+	PL_exitlist	= (PerlExitListEntry*)NULL;
+PL_my_cxt_size = proto_perl->Imy_cxt_size;
+if (PL_my_cxt_size) {
+	Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
+	Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
+#ifdef PERL_GLOBAL_STRUCT_PRIVATE
+	Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
+	Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
+#endif
+}
+else {
+	PL_my_cxt_list	= (void**)NULL;
+#ifdef PERL_GLOBAL_STRUCT_PRIVATE
+	PL_my_cxt_keys	= (const char**)NULL;
+#endif
+}
+PL_modglobal	= hv_dup_inc(proto_perl->Imodglobal, param);
+PL_custom_op_names  = hv_dup_inc(proto_perl->Icustom_op_names,param);
+PL_custom_op_descs  = hv_dup_inc(proto_perl->Icustom_op_descs,param);
+PL_custom_ops	= hv_dup_inc(proto_perl->Icustom_ops, param);
+PL_compcv			= cv_dup(proto_perl->Icompcv, param);
+PAD_CLONE_VARS(proto_perl, param);
+#ifdef HAVE_INTERP_INTERN
+sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
+#endif
+PL_DBcv		= cv_dup(proto_perl->IDBcv, param);
+#ifdef PERL_USES_PL_PIDSTATUS
+PL_pidstatus	= newHV();			/* XXX flag for cloning? */
+#endif
+PL_osname		= SAVEPV(proto_perl->Iosname);
+PL_parser		= parser_dup(proto_perl->Iparser, param);
+/* XXX this only works if the saved cop has already been cloned */
+if (proto_perl->Iparser) {
+	PL_parser->saved_curcop = (COP*)any_dup(
+				    proto_perl->Iparser->saved_curcop,
+				    proto_perl);
+}
+PL_subname		= sv_dup_inc(proto_perl->Isubname, param);
+#ifdef USE_LOCALE_CTYPE
+/* Should we warn if uses locale? */
+PL_warn_locale      = sv_dup_inc(proto_perl->Iwarn_locale, param);
+#endif
+#ifdef USE_LOCALE_COLLATE
+PL_collation_name	= SAVEPV(proto_perl->Icollation_name);
+#endif /* USE_LOCALE_COLLATE */
+#ifdef USE_LOCALE_NUMERIC
+PL_numeric_name	= SAVEPV(proto_perl->Inumeric_name);
+PL_numeric_radix_sv	= sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
+#endif /* !USE_LOCALE_NUMERIC */
+/* Unicode inversion lists */
+PL_Latin1		= sv_dup_inc(proto_perl->ILatin1, param);
+PL_UpperLatin1	= sv_dup_inc(proto_perl->IUpperLatin1, param);
+PL_AboveLatin1	= sv_dup_inc(proto_perl->IAboveLatin1, param);
+PL_InBitmap         = sv_dup_inc(proto_perl->IInBitmap, param);
+PL_NonL1NonFinalFold = sv_dup_inc(proto_perl->INonL1NonFinalFold, param);
+PL_HasMultiCharFold = sv_dup_inc(proto_perl->IHasMultiCharFold, param);
+/* utf8 character class swashes */
+for (i = 0; i < POSIX_SWASH_COUNT; i++) {
+PL_utf8_swash_ptrs[i] = sv_dup_inc(proto_perl->Iutf8_swash_ptrs[i], param);
+}
+for (i = 0; i < POSIX_CC_COUNT; i++) {
+PL_XPosix_ptrs[i] = sv_dup_inc(proto_perl->IXPosix_ptrs[i], param);
+}
+PL_GCB_invlist = sv_dup_inc(proto_perl->IGCB_invlist, param);
+PL_SB_invlist = sv_dup_inc(proto_perl->ISB_invlist, param);
+PL_WB_invlist = sv_dup_inc(proto_perl->IWB_invlist, param);
+PL_utf8_mark	= sv_dup_inc(proto_perl->Iutf8_mark, param);
+PL_utf8_toupper	= sv_dup_inc(proto_perl->Iutf8_toupper, param);
+PL_utf8_totitle	= sv_dup_inc(proto_perl->Iutf8_totitle, param);
+PL_utf8_tolower	= sv_dup_inc(proto_perl->Iutf8_tolower, param);
+PL_utf8_tofold	= sv_dup_inc(proto_perl->Iutf8_tofold, param);
+PL_utf8_idstart	= sv_dup_inc(proto_perl->Iutf8_idstart, param);
+PL_utf8_xidstart	= sv_dup_inc(proto_perl->Iutf8_xidstart, param);
+PL_utf8_perl_idstart = sv_dup_inc(proto_perl->Iutf8_perl_idstart, param);
+PL_utf8_perl_idcont = sv_dup_inc(proto_perl->Iutf8_perl_idcont, param);
+PL_utf8_idcont	= sv_dup_inc(proto_perl->Iutf8_idcont, param);
+PL_utf8_xidcont	= sv_dup_inc(proto_perl->Iutf8_xidcont, param);
+PL_utf8_foldable	= sv_dup_inc(proto_perl->Iutf8_foldable, param);
+PL_utf8_charname_begin = sv_dup_inc(proto_perl->Iutf8_charname_begin, param);
+PL_utf8_charname_continue = sv_dup_inc(proto_perl->Iutf8_charname_continue, param);
+if (proto_perl->Ipsig_pend) {
+	Newxz(PL_psig_pend, SIG_SIZE, int);
+}
+else {
+	PL_psig_pend	= (int*)NULL;
+}
+if (proto_perl->Ipsig_name) {
+	Newx(PL_psig_name, 2 * SIG_SIZE, SV*);
+	sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE,
+			    param);
+	PL_psig_ptr = PL_psig_name + SIG_SIZE;
+}
+else {
+	PL_psig_ptr	= (SV**)NULL;
+	PL_psig_name	= (SV**)NULL;
+}
+if (flags & CLONEf_COPY_STACKS) {
+	Newx(PL_tmps_stack, PL_tmps_max, SV*);
+	sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack,
+			    PL_tmps_ix+1, param);
+	/* next PUSHMARK() sets *(PL_markstack_ptr+1) */
+	i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
+	Newxz(PL_markstack, i, I32);
+	PL_markstack_max	= PL_markstack + (proto_perl->Imarkstack_max
+						  - proto_perl->Imarkstack);
+	PL_markstack_ptr	= PL_markstack + (proto_perl->Imarkstack_ptr
+						  - proto_perl->Imarkstack);
+	Copy(proto_perl->Imarkstack, PL_markstack,
+	     PL_markstack_ptr - PL_markstack + 1, I32);
+	/* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
+	 * NOTE: unlike the others! */
+	Newxz(PL_scopestack, PL_scopestack_max, I32);
+	Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
+#ifdef DEBUGGING
+	Newxz(PL_scopestack_name, PL_scopestack_max, const char *);
+	Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *);
+#endif
+/* reset stack AV to correct length before its duped via
+* PL_curstackinfo */
+AvFILLp(proto_perl->Icurstack) =
+proto_perl->Istack_sp - proto_perl->Istack_base;
+	/* NOTE: si_dup() looks at PL_markstack */
+	PL_curstackinfo		= si_dup(proto_perl->Icurstackinfo, param);
+	/* PL_curstack		= PL_curstackinfo->si_stack; */
+	PL_curstack		= av_dup(proto_perl->Icurstack, param);
+	PL_mainstack		= av_dup(proto_perl->Imainstack, param);
+	/* next PUSHs() etc. set *(PL_stack_sp+1) */
+	PL_stack_base		= AvARRAY(PL_curstack);
+	PL_stack_sp		= PL_stack_base + (proto_perl->Istack_sp
+						   - proto_perl->Istack_base);
+	PL_stack_max		= PL_stack_base + AvMAX(PL_curstack);
+	/*Newxz(PL_savestack, PL_savestack_max, ANY);*/
+	PL_savestack		= ss_dup(proto_perl, param);
+}
+else {
+	init_stacks();
+	ENTER;			/* perl_destruct() wants to LEAVE; */
+}
+PL_statgv		= gv_dup(proto_perl->Istatgv, param);
+PL_statname		= sv_dup_inc(proto_perl->Istatname, param);
+PL_rs		= sv_dup_inc(proto_perl->Irs, param);
+PL_last_in_gv	= gv_dup(proto_perl->Ilast_in_gv, param);
+PL_defoutgv		= gv_dup_inc(proto_perl->Idefoutgv, param);
+PL_toptarget	= sv_dup_inc(proto_perl->Itoptarget, param);
+PL_bodytarget	= sv_dup_inc(proto_perl->Ibodytarget, param);
+PL_formtarget	= sv_dup(proto_perl->Iformtarget, param);
+PL_errors		= sv_dup_inc(proto_perl->Ierrors, param);
+PL_sortcop		= (OP*)any_dup(proto_perl->Isortcop, proto_perl);
+PL_firstgv		= gv_dup_inc(proto_perl->Ifirstgv, param);
+PL_secondgv		= gv_dup_inc(proto_perl->Isecondgv, param);
+PL_stashcache       = newHV();
+PL_watchaddr	= (char **) ptr_table_fetch(PL_ptr_table,
+					    proto_perl->Iwatchaddr);
+PL_watchok		= PL_watchaddr ? * PL_watchaddr : NULL;
+if (PL_debug && PL_watchaddr) {
+	PerlIO_printf(Perl_debug_log,
+	  "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
+	  PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
+	  PTR2UV(PL_watchok));
+}
+PL_registered_mros  = hv_dup_inc(proto_perl->Iregistered_mros, param);
+PL_blockhooks	= av_dup_inc(proto_perl->Iblockhooks, param);
+PL_utf8_foldclosures = hv_dup_inc(proto_perl->Iutf8_foldclosures, param);
+/* Call the ->CLONE method, if it exists, for each of the stashes
+identified by sv_dup() above.
+*/
+while(av_tindex(param->stashes) != -1) {
+	HV* const stash = MUTABLE_HV(av_shift(param->stashes));
+	GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
+	if (cloner && GvCV(cloner)) {
+	    dSP;
+	    ENTER;
+	    SAVETMPS;
+	    PUSHMARK(SP);
+	    mXPUSHs(newSVhek(HvNAME_HEK(stash)));
+	    PUTBACK;
+	    call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
+	    FREETMPS;
+	    LEAVE;
+	}
+}
+if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
+ptr_table_free(PL_ptr_table);
+PL_ptr_table = NULL;
+}
+if (!(flags & CLONEf_COPY_STACKS)) {
+	unreferenced_to_tmp_stack(param->unreferenced);
+}
+SvREFCNT_dec(param->stashes);
+/* orphaned? eg threads->new inside BEGIN or use */
+if (PL_compcv && ! SvREFCNT(PL_compcv)) {
+	SvREFCNT_inc_simple_void(PL_compcv);
+	SAVEFREESV(PL_compcv);
+}
+return my_perl;
+}
+static void
+S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced)
+{
+PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK;
+if (AvFILLp(unreferenced) > -1) {
+	SV **svp = AvARRAY(unreferenced);
+	SV **const last = svp + AvFILLp(unreferenced);
+	SSize_t count = 0;
+	do {
+	    if (SvREFCNT(*svp) == 1)
+		++count;
+	} while (++svp <= last);
+	EXTEND_MORTAL(count);
+	svp = AvARRAY(unreferenced);
+	do {
+	    if (SvREFCNT(*svp) == 1) {
+		/* Our reference is the only one to this SV. This means that
+		   in this thread, the scalar effectively has a 0 reference.
+		   That doesn't work (cleanup never happens), so donate our
+		   reference to it onto the save stack. */
+		PL_tmps_stack[++PL_tmps_ix] = *svp;
+	    } else {
+		/* As an optimisation, because we are already walking the
+		   entire array, instead of above doing either
+		   SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead
+		   release our reference to the scalar, so that at the end of
+		   the array owns zero references to the scalars it happens to
+		   point to. We are effectively converting the array from
+		   AvREAL() on to AvREAL() off. This saves the av_clear()
+		   (triggered by the SvREFCNT_dec(unreferenced) below) from
+		   walking the array a second time.  */
+		SvREFCNT_dec(*svp);
+	    }
+	} while (++svp <= last);
+	AvREAL_off(unreferenced);
+}
+SvREFCNT_dec_NN(unreferenced);
+}
+void
+Perl_clone_params_del(CLONE_PARAMS *param)
+{
+/* This seemingly funky ordering keeps the build with PERL_GLOBAL_STRUCT
+happy: */
+PerlInterpreter *const to = param->new_perl;
+dTHXa(to);
+PerlInterpreter *const was = PERL_GET_THX;
+PERL_ARGS_ASSERT_CLONE_PARAMS_DEL;
+if (was != to) {
+	PERL_SET_THX(to);
+}
+SvREFCNT_dec(param->stashes);
+if (param->unreferenced)
+	unreferenced_to_tmp_stack(param->unreferenced);
+Safefree(param);
+if (was != to) {
+	PERL_SET_THX(was);
+}
+}
+CLONE_PARAMS *
+Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
+{
+dVAR;
+/* Need to play this game, as newAV() can call safesysmalloc(), and that
+does a dTHX; to get the context from thread local storage.
+FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to
+a version that passes in my_perl.  */
+PerlInterpreter *const was = PERL_GET_THX;
+CLONE_PARAMS *param;
+PERL_ARGS_ASSERT_CLONE_PARAMS_NEW;
+if (was != to) {
+	PERL_SET_THX(to);
+}
+/* Given that we've set the context, we can do this unshared.  */
+Newx(param, 1, CLONE_PARAMS);
+param->flags = 0;
+param->proto_perl = from;
+param->new_perl = to;
+param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV);
+AvREAL_off(param->stashes);
+param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV);
+if (was != to) {
+	PERL_SET_THX(was);
+}
+return param;
+}
+#endif /* USE_ITHREADS */
+void
+Perl_init_constants(pTHX)
+{
+SvREFCNT(&PL_sv_undef)	= SvREFCNT_IMMORTAL;
+SvFLAGS(&PL_sv_undef)	= SVf_READONLY|SVf_PROTECT|SVt_NULL;
+SvANY(&PL_sv_undef)		= NULL;
+SvANY(&PL_sv_no)		= new_XPVNV();
+SvREFCNT(&PL_sv_no)		= SvREFCNT_IMMORTAL;
+SvFLAGS(&PL_sv_no)		= SVt_PVNV|SVf_READONLY|SVf_PROTECT
+				  |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
+				  |SVp_POK|SVf_POK;
+SvANY(&PL_sv_yes)		= new_XPVNV();
+SvREFCNT(&PL_sv_yes)	= SvREFCNT_IMMORTAL;
+SvFLAGS(&PL_sv_yes)		= SVt_PVNV|SVf_READONLY|SVf_PROTECT
+				  |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
+				  |SVp_POK|SVf_POK;
+SvPV_set(&PL_sv_no, (char*)PL_No);
+SvCUR_set(&PL_sv_no, 0);
+SvLEN_set(&PL_sv_no, 0);
+SvIV_set(&PL_sv_no, 0);
+SvNV_set(&PL_sv_no, 0);
+SvPV_set(&PL_sv_yes, (char*)PL_Yes);
+SvCUR_set(&PL_sv_yes, 1);
+SvLEN_set(&PL_sv_yes, 0);
+SvIV_set(&PL_sv_yes, 1);
+SvNV_set(&PL_sv_yes, 1);
+PadnamePV(&PL_padname_const) = (char *)PL_No;
+}
+/*
+=head1 Unicode Support
+=for apidoc sv_recode_to_utf8
+The encoding is assumed to be an Encode object, on entry the PV
+of the sv is assumed to be octets in that encoding, and the sv
+will be converted into Unicode (and UTF-8).
+If the sv already is UTF-8 (or if it is not POK), or if the encoding
+is not a reference, nothing is done to the sv.  If the encoding is not
+an C<Encode::XS> Encoding object, bad things will happen.
+(See F<lib/encoding.pm> and L<Encode>.)
+The PV of the sv is returned.
+=cut */
+char *
+Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
+{
+PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
+if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
+	SV *uni;
+	STRLEN len;
+	const char *s;
+	dSP;
+	SV *nsv = sv;
+	ENTER;
+	PUSHSTACK;
+	SAVETMPS;
+	if (SvPADTMP(nsv)) {
+	    nsv = sv_newmortal();
+	    SvSetSV_nosteal(nsv, sv);
+	}
+	save_re_context();
+	PUSHMARK(sp);
+	EXTEND(SP, 3);
+	PUSHs(encoding);
+	PUSHs(nsv);
+/*
+NI-S 2002/07/09
+Passing sv_yes is wrong - it needs to be or'ed set of constants
+for Encode::XS, while UTf-8 decode (currently) assumes a true value means
+remove converted chars from source.
+Both will default the value - let them.
+	XPUSHs(&PL_sv_yes);
+*/
+	PUTBACK;
+	call_method("decode", G_SCALAR);
+	SPAGAIN;
+	uni = POPs;
+	PUTBACK;
+	s = SvPV_const(uni, len);
+	if (s != SvPVX_const(sv)) {
+	    SvGROW(sv, len + 1);
+	    Move(s, SvPVX(sv), len + 1, char);
+	    SvCUR_set(sv, len);
+	}
+	FREETMPS;
+	POPSTACK;
+	LEAVE;
+	if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+	    /* clear pos and any utf8 cache */
+	    MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
+	    if (mg)
+		mg->mg_len = -1;
+	    if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
+		magic_setutf8(sv,mg); /* clear UTF8 cache */
+	}
+	SvUTF8_on(sv);
+	return SvPVX(sv);
+}
+return SvPOKp(sv) ? SvPVX(sv) : NULL;
+}
+/*
+=for apidoc sv_cat_decode
+The encoding is assumed to be an Encode object, the PV of the ssv is
+assumed to be octets in that encoding and decoding the input starts
+from the position which (PV + *offset) pointed to.  The dsv will be
+concatenated the decoded UTF-8 string from ssv.  Decoding will terminate
+when the string tstr appears in decoding output or the input ends on
+the PV of the ssv.  The value which the offset points will be modified
+to the last input position on the ssv.
+Returns TRUE if the terminator was found, else returns FALSE.
+=cut */
+bool
+Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
+		   SV *ssv, int *offset, char *tstr, int tlen)
+{
+bool ret = FALSE;
+PERL_ARGS_ASSERT_SV_CAT_DECODE;
+if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding)) {
+	SV *offsv;
+	dSP;
+	ENTER;
+	SAVETMPS;
+	save_re_context();
+	PUSHMARK(sp);
+	EXTEND(SP, 6);
+	PUSHs(encoding);
+	PUSHs(dsv);
+	PUSHs(ssv);
+	offsv = newSViv(*offset);
+	mPUSHs(offsv);
+	mPUSHp(tstr, tlen);
+	PUTBACK;
+	call_method("cat_decode", G_SCALAR);
+	SPAGAIN;
+	ret = SvTRUE(TOPs);
+	*offset = SvIV(offsv);
+	PUTBACK;
+	FREETMPS;
+	LEAVE;
+}
+else
+Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
+return ret;
+}
+/* ---------------------------------------------------------------------
+*
+* support functions for report_uninit()
+*/
+/* the maxiumum size of array or hash where we will scan looking
+* for the undefined element that triggered the warning */
+#define FUV_MAX_SEARCH_SIZE 1000
+/* Look for an entry in the hash whose value has the same SV as val;
+* If so, return a mortal copy of the key. */
+STATIC SV*
+S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
+{
+dVAR;
+HE **array;
+I32 i;
+PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
+if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
+			(HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
+	return NULL;
+array = HvARRAY(hv);
+for (i=HvMAX(hv); i>=0; i--) {
+	HE *entry;
+	for (entry = array[i]; entry; entry = HeNEXT(entry)) {
+	    if (HeVAL(entry) != val)
+		continue;
+	    if (    HeVAL(entry) == &PL_sv_undef ||
+		    HeVAL(entry) == &PL_sv_placeholder)
+		continue;
+	    if (!HeKEY(entry))
+		return NULL;
+	    if (HeKLEN(entry) == HEf_SVKEY)
+		return sv_mortalcopy(HeKEY_sv(entry));
+	    return sv_2mortal(newSVhek(HeKEY_hek(entry)));
+	}
+}
+return NULL;
+}
+/* Look for an entry in the array whose value has the same SV as val;
+* If so, return the index, otherwise return -1. */
+STATIC I32
+S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
+{
+PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
+if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
+			(AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
+	return -1;
+if (val != &PL_sv_undef) {
+	SV ** const svp = AvARRAY(av);
+	I32 i;
+	for (i=AvFILLp(av); i>=0; i--)
+	    if (svp[i] == val)
+		return i;
+}
+return -1;
+}
+/* varname(): return the name of a variable, optionally with a subscript.
+* If gv is non-zero, use the name of that global, along with gvtype (one
+* of "$", "@", "%"); otherwise use the name of the lexical at pad offset
+* targ.  Depending on the value of the subscript_type flag, return:
+*/
+#define FUV_SUBSCRIPT_NONE	1	/* "@foo"          */
+#define FUV_SUBSCRIPT_ARRAY	2	/* "$foo[aindex]"  */
+#define FUV_SUBSCRIPT_HASH	3	/* "$foo{keyname}" */
+#define FUV_SUBSCRIPT_WITHIN	4	/* "within @foo"   */
+SV*
+Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
+	const SV *const keyname, I32 aindex, int subscript_type)
+{
+SV * const name = sv_newmortal();
+if (gv && isGV(gv)) {
+	char buffer[2];
+	buffer[0] = gvtype;
+	buffer[1] = 0;
+	/* as gv_fullname4(), but add literal '^' for $^FOO names  */
+	gv_fullname4(name, gv, buffer, 0);
+	if ((unsigned int)SvPVX(name)[1] <= 26) {
+	    buffer[0] = '^';
+	    buffer[1] = SvPVX(name)[1] + 'A' - 1;
+	    /* Swap the 1 unprintable control character for the 2 byte pretty
+	       version - ie substr($name, 1, 1) = $buffer; */
+	    sv_insert(name, 1, 1, buffer, 2);
+	}
+}
+else {
+	CV * const cv = gv ? ((CV *)gv) : find_runcv(NULL);
+	PADNAME *sv;
+	assert(!cv || SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
+	if (!cv || !CvPADLIST(cv))
+	    return NULL;
+	sv = padnamelist_fetch(PadlistNAMES(CvPADLIST(cv)), targ);
+	sv_setpvn(name, PadnamePV(sv), PadnameLEN(sv));
+	SvUTF8_on(name);
+}
+if (subscript_type == FUV_SUBSCRIPT_HASH) {
+	SV * const sv = newSV(0);
+	*SvPVX(name) = '$';
+	Perl_sv_catpvf(aTHX_ name, "{%s}",
+	    pv_pretty(sv, SvPVX_const(keyname), SvCUR(keyname), 32, NULL, NULL,
+		    PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT ));
+	SvREFCNT_dec_NN(sv);
+}
+else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
+	*SvPVX(name) = '$';
+	Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
+}
+else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
+	/* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
+	Perl_sv_insert_flags(aTHX_ name, 0, 0,  STR_WITH_LEN("within "), 0);
+}
+return name;
+}
+/*
+=for apidoc find_uninit_var
+Find the name of the undefined variable (if any) that caused the operator
+to issue a "Use of uninitialized value" warning.
+If match is true, only return a name if its value matches uninit_sv.
+So roughly speaking, if a unary operator (such as OP_COS) generates a
+warning, then following the direct child of the op may yield an
+OP_PADSV or OP_GV that gives the name of the undefined variable.  On the
+other hand, with OP_ADD there are two branches to follow, so we only print
+the variable name if we get an exact match.
+desc_p points to a string pointer holding the description of the op.
+This may be updated if needed.
+The name is returned as a mortal SV.
+Assumes that PL_op is the op that originally triggered the error, and that
+PL_comppad/PL_curpad points to the currently executing pad.
+=cut
+*/
+STATIC SV *
+S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
+		  bool match, const char **desc_p)
+{
+dVAR;
+SV *sv;
+const GV *gv;
+const OP *o, *o2, *kid;
+PERL_ARGS_ASSERT_FIND_UNINIT_VAR;
+if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
+			    uninit_sv == &PL_sv_placeholder)))
+	return NULL;
+switch (obase->op_type) {
+case OP_RV2AV:
+case OP_RV2HV:
+case OP_PADAV:
+case OP_PADHV:
+{
+	const bool pad  = (    obase->op_type == OP_PADAV
+|| obase->op_type == OP_PADHV
+|| obase->op_type == OP_PADRANGE
+);
+	const bool hash = (    obase->op_type == OP_PADHV
+|| obase->op_type == OP_RV2HV
+|| (obase->op_type == OP_PADRANGE
+&& SvTYPE(PAD_SVl(obase->op_targ)) == SVt_PVHV)
+);
+	I32 index = 0;
+	SV *keysv = NULL;
+	int subscript_type = FUV_SUBSCRIPT_WITHIN;
+	if (pad) { /* @lex, %lex */
+	    sv = PAD_SVl(obase->op_targ);
+	    gv = NULL;
+	}
+	else {
+	    if (cUNOPx(obase)->op_first->op_type == OP_GV) {
+	    /* @global, %global */
+		gv = cGVOPx_gv(cUNOPx(obase)->op_first);
+		if (!gv)
+		    break;
+		sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
+	    }
+	    else if (obase == PL_op) /* @{expr}, %{expr} */
+		return find_uninit_var(cUNOPx(obase)->op_first,
+uninit_sv, match, desc_p);
+	    else /* @{expr}, %{expr} as a sub-expression */
+		return NULL;
+	}
+	/* attempt to find a match within the aggregate */
+	if (hash) {
+	    keysv = find_hash_subscript((const HV*)sv, uninit_sv);
+	    if (keysv)
+		subscript_type = FUV_SUBSCRIPT_HASH;
+	}
+	else {
+	    index = find_array_subscript((const AV *)sv, uninit_sv);
+	    if (index >= 0)
+		subscript_type = FUV_SUBSCRIPT_ARRAY;
+	}
+	if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
+	    break;
+	return varname(gv, (char)(hash ? '%' : '@'), obase->op_targ,
+				    keysv, index, subscript_type);
+}
+case OP_RV2SV:
+	if (cUNOPx(obase)->op_first->op_type == OP_GV) {
+	    /* $global */
+	    gv = cGVOPx_gv(cUNOPx(obase)->op_first);
+	    if (!gv || !GvSTASH(gv))
+		break;
+	    if (match && (GvSV(gv) != uninit_sv))
+		break;
+	    return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
+	}
+	/* ${expr} */
+	return find_uninit_var(cUNOPx(obase)->op_first, uninit_sv, 1, desc_p);
+case OP_PADSV:
+	if (match && PAD_SVl(obase->op_targ) != uninit_sv)
+	    break;
+	return varname(NULL, '$', obase->op_targ,
+				    NULL, 0, FUV_SUBSCRIPT_NONE);
+case OP_GVSV:
+	gv = cGVOPx_gv(obase);
+	if (!gv || (match && GvSV(gv) != uninit_sv) || !GvSTASH(gv))
+	    break;
+	return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
+case OP_AELEMFAST_LEX:
+	if (match) {
+	    SV **svp;
+	    AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
+	    if (!av || SvRMAGICAL(av))
+		break;
+	    svp = av_fetch(av, (I8)obase->op_private, FALSE);
+	    if (!svp || *svp != uninit_sv)
+		break;
+	}
+	return varname(NULL, '$', obase->op_targ,
+		       NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY);
+case OP_AELEMFAST:
+	{
+	    gv = cGVOPx_gv(obase);
+	    if (!gv)
+		break;
+	    if (match) {
+		SV **svp;
+		AV *const av = GvAV(gv);
+		if (!av || SvRMAGICAL(av))
+		    break;
+		svp = av_fetch(av, (I8)obase->op_private, FALSE);
+		if (!svp || *svp != uninit_sv)
+		    break;
+	    }
+	    return varname(gv, '$', 0,
+		    NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY);
+	}
+	NOT_REACHED; /* NOTREACHED */
+case OP_EXISTS:
+	o = cUNOPx(obase)->op_first;
+	if (!o || o->op_type != OP_NULL ||
+		! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
+	    break;
+	return find_uninit_var(cBINOPo->op_last, uninit_sv, match, desc_p);
+case OP_AELEM:
+case OP_HELEM:
+{
+	bool negate = FALSE;
+	if (PL_op == obase)
+	    /* $a[uninit_expr] or $h{uninit_expr} */
+	    return find_uninit_var(cBINOPx(obase)->op_last,
+uninit_sv, match, desc_p);
+	gv = NULL;
+	o = cBINOPx(obase)->op_first;
+	kid = cBINOPx(obase)->op_last;
+	/* get the av or hv, and optionally the gv */
+	sv = NULL;
+	if  (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
+	    sv = PAD_SV(o->op_targ);
+	}
+	else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
+		&& cUNOPo->op_first->op_type == OP_GV)
+	{
+	    gv = cGVOPx_gv(cUNOPo->op_first);
+	    if (!gv)
+		break;
+	    sv = o->op_type
+		== OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv));
+	}
+	if (!sv)
+	    break;
+	if (kid && kid->op_type == OP_NEGATE) {
+	    negate = TRUE;
+	    kid = cUNOPx(kid)->op_first;
+	}
+	if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
+	    /* index is constant */
+	    SV* kidsv;
+	    if (negate) {
+		kidsv = newSVpvs_flags("-", SVs_TEMP);
+		sv_catsv(kidsv, cSVOPx_sv(kid));
+	    }
+	    else
+		kidsv = cSVOPx_sv(kid);
+	    if (match) {
+		if (SvMAGICAL(sv))
+		    break;
+		if (obase->op_type == OP_HELEM) {
+		    HE* he = hv_fetch_ent(MUTABLE_HV(sv), kidsv, 0, 0);
+		    if (!he || HeVAL(he) != uninit_sv)
+			break;
+		}
+		else {
+		    SV * const  opsv = cSVOPx_sv(kid);
+		    const IV  opsviv = SvIV(opsv);
+		    SV * const * const svp = av_fetch(MUTABLE_AV(sv),
+			negate ? - opsviv : opsviv,
+			FALSE);
+		    if (!svp || *svp != uninit_sv)
+			break;
+		}
+	    }
+	    if (obase->op_type == OP_HELEM)
+		return varname(gv, '%', o->op_targ,
+			    kidsv, 0, FUV_SUBSCRIPT_HASH);
+	    else
+		return varname(gv, '@', o->op_targ, NULL,
+		    negate ? - SvIV(cSVOPx_sv(kid)) : SvIV(cSVOPx_sv(kid)),
+		    FUV_SUBSCRIPT_ARRAY);
+	}
+	else  {
+	    /* index is an expression;
+	     * attempt to find a match within the aggregate */
+	    if (obase->op_type == OP_HELEM) {
+		SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
+		if (keysv)
+		    return varname(gv, '%', o->op_targ,
+						keysv, 0, FUV_SUBSCRIPT_HASH);
+	    }
+	    else {
+		const I32 index
+		    = find_array_subscript((const AV *)sv, uninit_sv);
+		if (index >= 0)
+		    return varname(gv, '@', o->op_targ,
+					NULL, index, FUV_SUBSCRIPT_ARRAY);
+	    }
+	    if (match)
+		break;
+	    return varname(gv,
+		(char)((o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
+		? '@' : '%'),
+		o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
+	}
+	NOT_REACHED; /* NOTREACHED */
+}
+case OP_MULTIDEREF: {
+/* If we were executing OP_MULTIDEREF when the undef warning
+* triggered, then it must be one of the index values within
+* that triggered it. If not, then the only possibility is that
+* the value retrieved by the last aggregate lookup might be the
+* culprit. For the former, we set PL_multideref_pc each time before
+* using an index, so work though the item list until we reach
+* that point. For the latter, just work through the entire item
+* list; the last aggregate retrieved will be the candidate.
+*/
+/* the named aggregate, if any */
+PADOFFSET agg_targ = 0;
+GV       *agg_gv   = NULL;
+/* the last-seen index */
+UV        index_type;
+PADOFFSET index_targ;
+GV       *index_gv;
+IV        index_const_iv = 0; /* init for spurious compiler warn */
+SV       *index_const_sv;
+int       depth = 0;  /* how many array/hash lookups we've done */
+UNOP_AUX_item *items = cUNOP_AUXx(obase)->op_aux;
+UNOP_AUX_item *last = NULL;
+UV actions = items->uv;
+bool is_hv;
+if (PL_op == obase) {
+last = PL_multideref_pc;
+assert(last >= items && last <= items + items[-1].uv);
+}
+assert(actions);
+while (1) {
+is_hv = FALSE;
+switch (actions & MDEREF_ACTION_MASK) {
+case MDEREF_reload:
+actions = (++items)->uv;
+continue;
+case MDEREF_HV_padhv_helem:               /* $lex{...} */
+is_hv = TRUE;
+/* FALLTHROUGH */
+case MDEREF_AV_padav_aelem:               /* $lex[...] */
+agg_targ = (++items)->pad_offset;
+agg_gv = NULL;
+break;
+case MDEREF_HV_gvhv_helem:                /* $pkg{...} */
+is_hv = TRUE;
+/* FALLTHROUGH */
+case MDEREF_AV_gvav_aelem:                /* $pkg[...] */
+agg_targ = 0;
+agg_gv = (GV*)UNOP_AUX_item_sv(++items);
+assert(isGV_with_GP(agg_gv));
+break;
+case MDEREF_HV_gvsv_vivify_rv2hv_helem:   /* $pkg->{...} */
+case MDEREF_HV_padsv_vivify_rv2hv_helem:  /* $lex->{...} */
+++items;
+/* FALLTHROUGH */
+case MDEREF_HV_pop_rv2hv_helem:           /* expr->{...} */
+case MDEREF_HV_vivify_rv2hv_helem:        /* vivify, ->{...} */
+agg_targ = 0;
+agg_gv   = NULL;
+is_hv    = TRUE;
+break;
+case MDEREF_AV_gvsv_vivify_rv2av_aelem:   /* $pkg->[...] */
+case MDEREF_AV_padsv_vivify_rv2av_aelem:  /* $lex->[...] */
+++items;
+/* FALLTHROUGH */
+case MDEREF_AV_pop_rv2av_aelem:           /* expr->[...] */
+case MDEREF_AV_vivify_rv2av_aelem:        /* vivify, ->[...] */
+agg_targ = 0;
+agg_gv   = NULL;
+} /* switch */
+index_targ     = 0;
+index_gv       = NULL;
+index_const_sv = NULL;
+index_type = (actions & MDEREF_INDEX_MASK);
+switch (index_type) {
+case MDEREF_INDEX_none:
+break;
+case MDEREF_INDEX_const:
+if (is_hv)
+index_const_sv = UNOP_AUX_item_sv(++items)
+else
+index_const_iv = (++items)->iv;
+break;
+case MDEREF_INDEX_padsv:
+index_targ = (++items)->pad_offset;
+break;
+case MDEREF_INDEX_gvsv:
+index_gv = (GV*)UNOP_AUX_item_sv(++items);
+assert(isGV_with_GP(index_gv));
+break;
+}
+if (index_type != MDEREF_INDEX_none)
+depth++;
+if (   index_type == MDEREF_INDEX_none
+|| (actions & MDEREF_FLAG_last)
+|| (last && items == last)
+)
+break;
+actions >>= MDEREF_SHIFT;
+} /* while */
+	if (PL_op == obase) {
+	    /* index was undef */
+*desc_p = (    (actions & MDEREF_FLAG_last)
+&& (obase->op_private
+& (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE)))
+?
+(obase->op_private & OPpMULTIDEREF_EXISTS)
+? "exists"
+: "delete"
+: is_hv ? "hash element" : "array element";
+assert(index_type != MDEREF_INDEX_none);
+if (index_gv)
+return varname(index_gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
+if (index_targ)
+return varname(NULL, '$', index_targ,
+				    NULL, 0, FUV_SUBSCRIPT_NONE);
+assert(is_hv); /* AV index is an IV and can't be undef */
+/* can a const HV index ever be undef? */
+return NULL;
+}
+/* the SV returned by pp_multideref() was undef, if anything was */
+if (depth != 1)
+break;
+if (agg_targ)
+	    sv = PAD_SV(agg_targ);
+else if (agg_gv)
+sv = is_hv ? MUTABLE_SV(GvHV(agg_gv)) : MUTABLE_SV(GvAV(agg_gv));
+else
+break;
+	if (index_type == MDEREF_INDEX_const) {
+	    if (match) {
+		if (SvMAGICAL(sv))
+		    break;
+		if (is_hv) {
+		    HE* he = hv_fetch_ent(MUTABLE_HV(sv), index_const_sv, 0, 0);
+		    if (!he || HeVAL(he) != uninit_sv)
+			break;
+		}
+		else {
+		    SV * const * const svp =
+av_fetch(MUTABLE_AV(sv), index_const_iv, FALSE);
+		    if (!svp || *svp != uninit_sv)
+			break;
+		}
+	    }
+	    return is_hv
+		? varname(agg_gv, '%', agg_targ,
+index_const_sv, 0,    FUV_SUBSCRIPT_HASH)
+		: varname(agg_gv, '@', agg_targ,
+NULL, index_const_iv, FUV_SUBSCRIPT_ARRAY);
+	}
+	else  {
+	    /* index is an var */
+	    if (is_hv) {
+		SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
+		if (keysv)
+		    return varname(agg_gv, '%', agg_targ,
+						keysv, 0, FUV_SUBSCRIPT_HASH);
+	    }
+	    else {
+		const I32 index
+		    = find_array_subscript((const AV *)sv, uninit_sv);
+		if (index >= 0)
+		    return varname(agg_gv, '@', agg_targ,
+					NULL, index, FUV_SUBSCRIPT_ARRAY);
+	    }
+	    if (match)
+		break;
+	    return varname(agg_gv,
+		is_hv ? '%' : '@',
+		agg_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
+	}
+	NOT_REACHED; /* NOTREACHED */
+}
+case OP_AASSIGN:
+	/* only examine RHS */
+	return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv,
+match, desc_p);
+case OP_OPEN:
+	o = cUNOPx(obase)->op_first;
+	if (   o->op_type == OP_PUSHMARK
+	   || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)
+)
+o = OpSIBLING(o);
+	if (!OpHAS_SIBLING(o)) {
+	    /* one-arg version of open is highly magical */
+	    if (o->op_type == OP_GV) { /* open FOO; */
+		gv = cGVOPx_gv(o);
+		if (match && GvSV(gv) != uninit_sv)
+		    break;
+		return varname(gv, '$', 0,
+			    NULL, 0, FUV_SUBSCRIPT_NONE);
+	    }
+	    /* other possibilities not handled are:
+	     * open $x; or open my $x;	should return '${*$x}'
+	     * open expr;		should return '$'.expr ideally
+	     */
+	     break;
+	}
+	goto do_op;
+/* ops where $_ may be an implicit arg */
+case OP_TRANS:
+case OP_TRANSR:
+case OP_SUBST:
+case OP_MATCH:
+	if ( !(obase->op_flags & OPf_STACKED)) {
+	    if (uninit_sv == DEFSV)
+		return newSVpvs_flags("$_", SVs_TEMP);
+	    else if (obase->op_targ
+		  && uninit_sv == PAD_SVl(obase->op_targ))
+		return varname(NULL, '$', obase->op_targ, NULL, 0,
+			       FUV_SUBSCRIPT_NONE);
+	}
+	goto do_op;
+case OP_PRTF:
+case OP_PRINT:
+case OP_SAY:
+	match = 1; /* print etc can return undef on defined args */
+	/* skip filehandle as it can't produce 'undef' warning  */
+	o = cUNOPx(obase)->op_first;
+	if ((obase->op_flags & OPf_STACKED)
+&&
+(   o->op_type == OP_PUSHMARK
+|| (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)))
+o = OpSIBLING(OpSIBLING(o));
+	goto do_op2;
+case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
+case OP_CUSTOM: /* XS or custom code could trigger random warnings */
+	/* the following ops are capable of returning PL_sv_undef even for
+	 * defined arg(s) */
+case OP_BACKTICK:
+case OP_PIPE_OP:
+case OP_FILENO:
+case OP_BINMODE:
+case OP_TIED:
+case OP_GETC:
+case OP_SYSREAD:
+case OP_SEND:
+case OP_IOCTL:
+case OP_SOCKET:
+case OP_SOCKPAIR:
+case OP_BIND:
+case OP_CONNECT:
+case OP_LISTEN:
+case OP_ACCEPT:
+case OP_SHUTDOWN:
+case OP_SSOCKOPT:
+case OP_GETPEERNAME:
+case OP_FTRREAD:
+case OP_FTRWRITE:
+case OP_FTREXEC:
+case OP_FTROWNED:
+case OP_FTEREAD:
+case OP_FTEWRITE:
+case OP_FTEEXEC:
+case OP_FTEOWNED:
+case OP_FTIS:
+case OP_FTZERO:
+case OP_FTSIZE:
+case OP_FTFILE:
+case OP_FTDIR:
+case OP_FTLINK:
+case OP_FTPIPE:
+case OP_FTSOCK:
+case OP_FTBLK:
+case OP_FTCHR:
+case OP_FTTTY:
+case OP_FTSUID:
+case OP_FTSGID:
+case OP_FTSVTX:
+case OP_FTTEXT:
+case OP_FTBINARY:
+case OP_FTMTIME:
+case OP_FTATIME:
+case OP_FTCTIME:
+case OP_READLINK:
+case OP_OPEN_DIR:
+case OP_READDIR:
+case OP_TELLDIR:
+case OP_SEEKDIR:
+case OP_REWINDDIR:
+case OP_CLOSEDIR:
+case OP_GMTIME:
+case OP_ALARM:
+case OP_SEMGET:
+case OP_GETLOGIN:
+case OP_UNDEF:
+case OP_SUBSTR:
+case OP_AEACH:
+case OP_EACH:
+case OP_SORT:
+case OP_CALLER:
+case OP_DOFILE:
+case OP_PROTOTYPE:
+case OP_NCMP:
+case OP_SMARTMATCH:
+case OP_UNPACK:
+case OP_SYSOPEN:
+case OP_SYSSEEK:
+	match = 1;
+	goto do_op;
+case OP_ENTERSUB:
+case OP_GOTO:
+	/* XXX tmp hack: these two may call an XS sub, and currently
+	  XS subs don't have a SUB entry on the context stack, so CV and
+	  pad determination goes wrong, and BAD things happen. So, just
+	  don't try to determine the value under those circumstances.
+	  Need a better fix at dome point. DAPM 11/2007 */
+	break;
+case OP_FLIP:
+case OP_FLOP:
+{
+	GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV);
+	if (gv && GvSV(gv) == uninit_sv)
+	    return newSVpvs_flags("$.", SVs_TEMP);
+	goto do_op;
+}
+case OP_POS:
+	/* def-ness of rval pos() is independent of the def-ness of its arg */
+	if ( !(obase->op_flags & OPf_MOD))
+	    break;
+case OP_SCHOMP:
+case OP_CHOMP:
+	if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
+	    return newSVpvs_flags("${$/}", SVs_TEMP);
+	/* FALLTHROUGH */
+default:
+do_op:
+	if (!(obase->op_flags & OPf_KIDS))
+	    break;
+	o = cUNOPx(obase)->op_first;
+do_op2:
+	if (!o)
+	    break;
+	/* This loop checks all the kid ops, skipping any that cannot pos-
+	 * sibly be responsible for the uninitialized value; i.e., defined
+	 * constants and ops that return nothing.  If there is only one op
+	 * left that is not skipped, then we *know* it is responsible for
+	 * the uninitialized value.  If there is more than one op left, we
+	 * have to look for an exact match in the while() loop below.
+* Note that we skip padrange, because the individual pad ops that
+* it replaced are still in the tree, so we work on them instead.
+	 */
+	o2 = NULL;
+	for (kid=o; kid; kid = OpSIBLING(kid)) {
+	    const OPCODE type = kid->op_type;
+	    if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
+	      || (type == OP_NULL  && ! (kid->op_flags & OPf_KIDS))
+	      || (type == OP_PUSHMARK)
+	      || (type == OP_PADRANGE)
+	    )
+	    continue;
+	    if (o2) { /* more than one found */
+		o2 = NULL;
+		break;
+	    }
+	    o2 = kid;
+	}
+	if (o2)
+	    return find_uninit_var(o2, uninit_sv, match, desc_p);
+	/* scan all args */
+	while (o) {
+	    sv = find_uninit_var(o, uninit_sv, 1, desc_p);
+	    if (sv)
+		return sv;
+	    o = OpSIBLING(o);
+	}
+	break;
+}
+return NULL;
+}
+/*
+=for apidoc report_uninit
+Print appropriate "Use of uninitialized variable" warning.
+=cut
+*/
+void
+Perl_report_uninit(pTHX_ const SV *uninit_sv)
+{
+if (PL_op) {
+	SV* varname = NULL;
+	const char *desc;
+	desc = PL_op->op_type == OP_STRINGIFY && PL_op->op_folded
+		? "join or string"
+		: OP_DESC(PL_op);
+	if (uninit_sv && PL_curpad) {
+	    varname = find_uninit_var(PL_op, uninit_sv, 0, &desc);
+	    if (varname)
+		sv_insert(varname, 0, 0, " ", 1);
+	}
+/* PL_warn_uninit_sv is constant */
+GCC_DIAG_IGNORE(-Wformat-nonliteral);
+	/* diag_listed_as: Use of uninitialized value%s */
+	Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit_sv,
+		SVfARG(varname ? varname : &PL_sv_no),
+		" in ", desc);
+GCC_DIAG_RESTORE;
+}
+else {
+/* PL_warn_uninit is constant */
+GCC_DIAG_IGNORE(-Wformat-nonliteral);
+	Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
+		    "", "", "");
+GCC_DIAG_RESTORE;
+}
+}
+/*
+* ex: set ts=8 sts=4 sw=4 et:
+*/

Mercurial > repo

comparison perl-5.22.2/sv.c @ 8045:a16537d2fe07