Merge branch 'release-5.38.0' into blead

[perl5.git] / sv.c

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

static const char S_destroy[] = "DESTROY";
#define S_destroy_len (sizeof(S_destroy)-1)

/* ============================================================================

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 internal function visit() scans the SV arenas list, and calls a specified
function for each SV it finds which is still live, I<i.e.> 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_body()
    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 DEBUG_LEAKING_SCALARS
#  define FREE_SV_DEBUG_FILE(sv) STMT_START { \
        if ((sv)->sv_debug_file) {                   \
            PerlMemShared_free((sv)->sv_debug_file); \
            sv->sv_debug_file = NULL;                \
        }                                            \
    } 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

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


/* make some more SVs by adding another arena */

SV*
Perl_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;
}

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


/*
=for apidoc_section $SV

=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 (!SvIS_FREED(sv)
                    && (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 (!SvIS_FREED(sv)) {
        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;
}

/*
  Historically, here were mid-level routines that manage the
  allocation of bodies out of the various arenas. Some of these
  routines and related definitions remain here, but others were
  moved into sv_inline.h to facilitate inlining of newSV_type().

  There are 4 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 don't 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 type 4)

  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.

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_from_arena 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_ARENA_ROOT_IX=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. Similarly SVt_IV is re-used for HVAUX_ARENA_ROOT_IX.

*/

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


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)
    static bool 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;
    }
}

/*
=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<L</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 *referent = 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)) {
            referent = 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:
    case SVt_PVOBJ:
        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 = S_new_body(aTHX_ new_type);
        /* xpvav and xpvhv have no offset, so no need to adjust new_body */
        assert(!(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;
        switch(new_type) {
        case SVt_PVAV:
            {
                XPVAV pvav = {
                    .xmg_stash = NULL,
                    .xmg_u = {.xmg_magic = NULL},
                    .xav_fill = -1, .xav_max = -1, .xav_alloc = 0
                };
                *((XPVAV*) SvANY(sv)) = pvav;
            }

            AvREAL_only(sv);
            break;
        case SVt_PVHV:
            {
                XPVHV pvhv = {
                    .xmg_stash = NULL,
                    .xmg_u = {.xmg_magic = NULL},
                    .xhv_keys = 0,
                    /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
                    .xhv_max = PERL_HASH_DEFAULT_HvMAX
                };
                *((XPVHV*) SvANY(sv)) = pvhv;
            }

            assert(!SvOK(sv));
            SvOK_off(sv);
#ifndef NODEFAULT_SHAREKEYS
            HvSHAREKEYS_on(sv);         /* key-sharing on by default */
#endif
            break;
        case SVt_PVOBJ:
            {
                XPVOBJ pvo = {
                    .xmg_stash = NULL, .xmg_u = {.xmg_magic = NULL},
                    .xobject_maxfield = -1,
                    .xobject_iter_sv_at = 0,
                    .xobject_fields = NULL,
                };
                *((XPVOBJ*) SvANY(sv)) = pvo;
            }
            break;
        default:
            NOT_REACHED;
        }

        /* 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..  */
#ifndef PURIFY
        if(new_type_details->arena) {
            /* This points to the start of the allocated area.  */
            new_body = S_new_body(aTHX_ new_type);
            Zero(new_body, new_type_details->body_size, char);
            new_body = ((char *)new_body) - new_type_details->offset;
        } else
#endif
        {
            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 (old_type < SVt_PV) {
            /* referent will be NULL unless the old type was SVt_IV emulating
               SVt_RV */
            sv->sv_u.svu_rv = referent;
        }
        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
    }
}

struct xpvhv_aux*
Perl_hv_auxalloc(pTHX_ HV *hv) {
    const struct body_details *old_type_details = bodies_by_type + SVt_PVHV;
    void *old_body;
    void *new_body;

    PERL_ARGS_ASSERT_HV_AUXALLOC;
    assert(SvTYPE(hv) == SVt_PVHV);
    assert(!HvHasAUX(hv));

#ifdef PURIFY
    new_body = new_NOARENAZ(&fake_hv_with_aux);
#else
    new_body_from_arena(new_body, HVAUX_ARENA_ROOT_IX, fake_hv_with_aux);
#endif

    old_body = SvANY(hv);

    Copy((char *)old_body + old_type_details->offset,
         (char *)new_body + fake_hv_with_aux.offset,
         old_type_details->copy,
         char);

#ifdef PURIFY
    safefree(old_body);
#else
    assert(old_type_details->arena);
    del_body((void*)((char*)old_body + old_type_details->offset),
             &PL_body_roots[SVt_PVHV]);
#endif

    SvANY(hv) = (XPVHV *) new_body;
    SvFLAGS(hv) |= SVphv_HasAUX;
    return HvAUX(hv);
}

/*
=for apidoc sv_backoff

Remove any string offset.  You should normally use the C<SvOOK_off> macro
wrapper instead.

=cut
*/

/* prior to 5.000 stable, this function returned the new OOK-less SvFLAGS
   prior to 5.23.4 this function always returned 0
*/

void
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);
    SvFLAGS(sv) &= ~SVf_OOK;
    Move(s, SvPVX(sv), SvCUR(sv)+1, char);
    return;
}


/* forward declaration */
static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags);


/*
=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
*/


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_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.
     *
     * Only increment if the allocation isn't MEM_SIZE_MAX,
     * otherwise it will wrap to 0.
     */
    if ( 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) + PERL_STRLEN_NEW_MIN;
        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, 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_grow_fresh

A cut-down version of sv_grow intended only for when sv is a freshly-minted
SVt_PV, SVt_PVIV, SVt_PVNV, or SVt_PVMG. i.e. sv has the default flags, has
never been any other type, and does not have an existing string. Basically,
just assigns a char buffer and returns a pointer to it.

=cut
*/


char *
Perl_sv_grow_fresh(pTHX_ SV *const sv, STRLEN newlen)
{
    char *s;

    PERL_ARGS_ASSERT_SV_GROW_FRESH;

    assert(SvTYPE(sv) >= SVt_PV && SvTYPE(sv) <= SVt_PVMG);
    assert(!SvROK(sv));
    assert(!SvOOK(sv));
    assert(!SvIsCOW(sv));
    assert(!SvLEN(sv));
    assert(!SvCUR(sv));

#ifdef PERL_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.
     *
     * Only increment if the allocation isn't MEM_SIZE_MAX,
     * otherwise it will wrap to 0.
     */
    if ( newlen != MEM_SIZE_MAX )
        newlen++;
#endif

    if (newlen < PERL_STRLEN_NEW_MIN)
        newlen = PERL_STRLEN_NEW_MIN;

    s = (char*)safemalloc(newlen);
    SvPV_set(sv, s);

    /* No PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC here, since many strings */
    /* will never be grown once set. Let the real sv_grow worry about that. */
    SvLEN_set(sv, newlen);
    return s;
}

/*
=for apidoc sv_setiv
=for apidoc_item sv_setiv_mg

These copy an integer into the given SV, upgrading first if necessary.

They differ only in that C<sv_setiv_mg> handles 'set' magic; C<sv_setiv> does
not.

=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)) {
#if NVSIZE <= IVSIZE
    case SVt_NULL:
    case SVt_NV:
        SET_SVANY_FOR_BODYLESS_IV(sv);
        SvFLAGS(sv) &= ~SVTYPEMASK;
        SvFLAGS(sv) |= SVt_IV;
        break;
#else
    case SVt_NULL:
        SET_SVANY_FOR_BODYLESS_IV(sv);
        SvFLAGS(sv) &= ~SVTYPEMASK;
        SvFLAGS(sv) |= SVt_IV;
        break;
    case SVt_NV:
        sv_upgrade(sv, SVt_IV);
        break;
#endif
    case SVt_PV:
        sv_upgrade(sv, SVt_PVIV);
        break;

    case SVt_PVGV:
        if (!isGV_with_GP(sv))
            break;
        /* FALLTHROUGH */
    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));
        NOT_REACHED; /* NOTREACHED */
        break;
    default: NOOP;
    }
    (void)SvIOK_only(sv);                       /* validate number */
    SvIV_set(sv, i);
    SvTAINT(sv);
}

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
=for apidoc_item sv_setuv_mg

These copy an unsigned integer into the given SV, upgrading first if necessary.


They differ only in that C<sv_setuv_mg> handles 'set' magic; C<sv_setuv> does
not.

=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);
}

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
=for apidoc_item sv_setnv_mg

These copy a double into the given SV, upgrading first if necessary.

They differ only in that C<sv_setnv_mg> handles 'set' magic; C<sv_setnv> does
not.

=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:
#if NVSIZE <= IVSIZE
        SET_SVANY_FOR_BODYLESS_NV(sv);
        SvFLAGS(sv) &= ~SVTYPEMASK;
        SvFLAGS(sv) |= SVt_NV;
        break;
#else
        sv_upgrade(sv, SVt_NV);
        break;
#endif
    case SVt_PV:
    case SVt_PVIV:
        sv_upgrade(sv, SVt_PVNV);
        break;

    case SVt_PVGV:
        if (!isGV_with_GP(sv))
            break;
        /* FALLTHROUGH */
    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));
        NOT_REACHED; /* NOTREACHED */
        break;
    default: NOOP;
    }
    SvNV_set(sv, num);
    (void)SvNOK_only(sv);                       /* validate number */
    SvTAINT(sv);
}

void
Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
{
    PERL_ARGS_ASSERT_SV_SETNV_MG;

    sv_setnv(sv,num);
    SvSETMAGIC(sv);
}

/*
=for apidoc sv_setrv_noinc
=for apidoc_item sv_setrv_noinc_mg

Copies an SV pointer into the given SV as an SV reference, upgrading it if
necessary. After this, C<SvRV(sv)> is equal to I<ref>. This does not adjust
the reference count of I<ref>. The reference I<ref> must not be NULL.

C<sv_setrv_noinc_mg> will invoke 'set' magic on the SV; C<sv_setrv_noinc> will
not.

=cut
*/

void
Perl_sv_setrv_noinc(pTHX_ SV *const sv, SV *const ref)
{
    PERL_ARGS_ASSERT_SV_SETRV_NOINC;

    SV_CHECK_THINKFIRST_COW_DROP(sv);
    prepare_SV_for_RV(sv);

    SvOK_off(sv);
    SvRV_set(sv, ref);
    SvROK_on(sv);
}

void
Perl_sv_setrv_noinc_mg(pTHX_ SV *const sv, SV *const ref)
{
    PERL_ARGS_ASSERT_SV_SETRV_NOINC_MG;

    sv_setrv_noinc(sv, ref);
    SvSETMAGIC(sv);
}

/*
=for apidoc sv_setrv_inc
=for apidoc_item sv_setrv_inc_mg

As C<sv_setrv_noinc> but increments the reference count of I<ref>.

C<sv_setrv_inc_mg> will invoke 'set' magic on the SV; C<sv_setrv_inc> will
not.

=cut
*/

void
Perl_sv_setrv_inc(pTHX_ SV *const sv, SV *const ref)
{
    PERL_ARGS_ASSERT_SV_SETRV_INC;

    sv_setrv_noinc(sv, SvREFCNT_inc_simple_NN(ref));
}

void
Perl_sv_setrv_inc_mg(pTHX_ SV *const sv, SV *const ref)
{
    PERL_ARGS_ASSERT_SV_SETRV_INC_MG;

    sv_setrv_noinc(sv, SvREFCNT_inc_simple_NN(ref));
    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, 32, 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 = (U8) *s;
               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 C<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) < IV_MAX_P1) {
        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). */
static void
S_sv_setnv(pTHX_ SV* sv, int numtype)
{
    bool pok = cBOOL(SvPOK(sv));
    bool nok = FALSE;
#ifdef NV_INF
    if ((numtype & IS_NUMBER_INFINITY)) {
        SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
        nok = TRUE;
    } else
#endif
#ifdef NV_NAN
    if ((numtype & IS_NUMBER_NAN)) {
        SvNV_set(sv, NV_NAN);
        nok = TRUE;
    } else
#endif
    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. */
    }
}

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

    got_nv:
        (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;
        int numtype;
        const char *s = SvPVX_const(sv);
        const STRLEN cur = SvCUR(sv);

        /* short-cut for a single digit string like "1" */

        if (cur == 1) {
            char c = *s;
            if (isDIGIT(c)) {
                if (SvTYPE(sv) < SVt_PVIV)
                    sv_upgrade(sv, SVt_PVIV);
                (void)SvIOK_on(sv);
                SvIV_set(sv, (IV)(c - '0'));
                return FALSE;
            }
        }

        numtype = grok_number(s, cur, &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);
            goto got_nv;        /* Fill IV/UV slot and set IOKp */
        }

        /* 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
            SvNOKp_on(sv);
            if (numtype)
                SvNOK_on(sv);
            goto got_nv;        /* Fill IV/UV slot and set IOKp, maybe IOK */
#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(Perl_fabs(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);
                    /* There had been runtime checking for
                       "U_V(Perl_fabs(SvNVX(sv))) < (UV)IV_MAX" here to ensure
                       that this NV is in the preserved range, but this should
                       be always true if the following assertion is true: */
                    STATIC_ASSERT_STMT(((UV)1 << NV_PRESERVES_UV_BITS) <=
                                       (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
                }
            }
        /* 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);
#endif /* NV_PRESERVES_UV */
        }
    }
    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 C<flags> has the C<SV_GMAGIC> bit set, does an C<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, 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(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)) {
        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 C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.

=for apidoc Amnh||SV_GMAGIC

=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(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)) {
        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 C<flags> has the C<SV_GMAGIC> bit set, does an C<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);
            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;
        }
        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));
        }
        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);
        CLANG_DIAG_IGNORE_STMT(-Wthread-safety);
        DEBUG_c({
            DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
            STORE_LC_NUMERIC_SET_STANDARD();
            PerlIO_printf(Perl_debug_log,
                          "0x%" UVxf " num(%" NVgf ")\n",
                          PTR2UV(sv), SvNVX(sv));
            RESTORE_LC_NUMERIC();
        });
        CLANG_DIAG_RESTORE_STMT;

    }
    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(Perl_fabs(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;
    }
    CLANG_DIAG_IGNORE_STMT(-Wthread-safety);
    DEBUG_c({
        DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
        STORE_LC_NUMERIC_SET_STANDARD();
        PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2nv(%" NVgf ")\n",
                      PTR2UV(sv), SvNVX(sv));
        RESTORE_LC_NUMERIC();
    });
    CLANG_DIAG_RESTORE_STMT;
    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))));
}

/* int2str_table: lookup table containing string representations of all
 * two digit numbers. For example, int2str_table.arr[0] is "00" and
 * int2str_table.arr[12*2] is "12".
 *
 * We are going to read two bytes at a time, so we have to ensure that
 * the array is aligned to a 2 byte boundary. That's why it was made a
 * union with a dummy U16 member. */
static const union {
    char arr[200];
    U16 dummy;
} int2str_table = {{
    '0', '0', '0', '1', '0', '2', '0', '3', '0', '4', '0', '5', '0', '6',
    '0', '7', '0', '8', '0', '9', '1', '0', '1', '1', '1', '2', '1', '3',
    '1', '4', '1', '5', '1', '6', '1', '7', '1', '8', '1', '9', '2', '0',
    '2', '1', '2', '2', '2', '3', '2', '4', '2', '5', '2', '6', '2', '7',
    '2', '8', '2', '9', '3', '0', '3', '1', '3', '2', '3', '3', '3', '4',
    '3', '5', '3', '6', '3', '7', '3', '8', '3', '9', '4', '0', '4', '1',
    '4', '2', '4', '3', '4', '4', '4', '5', '4', '6', '4', '7', '4', '8',
    '4', '9', '5', '0', '5', '1', '5', '2', '5', '3', '5', '4', '5', '5',
    '5', '6', '5', '7', '5', '8', '5', '9', '6', '0', '6', '1', '6', '2',
    '6', '3', '6', '4', '6', '5', '6', '6', '6', '7', '6', '8', '6', '9',
    '7', '0', '7', '1', '7', '2', '7', '3', '7', '4', '7', '5', '7', '6',
    '7', '7', '7', '8', '7', '9', '8', '0', '8', '1', '8', '2', '8', '3',
    '8', '4', '8', '5', '8', '6', '8', '7', '8', '8', '8', '9', '9', '0',
    '9', '1', '9', '2', '9', '3', '9', '4', '9', '5', '9', '6', '9', '7',
    '9', '8', '9', '9'
}};

/* 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.
 */

PERL_STATIC_INLINE 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;
    U16 *word_ptr, *word_table;

    PERL_ARGS_ASSERT_UIV_2BUF;

    /* ptr has to be properly aligned, because we will cast it to U16* */
    assert(PTR2nat(ptr) % 2 == 0);
    /* we are going to read/write two bytes at a time */
    word_ptr = (U16*)ptr;
    word_table = (U16*)int2str_table.arr;

    if (UNLIKELY(is_uv))
        sign = 0;
    else if (iv >= 0) {
        uv = iv;
        sign = 0;
    } else {
        /* Using 0- here to silence bogus warning from MS VC */
        uv = (UV) (0 - (UV) iv);
        sign = 1;
    }

    while (uv > 99) {
        *--word_ptr = word_table[uv % 100];
        uv /= 100;
    }
    ptr = (char*)word_ptr;

    if (uv < 10)
        *--ptr = (char)uv + '0';
    else {
        *--word_ptr = word_table[uv];
        ptr = (char*)word_ptr;
    }

    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)
 * returns zero, assert-fails on maxlen being too short.
 *
 * 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) {
    char* s = buffer;
    assert(maxlen >= 4);
    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;
}

/*
=for apidoc      sv_2pv
=for apidoc_item sv_2pv_flags

These implement the various forms of the L<perlapi/C<SvPV>> macros.
The macros are the preferred interface.

These return a pointer to the string value of an SV (coercing it to a string if
necessary), and set C<*lp> to its length in bytes.

The forms differ in that plain C<sv_2pvbyte> always processes 'get' magic; and
C<sv_2pvbyte_flags> processes 'get' magic if and only if C<flags> contains
C<SV_GMAGIC>.

=for apidoc Amnh||SV_GMAGIC

=cut
*/

char *
Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const U32 flags)
{
    char *s;
    bool done_gmagic = FALSE;

    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);
        done_gmagic = TRUE;
    }

    if (SvROK(sv)) {
        if (SvAMAGIC(sv)) {
            SV *tmpstr;
            SV *nsv= (SV *)sv;
            if (flags & SV_SKIP_OVERLOAD)
                return NULL;
            if (done_gmagic)
                nsv = sv_mortalcopy_flags(sv,0);
            tmpstr = AMG_CALLunary(nsv, string_amg);
            TAINT_IF(tmpstr && SvTAINTED(tmpstr));
            if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(nsv)))) {
                /* 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 typestring = sv_reftype(referent, 0);
                const STRLEN typelen = strlen(typestring);
                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, typestring, 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);
        /* The purpose of this union is to ensure that arr is aligned on
           a 2 byte boundary, because that is what uiv_2buf() requires */
        union {
            char arr[TYPE_CHARS(UV)];
            U16 dummy;
        } buf;
        char *ebuf, *ptr;
        STRLEN len;

        if (SvTYPE(sv) < SVt_PVIV)
            sv_upgrade(sv, SVt_PVIV);
        ptr = uiv_2buf(buf.arr, 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';
        /* We used to call SvPOK_on(). Whilst this is fine for (most) Perl code,
           it means that after this stringification is cached, there is no way
           to distinguish between values originally assigned as $a = 42; and
           $a = "42"; (or results of string operators vs numeric operators)
           where the value has subsequently been used in the other sense
           and had a value cached.
           This (somewhat) hack means that we retain the cached stringification,
           but don't set SVf_POK. Hence if a value is SVf_IOK|SVf_POK then it
           originated as "42", whereas if it's SVf_IOK then it originated as 42.
           (ignore SVp_IOK and SVp_POK)
           The SvPV macros are now updated to recognise this specific case
           (and that there isn't overloading or magic that could alter the
           cached value) and so return the cached value immediately without
           re-entering this function, getting back here to this block of code,
           and repeating the same conversion. */
        SvPOKp_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;
                SvPOKp_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);

                SvPOKp_on(sv);
#else
                {
                    bool local_radix;
                    DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
                    STORE_LC_NUMERIC_SET_TO_NEEDED();

                    local_radix = NOT_IN_NUMERIC_STANDARD_;
                    if (local_radix && SvCUR(PL_numeric_radix_sv) > 1) {
                        size += SvCUR(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
                        && SvUTF8(PL_numeric_radix_sv)
                        && 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);
        else
            SvUTF8_off(sv);
        if (lp)
            *lp = SvCUR(buffer);
        return SvPVX(buffer);
    }
    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
=for apidoc_item sv_copypv_flags
=for apidoc_item sv_copypv_nomg

These copy a stringified representation of the source SV into the
destination SV.  They automatically perform coercion of numeric values into
strings.  Guaranteed to preserve the C<UTF8> flag even from overloaded objects.
Similar in nature to C<sv_2pv[_flags]> but they operate directly on an SV
instead of just the string.  Mostly they use L</C<sv_2pv_flags>> to
do the work, except when that would lose the UTF-8'ness of the PV.

The three forms differ only in whether or not they perform 'get magic' on
C<sv>.  C<sv_copypv_nomg> skips 'get magic'; C<sv_copypv> performs it; and
C<sv_copypv_flags> either performs it (if the C<SV_GMAGIC> bit is set in
C<flags>) or doesn't (if that bit is cleared).

=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
=for apidoc_item sv_2pvbyte_flags

These implement the various forms of the L<perlapi/C<SvPVbyte>> macros.
The macros are the preferred interface.

These return a pointer to the byte-encoded representation of the SV, and set
C<*lp> to its length.  If the SV is marked as being encoded as UTF-8, it will
be downgraded, if possible, to a byte string.  If the SV cannot be downgraded,
they croak.

The forms differ in that plain C<sv_2pvbyte> always processes 'get' magic; and
C<sv_2pvbyte_flags> processes 'get' magic if and only if C<flags> contains
C<SV_GMAGIC>.

=for apidoc Amnh||SV_GMAGIC

=cut
*/

char *
Perl_sv_2pvbyte_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags)
{
    PERL_ARGS_ASSERT_SV_2PVBYTE_FLAGS;

    if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
        mg_get(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_nomg(sv,0);
    return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
}

/*
=for apidoc      sv_2pvutf8
=for apidoc_item sv_2pvutf8_flags

These implement the various forms of the L<perlapi/C<SvPVutf8>> macros.
The macros are the preferred interface.

These return a pointer to the UTF-8-encoded representation of the SV, and set
C<*lp> to its length in bytes.  They may cause the SV to be upgraded to UTF-8
as a side-effect.

The forms differ in that plain C<sv_2pvutf8> always processes 'get' magic; and
C<sv_2pvutf8_flags> processes 'get' magic if and only if C<flags> contains
C<SV_GMAGIC>.

=cut
*/

char *
Perl_sv_2pvutf8_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags)
{
    PERL_ARGS_ASSERT_SV_2PVUTF8_FLAGS;

    if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
        mg_get(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_upgrade_nomg(sv);
    return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
}


/*
=for apidoc sv_2bool

This macro is only used by C<sv_true()> or its macro equivalent, and only if
the latter's argument is neither C<SvPOK>, C<SvIOK> nor C<SvNOK>.
It calls C<sv_2bool_flags> with the C<SV_GMAGIC> flag.

=for apidoc sv_2bool_flags

This function is only used by C<sv_true()> and friends,  and only if
the latter's argument is neither C<SvPOK>, C<SvIOK> nor C<SvNOK>.  If the flags
contain C<SV_GMAGIC>, then it does an C<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);
            }
        }
        assert(SvRV(sv));
        return TRUE;
    }
    if (isREGEXP(sv))
        return
          RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0');

    if (SvNOK(sv) && !SvPOK(sv))
        return SvNVX(sv) != 0.0;

    return SvTRUE_common(sv, 0);
}

/*
=for apidoc sv_utf8_upgrade
=for apidoc_item sv_utf8_upgrade_flags
=for apidoc_item sv_utf8_upgrade_flags_grow
=for apidoc_item sv_utf8_upgrade_nomg

These convert the PV of an SV to its UTF-8-encoded form.
The SV is forced to string form if it is not already.
They always set the C<SvUTF8> flag to avoid future validity checks even if the
whole string is the same in UTF-8 as not.
They return the number of bytes in the converted string

The forms differ in just two ways.  The main difference is whether or not they
perform 'get magic' on C<sv>.  C<sv_utf8_upgrade_nomg> skips 'get magic';
C<sv_utf8_upgrade> performs it; and C<sv_utf8_upgrade_flags> and
C<sv_utf8_upgrade_flags_grow> either perform it (if the C<SV_GMAGIC> bit is set
in C<flags>) or don't (if that bit is cleared).

The other difference is that C<sv_utf8_upgrade_flags_grow> has an additional
parameter, C<extra>, which allows the caller to specify an amount of space to
be reserved as spare beyond what is needed for the actual conversion.  This is
used when the caller knows it will soon be needing yet more space, and it is
more efficient to request space from the system in a single call.
This form is otherwise identical to C<sv_utf8_upgrade_flags>.

These are not a general purpose byte encoding to Unicode interface: use the
Encode extension for that.

The C<SV_FORCE_UTF8_UPGRADE> flag is now ignored.

=for apidoc Amnh||SV_GMAGIC|
=for apidoc Amnh||SV_FORCE_UTF8_UPGRADE|

=cut

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.

*/

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);
        }
    }

    /* SVt_REGEXP's shouldn't be upgraded to UTF8 - they're already
     * compiled and individual nodes will remain non-utf8 even if the
     * stringified version of the pattern gets upgraded. Whether the
     * PVX of a REGEXP should be grown or we should just croak, I don't
     * know - DAPM */
    if (SvUTF8(sv) || isREGEXP(sv)) {
        if (extra) SvGROW(sv, SvCUR(sv) + extra);
        return SvCUR(sv);
    }

    if (SvIsCOW(sv)) {
        S_sv_uncow(aTHX_ sv, 0);
    }

    if (SvCUR(sv) == 0) {
        if (extra) SvGROW(sv, extra + 1); /* Make sure is room for a trailing
                                             byte */
    } 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. */
        U8 * s = (U8 *) SvPVX_const(sv);
        U8 *t = s;

        if (is_utf8_invariant_string_loc(s, SvCUR(sv), (const U8 **) &t)) {

            /* 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);
        }

        /* Here, there is at least one variant (t points to the first one), so
         * the string should be converted to utf8.  Everything from 's' to
         * 't - 1' will occupy only 1 byte each on output.
         *
         * Note that the incoming SV may not have a trailing '\0', as certain
         * code in pp_formline can send us partially built SVs.
         *
         * 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.  Going this
         * route, it's probably best to initially allocate enough space in the
         * string 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.  To be sure to allocate enough
         * space, one could use the worst case scenario, where every remaining
         * byte expands to two under UTF-8, or one could parse it and count
         * exactly how many do expand.
         *
         * The other way is to unconditionally parse the remainder of the
         * string to figure out exactly how big the expanded string will be,
         * growing if needed.  Then start at the end of the string and place
         * the character there at the end of the unfilled space in the expanded
         * one, working backwards until reaching 't'.
         *
         * The problem with assuming the worst case scenario is that for very
         * long strings, we could allocate much more memory than actually
         * needed, which can create performance problems.  If we have to parse
         * anyway, the second method is the winner as it may avoid an extra
         * copy.  The code used to use the first method under some
         * circumstances, but now that there is faster variant counting on
         * ASCII platforms, the second method is used exclusively, eliminating
         * some code that no longer has to be maintained. */

        {
            /* Count the total number of variants there are.  We can start
             * just beyond the first one, which is known to be at 't' */
            const Size_t invariant_length = t - s;
            U8 * e = (U8 *) SvEND(sv);

            /* The length of the left overs, plus 1. */
            const Size_t remaining_length_p1 = e - t;

            /* We expand by 1 for the variant at 't' and one for each remaining
             * variant (we start looking at 't+1') */
            Size_t expansion = 1 + variant_under_utf8_count(t + 1, e);

            /* +1 = trailing NUL */
            Size_t need = SvCUR(sv) + expansion + extra + 1;
            U8 * d;

            /* Grow if needed */
            if (SvLEN(sv) < need) {
                t = invariant_length + (U8*) SvGROW(sv, need);
                e = t + remaining_length_p1;
            }
            SvCUR_set(sv, invariant_length + remaining_length_p1 + expansion);

            /* Set the NUL at the end */
            d = (U8 *) SvEND(sv);
            *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 */
            }
        }
    }

    SvUTF8_on(sv);
    return SvCUR(sv);
}

/*
=for apidoc sv_utf8_downgrade
=for apidoc_item sv_utf8_downgrade_flags
=for apidoc_item sv_utf8_downgrade_nomg

These attempt 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, C<FALSE> is returned if C<fail_ok> is true; otherwise they croak.

They are not a general purpose Unicode to byte encoding interface:
use the C<Encode> extension for that.

They differ only in that:

C<sv_utf8_downgrade> processes 'get' magic on C<sv>.

C<sv_utf8_downgrade_nomg> does not.

C<sv_utf8_downgrade_flags> has an additional C<flags> parameter in which you can specify
C<SV_GMAGIC> to process 'get' magic, or leave it cleared to not process 'get' magic.

=cut
*/

bool
Perl_sv_utf8_downgrade_flags(pTHX_ SV *const sv, const bool fail_ok, const U32 flags)
{
    PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE_FLAGS;

    if (SvPOKp(sv) && SvUTF8(sv)) {
        if (SvCUR(sv)) {
            U8 *s;
            STRLEN len;
            U32 mg_flags = 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,
                                                mg_flags|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 Perl's extended 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, *first_variant;

        /* 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_invariant_string_loc(c, SvCUR(sv), &first_variant)) {
            if (!is_utf8_string(first_variant, SvCUR(sv) - (first_variant -c)))
                return FALSE;
            SvUTF8_on(sv);
        }
        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
=for apidoc_item sv_setsv_flags
=for apidoc_item sv_setsv_mg
=for apidoc_item sv_setsv_nomg

These copy the contents of the source SV C<ssv> into the destination SV C<dsv>.
C<ssv> may be destroyed if it is mortal, so don't use these functions if
the source SV needs to be reused.
Loosely speaking, they perform a copy-by-value, obliterating any previous
content of the destination.

They differ only in that:

C<sv_setsv> calls 'get' magic on C<ssv>, but skips 'set' magic on C<dsv>.

C<sv_setsv_mg> calls both 'get' magic on C<ssv> and 'set' magic on C<dsv>.

C<sv_setsv_nomg> skips all magic.

C<sv_setsv_flags> has a C<flags> parameter which you can use to specify any
combination of magic handling, and also you can specify C<SV_NOSTEAL> so that
the buffers of temps will not be stolen.

You probably want to instead use one of the assortment of wrappers, such as
C<L</SvSetSV>>, C<L</SvSetSV_nosteal>>, C<L</SvSetMagicSV>> and
C<L</SvSetMagicSV_nosteal>>.

C<sv_setsv_flags> is the primary function for copying scalars, and most other
copy-ish functions and macros use it underneath.

=for apidoc Amnh||SV_NOSTEAL

=cut
*/

static void
S_glob_assign_glob(pTHX_ SV *const dsv, SV *const ssv, 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(dsv)) {
        const char * const name = GvNAME(ssv);
        const STRLEN len = GvNAMELEN(ssv);
        {
            if (dtype >= SVt_PV) {
                SvPV_free(dsv);
                SvPV_set(dsv, 0);
                SvLEN_set(dsv, 0);
                SvCUR_set(dsv, 0);
            }
            SvUPGRADE(dsv, SVt_PVGV);
            (void)SvOK_off(dsv);
            isGV_with_GP_on(dsv);
        }
        GvSTASH(dsv) = GvSTASH(ssv);
        if (GvSTASH(dsv))
            Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dsv)), dsv);
        gv_name_set(MUTABLE_GV(dsv), name, len,
                        GV_ADD | (GvNAMEUTF8(ssv) ? SVf_UTF8 : 0 ));
        SvFAKE_on(dsv); /* can coerce to non-glob */
    }

    if(GvGP(MUTABLE_GV(ssv))) {
        /* If source has method cache entry, clear it */
        if(GvCVGEN(ssv)) {
            SvREFCNT_dec(GvCV(ssv));
            GvCV_set(ssv, NULL);
            GvCVGEN(ssv) = 0;
        }
        /* If source has a real method, then a method is
           going to change */
        else if(
         GvCV((const GV *)ssv) && GvSTASH(dsv) && HvHasENAME(GvSTASH(dsv))
        ) {
            mro_changes = 1;
        }
    }

    /* If dest already had a real method, that's a change as well */
    if(
        !mro_changes && GvGP(MUTABLE_GV(dsv)) && GvCVu((const GV *)dsv)
     && GvSTASH(dsv) && HvHasENAME(GvSTASH(dsv))
    ) {
        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 *)dsv);
        const STRLEN len = GvNAMELEN(dsv);
        if(memEQs(name, len, "ISA")
         /* The stash may have been detached from the symbol table, so
            check its name. */
         && GvSTASH(dsv) && HvHasENAME(GvSTASH(dsv))
        )
            mro_changes = 2;
        else {
            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(dsv)))
                    /* 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(dsv));
    }

    /* freeing dsv's GP might free ssv (e.g. *x = $x),
     * so temporarily protect it */
    ENTER;
    SAVEFREESV(SvREFCNT_inc_simple_NN(ssv));
    gp_free(MUTABLE_GV(dsv));
    GvINTRO_off(dsv);           /* one-shot flag */
    GvGP_set(dsv, gp_ref(GvGP(ssv)));
    LEAVE;

    if (SvTAINTED(ssv))
        SvTAINT(dsv);
    if (GvIMPORTED(dsv) != GVf_IMPORTED
        && CopSTASH_ne(PL_curcop, GvSTASH(dsv)))
        {
            GvIMPORTED_on(dsv);
        }
    GvMULTI_on(dsv);
    if(mro_changes == 2) {
      if (GvAV((const GV *)ssv)) {
        MAGIC *mg;
        SV * const sref = (SV *)GvAV((const GV *)dsv);
        if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
            if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
                AV * const ary = newAV_alloc_x(2);
                av_push_simple(ary, mg->mg_obj); /* takes the refcount */
                av_push_simple(ary, SvREFCNT_inc_simple_NN(dsv));
                mg->mg_obj = (SV *)ary;
            } else {
                av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dsv));
            }
        }
        else sv_magic(sref, dsv, PERL_MAGIC_isa, NULL, 0);
      }
      mro_isa_changed_in(GvSTASH(dsv));
    }
    else if(mro_changes == 3) {
        HV * const stash = GvHV(dsv);
        if(old_stash ? HvHasENAME(old_stash) : cBOOL(stash))
            mro_package_moved(
                stash, old_stash,
                (GV *)dsv, 0
            );
    }
    else if(mro_changes) mro_method_changed_in(GvSTASH(dsv));
    if (GvIO(dsv) && 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 dsv, SV *const ssv)
{
    SV * const sref = SvRV(ssv);
    SV *dref;
    const int intro = GvINTRO(dsv);
    SV **location;
    U8 import_flag = 0;
    const U32 stype = SvTYPE(sref);

    PERL_ARGS_ASSERT_GV_SETREF;

    if (intro) {
        GvINTRO_off(dsv);       /* one-shot flag */
        GvLINE(dsv) = CopLINE(PL_curcop);
        GvEGV(dsv) = MUTABLE_GV(dsv);
    }
    GvMULTI_on(dsv);
    switch (stype) {
    case SVt_PVCV:
        location = (SV **) &(GvGP(dsv)->gp_cv); /* XXX bypassing GvCV_set */
        import_flag = GVf_IMPORTED_CV;
        goto common;
    case SVt_PVHV:
        location = (SV **) &GvHV(dsv);
        import_flag = GVf_IMPORTED_HV;
        goto common;
    case SVt_PVAV:
        location = (SV **) &GvAV(dsv);
        import_flag = GVf_IMPORTED_AV;
        goto common;
    case SVt_PVIO:
        location = (SV **) &GvIOp(dsv);
        goto common;
    case SVt_PVFM:
        location = (SV **) &GvFORM(dsv);
        goto common;
    default:
        location = &GvSV(dsv);
        import_flag = GVf_IMPORTED_SV;
    common:
        if (intro) {
            if (stype == SVt_PVCV) {
                /*if (GvCVGEN(dsv) && (GvCV(dsv) != (const CV *)sref || GvCVGEN(dsv))) {*/
                if (GvCVGEN(dsv)) {
                    SvREFCNT_dec(GvCV(dsv));
                    GvCV_set(dsv, NULL);
                    GvCVGEN(dsv) = 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(dsv);
                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(dsv))) {
            CV* const cv = MUTABLE_CV(*location);
            if (cv) {
                if (!GvCVGEN((const GV *)dsv) &&
                    (CvROOT(cv) || CvXSUB(cv)) &&
                    /* redundant check that avoids creating the extra SV
                       most of the time: */
                    (CvCONST(cv) || (ckWARN(WARN_REDEFINE) && !intro)))
                    {
                        SV * const new_const_sv =
                            CvCONST((const CV *)sref)
                                 ? cv_const_sv_or_av((const CV *)sref)
                                 : NULL;
                        HV * const stash = GvSTASH((const GV *)dsv);
                        report_redefined_cv(
                           sv_2mortal(
                             stash
                               ? Perl_newSVpvf(aTHX_
                                    "%" HEKf "::%" HEKf,
                                    HEKfARG(HvNAME_HEK(stash)),
                                    HEKfARG(GvENAME_HEK(MUTABLE_GV(dsv))))
                               : Perl_newSVpvf(aTHX_
                                    "%" HEKf,
                                    HEKfARG(GvENAME_HEK(MUTABLE_GV(dsv))))
                           ),
                           cv,
                           CvCONST((const CV *)sref) ? &new_const_sv : NULL
                        );
                    }
                if (!intro)
                    cv_ckproto_len_flags(cv, (const GV *)dsv,
                                   SvPOK(sref) ? CvPROTO(sref) : NULL,
                                   SvPOK(sref) ? CvPROTOLEN(sref) : 0,
                                   SvPOK(sref) ? SvUTF8(sref) : 0);
            }
            GvCVGEN(dsv) = 0; /* Switch off cacheness. */
            GvASSUMECV_on(dsv);
            if(GvSTASH(dsv)) { /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
                if (intro && GvREFCNT(dsv) > 1) {
                    /* temporary remove extra savestack's ref */
                    --GvREFCNT(dsv);
                    gv_method_changed(dsv);
                    ++GvREFCNT(dsv);
                }
                else gv_method_changed(dsv);
            }
        }
        *location = SvREFCNT_inc_simple_NN(sref);
        if (import_flag && !(GvFLAGS(dsv) & import_flag)
            && CopSTASH_ne(PL_curcop, GvSTASH(dsv))) {
            GvFLAGS(dsv) |= import_flag;
        }

        if (stype == SVt_PVHV) {
            const char * const name = GvNAME((GV*)dsv);
            const STRLEN len = GvNAMELEN(dsv);
            if (
                (
                   (len > 1 && name[len-2] == ':' && name[len-1] == ':')
                || (len == 1 && name[0] == ':')
                )
             && (!dref || HvHasENAME(dref))
            ) {
                mro_package_moved(
                    (HV *)sref, (HV *)dref,
                    (GV *)dsv, 0
                );
            }
        }
        else if (
            stype == SVt_PVAV && sref != dref
         && memEQs(GvNAME((GV*)dsv), GvNAMELEN((GV*)dsv), "ISA")
         /* The stash may have been detached from the symbol table, so
            check its name before doing anything. */
         && GvSTASH(dsv) && HvHasENAME(GvSTASH(dsv))
        ) {
            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_alloc_xz(4);
                    av_push_simple(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(dsv));
            }
            else
            {
                SSize_t i;
                sv_magic(
                 sref, omg ? omg->mg_obj : dsv, PERL_MAGIC_isa, NULL, 0
                );
                for (i = 0; i <= AvFILL(sref); ++i) {
                    SV **elem = av_fetch ((AV*)sref, i, 0);
                    if (elem) {
                        sv_magic(
                          *elem, sref, PERL_MAGIC_isaelem, NULL, i
                        );
                    }
                }
                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(ssv))
        SvTAINT(dsv);
    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 *dsv, SV* ssv, const I32 flags)
{
    U32 sflags;
    int dtype;
    svtype stype;
    unsigned int both_type;

    PERL_ARGS_ASSERT_SV_SETSV_FLAGS;

    if (UNLIKELY( ssv == dsv ))
        return;

    if (UNLIKELY( !ssv ))
        ssv = &PL_sv_undef;

    stype = SvTYPE(ssv);
    dtype = SvTYPE(dsv);
    both_type = (stype | dtype);

    /* with these values, we can check that both SVs are NULL/IV (and not
     * freed) just by testing the or'ed types */
    STATIC_ASSERT_STMT(SVt_NULL == 0);
    STATIC_ASSERT_STMT(SVt_IV   == 1);
    STATIC_ASSERT_STMT(SVt_NV   == 2);
#if NVSIZE <= IVSIZE
    if (both_type <= 2) {
#else
    if (both_type <= 1) {
#endif
        /* both src and dst are UNDEF/IV/RV - maybe NV depending on config,
         * so we can do a lot of special-casing */
        U32 sflags;
        U32 new_dflags;
        SV *old_rv = NULL;

        /* minimal subset of SV_CHECK_THINKFIRST_COW_DROP(dsv) */
        if (SvREADONLY(dsv))
            Perl_croak_no_modify();
        if (SvROK(dsv)) {
            if (SvWEAKREF(dsv))
                sv_unref_flags(dsv, 0);
            else
                old_rv = SvRV(dsv);
            SvROK_off(dsv);
        }

        assert(!SvGMAGICAL(ssv));
        assert(!SvGMAGICAL(dsv));

        sflags = SvFLAGS(ssv);
        if (sflags & (SVf_IOK|SVf_ROK)) {
            SET_SVANY_FOR_BODYLESS_IV(dsv);
            new_dflags = SVt_IV;

            if (sflags & SVf_ROK) {
                dsv->sv_u.svu_rv = SvREFCNT_inc(SvRV(ssv));
                new_dflags |= SVf_ROK;
            }
            else {
                /* both src and dst are <= SVt_IV, so sv_any points to the
                 * head; so access the head directly
                 */
                assert(    &(ssv->sv_u.svu_iv)
                        == &(((XPVIV*) SvANY(ssv))->xiv_iv));
                assert(    &(dsv->sv_u.svu_iv)
                        == &(((XPVIV*) SvANY(dsv))->xiv_iv));
                dsv->sv_u.svu_iv = ssv->sv_u.svu_iv;
                new_dflags |= (SVf_IOK|SVp_IOK|(sflags & SVf_IVisUV));
            }
        }
#if NVSIZE <= IVSIZE
        else if (sflags & SVf_NOK) {
            SET_SVANY_FOR_BODYLESS_NV(dsv);
            new_dflags = (SVt_NV|SVf_NOK|SVp_NOK);

            /* both src and dst are <= SVt_MV, so sv_any points to the
             * head; so access the head directly
             */
            assert(    &(ssv->sv_u.svu_nv)
                    == &(((XPVNV*) SvANY(ssv))->xnv_u.xnv_nv));
            assert(    &(dsv->sv_u.svu_nv)
                    == &(((XPVNV*) SvANY(dsv))->xnv_u.xnv_nv));
            dsv->sv_u.svu_nv = ssv->sv_u.svu_nv;
        }
#endif
        else {
            new_dflags = dtype; /* turn off everything except the type */
        }
        /* Should preserve some dsv flags - at least SVs_TEMP, */
        /* so cannot just set SvFLAGS(dsv) = new_dflags        */
        /* First clear the flags that we do want to clobber    */
        (void)SvOK_off(dsv);
        SvFLAGS(dsv) &= ~SVTYPEMASK;
        /* Now set the new flags */
        SvFLAGS(dsv) |= new_dflags;

        SvREFCNT_dec(old_rv);
        return;
    }

    if (UNLIKELY(both_type == SVTYPEMASK)) {
        if (SvIS_FREED(dsv)) {
            Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
                       " to a freed scalar %p", SVfARG(ssv), (void *)dsv);
        }
        if (SvIS_FREED(ssv)) {
            Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
                       (void*)ssv, (void*)dsv);
        }
    }



    SV_CHECK_THINKFIRST_COW_DROP(dsv);
    dtype = SvTYPE(dsv); /* THINKFIRST may have changed type */

    /* There's a lot of redundancy below but we're going for speed here
     * Note: some of the cases below do return; rather than break; so the
     * if-elseif-else logic below this switch does not see all cases. */

    switch (stype) {
    case SVt_NULL:
      undef_sstr:
        if (LIKELY( dtype != SVt_PVGV && dtype != SVt_PVLV )) {
            (void)SvOK_off(dsv);
            return;
        }
        break;
    case SVt_IV:
        if (SvIOK(ssv)) {
            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(dsv);
                SvFLAGS(dsv) |= SVt_IV;
                break;
            case SVt_NV:
            case SVt_PV:
                sv_upgrade(dsv, SVt_PVIV);
                break;
            case SVt_PVGV:
            case SVt_PVLV:
                goto end_of_first_switch;
            }
            (void)SvIOK_only(dsv);
            SvIV_set(dsv,  SvIVX(ssv));
            if (SvIsUV(ssv))
                SvIsUV_on(dsv);
            /* 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(ssv));
            return;
        }
        if (!SvROK(ssv))
            goto undef_sstr;
        if (dtype < SVt_PV && dtype != SVt_IV)
            sv_upgrade(dsv, SVt_IV);
        break;

    case SVt_NV:
        if (LIKELY( SvNOK(ssv) )) {
            switch (dtype) {
            case SVt_NULL:
            case SVt_IV:
                sv_upgrade(dsv, SVt_NV);
                break;
            case SVt_PV:
            case SVt_PVIV:
                sv_upgrade(dsv, SVt_PVNV);
                break;
            case SVt_PVGV:
            case SVt_PVLV:
                goto end_of_first_switch;
            }
            SvNV_set(dsv, SvNVX(ssv));
            (void)SvNOK_only(dsv);
            /* 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(ssv));
            return;
        }
        goto undef_sstr;

    case SVt_PV:
        if (dtype < SVt_PV)
            sv_upgrade(dsv, SVt_PV);
        break;
    case SVt_PVIV:
        if (dtype < SVt_PVIV)
            sv_upgrade(dsv, SVt_PVIV);
        break;
    case SVt_PVNV:
        if (dtype < SVt_PVNV)
            sv_upgrade(dsv, SVt_PVNV);
        break;

    case SVt_INVLIST:
        invlist_clone(ssv, dsv);
        return;
    default:
        {
        const char * const type = sv_reftype(ssv,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)
            sv_upgrade(dsv, SVt_REGEXP);
        break;

    case SVt_PVLV:
    case SVt_PVGV:
    case SVt_PVMG:
        if (SvGMAGICAL(ssv) && (flags & SV_GMAGIC)) {
            mg_get(ssv);
            if (SvTYPE(ssv) != stype)
                stype = SvTYPE(ssv);
        }
        if (isGV_with_GP(ssv) && dtype <= SVt_PVLV) {
                    glob_assign_glob(dsv, ssv, dtype);
                    return;
        }
        if (stype == SVt_PVLV)
        {
            if (isREGEXP(ssv)) goto upgregexp;
            SvUPGRADE(dsv, SVt_PVNV);
        }
        else
            SvUPGRADE(dsv, (svtype)stype);
    }
 end_of_first_switch:

    /* dsv may have been upgraded.  */
    dtype = SvTYPE(dsv);
    sflags = SvFLAGS(ssv);

    if (UNLIKELY( dtype == SVt_PVCV )) {
        /* Assigning to a subroutine sets the prototype.  */
        if (SvOK(ssv)) {
            STRLEN len;
            const char *const ptr = SvPV_const(ssv, len);

            SvGROW(dsv, len + 1);
            Copy(ptr, SvPVX(dsv), len + 1, char);
            SvCUR_set(dsv, len);
            SvPOK_only(dsv);
            SvFLAGS(dsv) |= sflags & SVf_UTF8;
            CvAUTOLOAD_off(dsv);
        } else {
            SvOK_off(dsv);
        }
    }
    else if (UNLIKELY(dtype == SVt_PVAV || dtype == SVt_PVHV
             || dtype == SVt_PVFM))
    {
        const char * const type = sv_reftype(dsv,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(dsv)
            && SvTYPE(SvRV(ssv)) == SVt_PVGV && isGV_with_GP(SvRV(ssv))) {
            ssv = SvRV(ssv);
            if (ssv == dsv) {
                if (GvIMPORTED(dsv) != GVf_IMPORTED
                    && CopSTASH_ne(PL_curcop, GvSTASH(dsv)))
                {
                    GvIMPORTED_on(dsv);
                }
                GvMULTI_on(dsv);
                return;
            }
            glob_assign_glob(dsv, ssv, dtype);
            return;
        }

        if (dtype >= SVt_PV) {
            if (isGV_with_GP(dsv)) {
                gv_setref(dsv, ssv);
                return;
            }
            if (SvPVX_const(dsv)) {
                SvPV_free(dsv);
                SvLEN_set(dsv, 0);
                SvCUR_set(dsv, 0);
            }
        }
        (void)SvOK_off(dsv);
        SvRV_set(dsv, SvREFCNT_inc(SvRV(ssv)));
        SvFLAGS(dsv) |= sflags & SVf_ROK;
        assert(!(sflags & SVp_NOK));
        assert(!(sflags & SVp_IOK));
        assert(!(sflags & SVf_NOK));
        assert(!(sflags & SVf_IOK));
    }
    else if (isGV_with_GP(dsv)) {
        if (!(sflags & SVf_OK)) {
            Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
                           "Undefined value assigned to typeglob");
        }
        else {
            GV *gv = gv_fetchsv_nomg(ssv, GV_ADD, SVt_PVGV);
            if (dsv != (const SV *)gv) {
                const char * const name = GvNAME((const GV *)dsv);
                const STRLEN len = GvNAMELEN(dsv);
                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(dsv))) {
                        /* Make sure we do not lose it early. */
                        SvREFCNT_inc_simple_void_NN(
                         sv_2mortal((SV *)old_stash)
                        );
                    }
                    reset_isa = TRUE;
                }

                if (GvGP(dsv)) {
                    SvREFCNT_inc_simple_void_NN(sv_2mortal(dsv));
                    gp_free(MUTABLE_GV(dsv));
                }
                GvGP_set(dsv, gp_ref(GvGP(gv)));

                if (reset_isa) {
                    HV * const stash = GvHV(dsv);
                    if(
                        old_stash ? HvHasENAME(old_stash) : cBOOL(stash)
                    )
                        mro_package_moved(
                         stash, old_stash,
                         (GV *)dsv, 0
                        );
                }
            }
        }
    }
    else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
          && (stype == SVt_REGEXP || isREGEXP(ssv))) {
        reg_temp_copy((REGEXP*)dsv, (REGEXP*)ssv);
    }
    else if (sflags & SVp_POK) {
        const STRLEN cur = SvCUR(ssv);
        const STRLEN len = SvLEN(ssv);

        /*
         * 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(dsv) has to be allocated.  If not, it should not
         * slow things down, as SvPVX_const(ssv) 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(dsv) 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 buffer 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(dsv);

        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(ssv) == 1 &&   /* and no other references to it? */
                 len)             /* and really is a string */
        {       /* Passes the swipe test.  */
            if (SvPVX_const(dsv))       /* we know that dtype >= SVt_PV */
                SvPV_free(dsv);
            SvPV_set(dsv, SvPVX_mutable(ssv));
            SvLEN_set(dsv, SvLEN(ssv));
            SvCUR_set(dsv, SvCUR(ssv));

            SvTEMP_off(dsv);
            (void)SvOK_off(ssv);        /* NOTE: nukes most SvFLAGS on ssv */
            SvPV_set(ssv, NULL);
            SvLEN_set(ssv, 0);
            SvCUR_set(ssv, 0);
            SvTEMP_off(ssv);
        }
        /* We must check for SvIsCOW_static() even without
         * SV_COW_SHARED_HASH_KEYS being set or else we'll break SvIsBOOL()
         */
        else if (SvIsCOW_static(ssv)) {
            if (SvPVX_const(dsv)) {     /* we know that dtype >= SVt_PV */
                SvPV_free(dsv);
            }
            SvPV_set(dsv, SvPVX(ssv));
            SvLEN_set(dsv, 0);
            SvCUR_set(dsv, cur);
            SvFLAGS(dsv) |= (SVf_IsCOW|SVppv_STATIC);
        }
        else if (flags & SV_COW_SHARED_HASH_KEYS
              &&
#ifdef PERL_COPY_ON_WRITE
                 (sflags & SVf_IsCOW
                   ? (!len ||
                       (  (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dsv) < cur+1)
                          /* If this is a regular (non-hek) COW, only so
                             many COW "copies" are possible. */
                       && CowREFCNT(ssv) != SV_COW_REFCNT_MAX  ))
                   : (  (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
                     && !(SvFLAGS(dsv) & SVf_BREAK)
                     && CHECK_COW_THRESHOLD(cur,len) && cur+1 < len
                     && (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dsv) < cur+1)
                    ))
#else
                 sflags & SVf_IsCOW
              && !(SvFLAGS(dsv) & SVf_BREAK)
#endif
            ) {
            /* Either it's a shared hash key, or it's suitable for
               copy-on-write.  */
#ifdef DEBUGGING
            if (DEBUG_C_TEST) {
                PerlIO_printf(Perl_debug_log, "Copy on write: ssv --> dsv\n");
                sv_dump(ssv);
                sv_dump(dsv);
            }
#endif
#ifdef PERL_ANY_COW
            if (!(sflags & SVf_IsCOW)) {
                    SvIsCOW_on(ssv);
                    CowREFCNT(ssv) = 0;
            }
#endif
            if (SvPVX_const(dsv)) {     /* we know that dtype >= SVt_PV */
                SvPV_free(dsv);
            }

#ifdef PERL_ANY_COW
            if (len) {
                    if (sflags & SVf_IsCOW) {
                        sv_buf_to_rw(ssv);
                    }
                    CowREFCNT(ssv)++;
                    SvPV_set(dsv, SvPVX_mutable(ssv));
                    sv_buf_to_ro(ssv);
            } else
#endif
            {
                    /* SvIsCOW_shared_hash */
                    DEBUG_C(PerlIO_printf(Perl_debug_log,
                                          "Copy on write: Sharing hash\n"));

                    assert (SvTYPE(dsv) >= SVt_PV);
                    SvPV_set(dsv,
                             HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv)))));
            }
            SvLEN_set(dsv, len);
            SvCUR_set(dsv, cur);
            SvIsCOW_on(dsv);
        } else {
            /* Failed the swipe test, and we cannot do copy-on-write either.
               Have to copy the string.  */
            SvGROW(dsv, cur + 1);       /* inlined from sv_setpvn */
            Move(SvPVX_const(ssv),SvPVX(dsv),cur,char);
            SvCUR_set(dsv, cur);
            *SvEND(dsv) = '\0';
        }
        if (sflags & SVp_NOK) {
            SvNV_set(dsv, SvNVX(ssv));
            if ((sflags & SVf_NOK) && !(sflags & SVf_POK)) {
                /* Source was SVf_NOK|SVp_NOK|SVp_POK but not SVf_POK, meaning
                   a value set as floating point and later stringified, where
                  the value happens to be one of the few that we know aren't
                  affected by the numeric locale, hence we can cache the
                  stringification. Currently that's  +Inf, -Inf and NaN, but
                  conceivably we might extend this to -9 .. +9 (excluding -0).
                  So mark destination the same: */
                SvFLAGS(dsv) &= ~SVf_POK;
            }
        }
        if (sflags & SVp_IOK) {
            SvIV_set(dsv, SvIVX(ssv));
            if (sflags & SVf_IVisUV)
                SvIsUV_on(dsv);
            if ((sflags & SVf_IOK) && !(sflags & SVf_POK)) {
                /* Source was SVf_IOK|SVp_IOK|SVp_POK but not SVf_POK, meaning
                   a value set as an integer and later stringified. So mark
                   destination the same: */
                SvFLAGS(dsv) &= ~SVf_POK;
            }
        }
        SvFLAGS(dsv) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
        {
            const MAGIC * const smg = SvVSTRING_mg(ssv);
            if (smg) {
                sv_magic(dsv, NULL, PERL_MAGIC_vstring,
                         smg->mg_ptr, smg->mg_len);
                SvRMAGICAL_on(dsv);
            }
        }
    }
    else if (sflags & (SVp_IOK|SVp_NOK)) {
        (void)SvOK_off(dsv);
        SvFLAGS(dsv) |= 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(dsv, SvIVX(ssv));
        }
        if (sflags & SVp_NOK) {
            SvNV_set(dsv, SvNVX(ssv));
        }
    }
    else {
        if (isGV_with_GP(ssv)) {
            gv_efullname3(dsv, MUTABLE_GV(ssv), "*");
        }
        else
            (void)SvOK_off(dsv);
    }
    if (SvTAINTED(ssv))
        SvTAINT(dsv);
}


/*
=for apidoc sv_set_undef

Equivalent to C<sv_setsv(sv, &PL_sv_undef)>, but more efficient.
Doesn't handle set magic.

The perl equivalent is C<$sv = undef;>. Note that it doesn't free any string
buffer, unlike C<undef $sv>.

Introduced in perl 5.25.12.

=cut
*/

void
Perl_sv_set_undef(pTHX_ SV *sv)
{
    U32 type = SvTYPE(sv);

    PERL_ARGS_ASSERT_SV_SET_UNDEF;

    /* shortcut, NULL, IV, RV */

    if (type <= SVt_IV) {
        assert(!SvGMAGICAL(sv));
        if (SvREADONLY(sv)) {
            /* does undeffing PL_sv_undef count as modifying a read-only
             * variable? Some XS code does this */
            if (sv == &PL_sv_undef)
                return;
            Perl_croak_no_modify();
        }

        if (SvROK(sv)) {
            if (SvWEAKREF(sv))
                sv_unref_flags(sv, 0);
            else {
                SV *rv = SvRV(sv);
                SvFLAGS(sv) = type; /* quickly turn off all flags */
                SvREFCNT_dec_NN(rv);
                return;
            }
        }
        SvFLAGS(sv) = type; /* quickly turn off all flags */
        return;
    }

    if (SvIS_FREED(sv))
        Perl_croak(aTHX_ "panic: attempt to undefine a freed scalar %p",
            (void *)sv);

    SV_CHECK_THINKFIRST_COW_DROP(sv);

    if (isGV_with_GP(sv))
        Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
                       "Undefined value assigned to typeglob");
    else
        SvOK_off(sv);
}

/*
=for apidoc sv_set_true

Equivalent to C<sv_setsv(sv, &PL_sv_yes)>, but may be made more
efficient in the future. Doesn't handle set magic.

The perl equivalent is C<$sv = !0;>.

Introduced in perl 5.35.11.

=cut
*/

void
Perl_sv_set_true(pTHX_ SV *sv)
{
    PERL_ARGS_ASSERT_SV_SET_TRUE;
    sv_setsv(sv, &PL_sv_yes);
}

/*
=for apidoc sv_set_false

Equivalent to C<sv_setsv(sv, &PL_sv_no)>, but may be made more
efficient in the future. Doesn't handle set magic.

The perl equivalent is C<$sv = !1;>.

Introduced in perl 5.35.11.

=cut
*/

void
Perl_sv_set_false(pTHX_ SV *sv)
{
    PERL_ARGS_ASSERT_SV_SET_FALSE;
    sv_setsv(sv, &PL_sv_no);
}

/*
=for apidoc sv_set_bool

Equivalent to C<sv_setsv(sv, bool_val ? &Pl_sv_yes : &PL_sv_no)>, but
may be made more efficient in the future. Doesn't handle set magic.

The perl equivalent is C<$sv = !!$expr;>.

Introduced in perl 5.35.11.

=cut
*/

void
Perl_sv_set_bool(pTHX_ SV *sv, const bool bool_val)
{
    PERL_ARGS_ASSERT_SV_SET_BOOL;
    sv_setsv(sv, bool_val ? &PL_sv_yes : &PL_sv_no);
}


void
Perl_sv_setsv_mg(pTHX_ SV *const dsv, SV *const ssv)
{
    PERL_ARGS_ASSERT_SV_SETSV_MG;

    sv_setsv(dsv,ssv);
    SvSETMAGIC(dsv);
}

#ifdef PERL_ANY_COW
#  define SVt_COW SVt_PV
SV *
Perl_sv_setsv_cow(pTHX_ SV *dsv, SV *ssv)
{
    STRLEN cur = SvCUR(ssv);
    STRLEN len = SvLEN(ssv);
    char *new_pv;
    U32 new_flags = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW);
#if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_COPY_ON_WRITE)
    const bool already = cBOOL(SvIsCOW(ssv));
#endif

    PERL_ARGS_ASSERT_SV_SETSV_COW;
#ifdef DEBUGGING
    if (DEBUG_C_TEST) {
        PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
                      (void*)ssv, (void*)dsv);
        sv_dump(ssv);
        if (dsv)
                    sv_dump(dsv);
    }
#endif
    if (dsv) {
        if (SvTHINKFIRST(dsv))
            sv_force_normal_flags(dsv, SV_COW_DROP_PV);
        else if (SvPVX_const(dsv))
            Safefree(SvPVX_mutable(dsv));
        SvUPGRADE(dsv, SVt_COW);
    }
    else
        dsv = newSV_type(SVt_COW);

    assert (SvPOK(ssv));
    assert (SvPOKp(ssv));

    if (SvIsCOW(ssv)) {
        if (SvIsCOW_shared_hash(ssv)) {
            /* 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(ssv))));
            goto common_exit;
        }
        else if (SvIsCOW_static(ssv)) {
            /* source is static constant; preserve this */
            new_pv = SvPVX(ssv);
            new_flags |= SVppv_STATIC;
            goto common_exit;
        }
        assert(SvCUR(ssv)+1 < SvLEN(ssv));
        assert(CowREFCNT(ssv) < SV_COW_REFCNT_MAX);
    } else {
        assert ((SvFLAGS(ssv) & CAN_COW_MASK) == CAN_COW_FLAGS);
        SvUPGRADE(ssv, SVt_COW);
        SvIsCOW_on(ssv);
        DEBUG_C(PerlIO_printf(Perl_debug_log,
                              "Fast copy on write: Converting ssv to COW\n"));
        CowREFCNT(ssv) = 0;
    }
#  ifdef PERL_DEBUG_READONLY_COW
    if (already) sv_buf_to_rw(ssv);
#  endif
    CowREFCNT(ssv)++;
    new_pv = SvPVX_mutable(ssv);
    sv_buf_to_ro(ssv);

  common_exit:
    SvPV_set(dsv, new_pv);
    SvFLAGS(dsv) = new_flags;
    if (SvUTF8(ssv))
        SvUTF8_on(dsv);
    SvLEN_set(dsv, len);
    SvCUR_set(dsv, cur);
#ifdef DEBUGGING
    if (DEBUG_C_TEST)
                sv_dump(dsv);
#endif
    return dsv;
}
#endif

/*
=for apidoc sv_setpv_bufsize

Sets the SV to be a string of cur bytes length, with at least
len bytes available. Ensures that there is a null byte at SvEND.
Returns a char * pointer to the SvPV buffer.

=cut
*/

char *
Perl_sv_setpv_bufsize(pTHX_ SV *const sv, const STRLEN cur, const STRLEN len)
{
    char *pv;

    PERL_ARGS_ASSERT_SV_SETPV_BUFSIZE;

    SV_CHECK_THINKFIRST_COW_DROP(sv);
    SvUPGRADE(sv, SVt_PV);
    pv = SvGROW(sv, len + 1);
    SvCUR_set(sv, cur);
    *(SvEND(sv))= '\0';
    (void)SvPOK_only_UTF8(sv);                /* validate pointer */

    SvTAINT(sv);
    if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
    return pv;
}

/*
=for apidoc            sv_setpv
=for apidoc_item       sv_setpv_mg
=for apidoc_item       sv_setpvn
=for apidoc_item       sv_setpvn_fresh
=for apidoc_item       sv_setpvn_mg
=for apidoc_item |void|sv_setpvs|SV* sv|"literal string"
=for apidoc_item |void|sv_setpvs_mg|SV* sv|"literal string"

These copy a string into the SV C<sv>, making sure it is C<L</SvPOK_only>>.

In the C<pvs> forms, the string must be a C literal string, enclosed in double
quotes.

In the C<pvn> forms, the first byte of the string is pointed to by C<ptr>, and
C<len> indicates the number of bytes to be copied, potentially including
embedded C<NUL> characters.

In the plain C<pv> forms, C<ptr> points to a NUL-terminated C string.  That is,
it points to the first byte of the string, and the copy proceeds up through the
first encountered C<NUL> byte.

In the forms that take a C<ptr> argument, if it is NULL, the SV will become
undefined.

The UTF-8 flag is not changed by these functions.  A terminating NUL byte is
guaranteed in the result.

The C<_mg> forms handle 'set' magic; the other forms skip all magic.

C<sv_setpvn_fresh> is a cut-down alternative to C<sv_setpvn>, intended ONLY
to be used with a fresh sv that has been upgraded to a SVt_PV, SVt_PVIV,
SVt_PVNV, or SVt_PVMG.

=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 (isGV_with_GP(sv))
        Perl_croak_no_modify();
    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);
}

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);
}

void
Perl_sv_setpvn_fresh(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
{
    char *dptr;

    PERL_ARGS_ASSERT_SV_SETPVN_FRESH;
    assert(SvTYPE(sv) >= SVt_PV && SvTYPE(sv) <= SVt_PVMG);
    assert(!SvTHINKFIRST(sv));
    assert(!isGV_with_GP(sv));

    if (ptr) {
        const IV iv = len;
        /* len is STRLEN which is unsigned, need to copy to signed */
        if (iv < 0)
            Perl_croak(aTHX_ "panic: sv_setpvn_fresh called with negative strlen %"
                       IVdf, iv);

        dptr = sv_grow_fresh(sv, len + 1);
        Move(ptr,dptr,len,char);
        dptr[len] = '\0';
        SvCUR_set(sv, len);
        SvPOK_on(sv);
        SvTAINT(sv);
    }
}

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);
}

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_NOTSHARED) {
            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
=for apidoc_item sv_usepvn_flags
=for apidoc_item sv_usepvn_mg

These tell an SV to use C<ptr> for its string value.  Normally SVs have
their string stored inside the SV, but these tell the SV to use an
external string instead.

C<ptr> should point to memory that was allocated
by L</C<Newx>>.  It must be
the start of a C<Newx>-ed block of memory, and not a pointer to the
middle of it (beware of L<C<OOK>|perlguts/Offsets> and copy-on-write),
and not be from a non-C<Newx> memory allocator like C<malloc>.  The
string length, C<len>, must be supplied.  By default this function
will L</C<Renew>> (i.e. realloc, move) the memory pointed to by C<ptr>,
so that the pointer should not be freed or used by the programmer after giving
it to C<sv_usepvn>, and neither should any pointers from "behind" that pointer
(I<e.g.>, S<C<ptr> + 1>) be used.

In the C<sv_usepvn_flags> form, if S<C<flags & SV_SMAGIC>> is true,
C<SvSETMAGIC> is called before returning.
And if S<C<flags & SV_HAS_TRAILING_NUL>> is true, then C<ptr[len]> must be
C<NUL>, and the realloc will be skipped (I<i.e.>, the buffer is actually at
least 1 byte longer than C<len>, and already meets the requirements for storing
in C<SvPVX>).

C<sv_usepvn> is merely C<sv_usepvn_flags> with C<flags> set to 0, so 'set'
magic is skipped.

C<sv_usepvn_mg> is merely C<sv_usepvn_flags> with C<flags> set to C<SV_SMAGIC>,
so 'set' magic is performed.

=for apidoc Amnh||SV_SMAGIC
=for apidoc Amnh||SV_HAS_TRAILING_NUL

=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);
}


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);
        const bool was_shared_hek = SvIsCOW_shared_hash(sv);

#ifdef DEBUGGING
        if (DEBUG_C_TEST) {
                PerlIO_printf(Perl_debug_log,
                              "Copy on write: Force normal %ld\n",
                              (long) flags);
                sv_dump(sv);
        }
#endif
        SvIsCOW_off(sv);
# ifdef PERL_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 (was_shared_hek) {
                        unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
            }
#ifdef DEBUGGING
            if (DEBUG_C_TEST)
                sv_dump(sv);
#endif
        }
#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
    }
}


/*
=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 C<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
C<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.

=for apidoc Amnh||SV_COW_DROP_PV

=cut
*/

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 *old_rx_body;

        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. */
        assert(ReANY((REGEXP *)sv)->mother_re);

        if (islv) {
            /* LV-as-regex has sv->sv_any pointing to an XPVLV body,
             * whose xpvlenu_rx field points to the regex body */
            XPV *xpv = (XPV*)(SvANY(sv));
            old_rx_body = xpv->xpv_len_u.xpvlenu_rx;
            xpv->xpv_len_u.xpvlenu_rx = NULL;
        }
        else
            old_rx_body = ReANY((REGEXP *)sv);

        /* 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, we zeroed it above (len field
               a union with xpvlenu_rx) */
            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) = old_rx_body;

        /* temp is now rebuilt as a correctly structured SVt_REGEXP, so this
         * will trigger a call to sv_clear() which will correctly free the
         * body. */
        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.
C<SvPOK(sv)>, or at least C<SvPOKp(sv)>, must be true and C<ptr> must be a
pointer to somewhere inside the string buffer.  C<ptr> becomes the first
character of the adjusted string.  Uses the C<OOK> hack.  On return, only
C<SvPOK(sv)> and C<SvPOKp(sv)> among the C<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
=for apidoc_item sv_catpvn_flags
=for apidoc_item sv_catpvn_mg
=for apidoc_item sv_catpvn_nomg

These concatenate the C<len> bytes of the string beginning at C<ptr> onto the
end of the string which is in C<dsv>.  The caller must make sure C<ptr>
contains at least C<len> bytes.

For all but C<sv_catpvn_flags>, 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.

They differ in that:

C<sv_catpvn_mg> performs both 'get' and 'set' magic on C<dsv>.

C<sv_catpvn> performs only 'get' magic.

C<sv_catpvn_nomg> skips all magic.

C<sv_catpvn_flags> has an extra C<flags> parameter which allows you to specify
any combination of magic handling (using C<SV_GMAGIC> and/or C<SV_SMAGIC>) and
to also override the UTF-8 handling.  By supplying the C<SV_CATBYTES> flag, the
appended string is interpreted as plain bytes; by supplying instead the
C<SV_CATUTF8> flag, it will be interpreted as UTF-8, and the C<dsv> will be
upgraded to UTF-8 if necessary.

C<sv_catpvn>, C<sv_catpvn_mg>, and C<sv_catpvn_nomg> are implemented
in terms of C<sv_catpvn_flags>.

=for apidoc Amnh||SV_CATUTF8
=for apidoc Amnh||SV_CATBYTES

=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 + 3);
      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 + 3);
        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
=for apidoc_item sv_catsv_flags
=for apidoc_item sv_catsv_mg
=for apidoc_item sv_catsv_nomg

These concatenate the string from SV C<sstr> onto the end of the string in SV
C<dsv>.  If C<sstr> is null, these are no-ops; otherwise only C<dsv> is
modified.

They differ only in what magic they perform:

C<sv_catsv_mg> performs 'get' magic on both SVs before the copy, and 'set' magic
on C<dsv> afterwards.

C<sv_catsv> performs just 'get' magic, on both SVs.

C<sv_catsv_nomg> skips all magic.

C<sv_catsv_flags> has an extra C<flags> parameter which allows you to use
C<SV_GMAGIC> and/or C<SV_SMAGIC> to specify any combination of magic handling
(although either both or neither SV will have 'get' magic applied to it.)

C<sv_catsv>, C<sv_catsv_mg>, and C<sv_catsv_nomg> are implemented
in terms of C<sv_catsv_flags>.

=cut */

void
Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const sstr, const I32 flags)
{
    PERL_ARGS_ASSERT_SV_CATSV_FLAGS;

    if (sstr) {
        STRLEN slen;
        const char *spv = SvPV_flags_const(sstr, slen, flags);
        if (flags & SV_GMAGIC)
                SvGETMAGIC(dsv);
        sv_catpvn_flags(dsv, spv, slen,
                            DO_UTF8(sstr) ? SV_CATUTF8 : SV_CATBYTES);