Clone.xs

#include <assert.h>

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "ppport.h"

#define CLONE_KEY(x) ((char *) &x)

/* Maximum safe recursion depth before switching to iterative mode.
 * Each nesting level of [[[...]]] consumes ~3 C stack frames in the
 * recursive clone path (sv_clone for RV + sv_clone for AV + av_clone).
 * The rdepth counter increments once per sv_clone() call, so the
 * nesting level is roughly rdepth/2, using ~450 bytes of stack each.
 *
 * Windows has a 1 MB default thread stack; Cygwin typically 2 MB.
 * Linux/macOS default to 8 MB but some CPAN smokers and containers
 * may have 4 MB or less available after Perl/harness overhead.
 *
 * MAX_DEPTH=2000 on Windows/Cygwin -> ~1000 nesting levels -> ~450 KB.
 * MAX_DEPTH=4000 elsewhere        -> ~2000 nesting levels -> ~900 KB.
 * (GH #77: 32000 was too aggressive — caused SEGV on CPAN smokers.) */
#if defined(_WIN32) || defined(__CYGWIN__)
#define MAX_DEPTH 2000
#else
#define MAX_DEPTH 4000
#endif

#define CLONE_STORE(x,y)						\
do {									\
    if (!hv_store(hseen, CLONE_KEY(x), PTRSIZE, SvREFCNT_inc(y), 0)) {	\
	SvREFCNT_dec(y); /* Restore the refcount */			\
	croak("Can't store clone in seen hash (hseen)");		\
    }									\
    else {	\
  TRACEME(("storing ref = 0x%x clone = 0x%x\n", ref, clone));	\
  TRACEME(("clone = 0x%x(%d)\n", clone, SvREFCNT(clone)));	\
  TRACEME(("ref = 0x%x(%d)\n", ref, SvREFCNT(ref)));	\
    }									\
} while (0)

#define CLONE_FETCH(x) (hv_fetch(hseen, CLONE_KEY(x), PTRSIZE, 0))

static SV *hv_clone (SV *, SV *, HV *, int, int, AV *);
static SV *av_clone (SV *, SV *, HV *, int, int, AV *);
static SV *sv_clone (SV *, HV *, int, int, AV *);
static SV *av_clone_iterative(SV *, HV *, int, AV *);
static SV *hv_clone_iterative(SV *, HV *, int, AV *);
static SV *rv_clone_iterative(SV *, HV *, int, AV *);

#ifdef DEBUG_CLONE
#define TRACEME(a) printf("%s:%d: ",__FUNCTION__, __LINE__) && printf a;
#else
#define TRACEME(a)
#endif

/* Check whether an mg_obj is a threads::shared::tie instance.
 * The mg_obj is an RV pointing to a blessed PVMG. (GH #18) */
static int
is_threads_shared_tie(SV *obj)
{
  HV *stash;
  if (!obj || !SvROK(obj) || !SvOBJECT(SvRV(obj)))
    return 0;
  stash = SvSTASH(SvRV(obj));
  return stash && HvNAME(stash)
      && strEQ(HvNAME(stash), "threads::shared::tie");
}

static SV *
hv_clone (SV * ref, SV * target, HV* hseen, int depth, int rdepth, AV * weakrefs)
{
  HV *clone = (HV *) target;
  HV *self = (HV *) ref;
  HE *next = NULL;
  int recur = depth ? depth - 1 : 0;

  assert(SvTYPE(ref) == SVt_PVHV);

  TRACEME(("ref = 0x%x(%d)\n", ref, SvREFCNT(ref)));

  /* Pre-size the target hash to avoid incremental resizing */
  if (HvKEYS(self) > 0)
    hv_ksplit(clone, HvKEYS(self));

  hv_iterinit (self);
  while ((next = hv_iternext (self)))
    {
      I32 klen;
      char *kpv = hv_iterkey(next, &klen);
      SV *val = sv_clone(hv_iterval(self, next), hseen, recur, rdepth, weakrefs);
      /* Use hv_iterkey + HeHASH to avoid allocating a mortal SV per key.
       * Negate klen for UTF-8 keys per Perl API convention. */
      if (HeKUTF8(next))
        klen = -klen;
      TRACEME(("clone item %.*s\n", (int)(klen > 0 ? klen : -klen), kpv));
      hv_store(clone, kpv, klen, val, HeHASH(next));
    }

  TRACEME(("clone = 0x%x(%d)\n", clone, SvREFCNT(clone)));
  return (SV *) clone;
}

static SV *
av_clone_iterative(SV * ref, HV* hseen, int rdepth, AV * weakrefs)
{
    AV *self;
    AV *root_clone;
    AV *tail;
    SV *current_ref;
    SV **seen = NULL;
    SV **svp;
    I32 arrlen;
    I32 i;

    if (!ref) return NULL;

    self = (AV *)ref;

    /* Check if we've already cloned this array */
    if ((seen = CLONE_FETCH(ref))) {
        return SvREFCNT_inc(*seen);
    }

    /* Create new array and store it in seen hash immediately */
    root_clone = newAV();
    CLONE_STORE(ref, (SV *)root_clone);

    /* Optimized path for deeply nested single-element arrays:
     * [[[...]]] chains are unrolled iteratively to avoid stack overflow.
     * Each nesting level is an AV with one element (an RV to the next AV). */
    if (av_len(self) == 0) {
        svp = av_fetch(self, 0, 0);
        if (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV) {
            tail = root_clone;
            current_ref = *svp;

            /* Walk the chain: each step creates one AV and one RV link */
            while (current_ref && SvROK(current_ref) &&
                   SvTYPE(SvRV(current_ref)) == SVt_PVAV &&
                   av_len((AV*)SvRV(current_ref)) == 0) {
                SV *inner_sv = SvRV(current_ref);
                SV **already;
                AV *new_av;

                /* Guard against circular refs: if this AV was already cloned,
                 * link to the existing clone and stop walking. */
                already = CLONE_FETCH(inner_sv);
                if (already) {
                    av_store(tail, 0, newRV_inc(*already));
                    break;
                }

                new_av = newAV();

                /* Preserve blessing if the original AV is an object.
                 * Without this, blessed arrayrefs in the chain lose
                 * their class when cloned via the iterative path. */
                if (SvOBJECT(inner_sv)) {
                    SV *tmp_rv = newRV((SV *)new_av);
                    sv_bless(tmp_rv, SvSTASH(inner_sv));
                    SvREFCNT_dec(tmp_rv);
                }

                av_store(tail, 0, newRV_noinc((SV*)new_av));
                CLONE_STORE(inner_sv, (SV*)new_av);

                /* Advance to the next element in the chain */
                svp = av_fetch((AV*)inner_sv, 0, 0);
                if (!svp) break;
                current_ref = *svp;
                tail = new_av;
            }

            /* Handle the final element (leaf or non-matching structure) */
            if (current_ref) {
                if (SvROK(current_ref) &&
                    SvTYPE(SvRV(current_ref)) == SVt_PVAV) {
                    /* Final AV — clone it iteratively too */
                    SV *leaf = av_clone_iterative(SvRV(current_ref),
                                                  hseen, rdepth, weakrefs);
                    av_store(tail, 0, newRV_noinc(leaf));
                } else if (SvROK(current_ref)) {
                    av_store(tail, 0,
                             sv_clone(current_ref, hseen, 1, rdepth, weakrefs));
                } else {
                    av_store(tail, 0, newSVsv(current_ref));
                }
            }

            return (SV*)root_clone;
        }

        /* Single non-array element */
        if (svp) {
            av_store(root_clone, 0,
                     sv_clone(*svp, hseen, 1, rdepth, weakrefs));
        }
        return (SV*)root_clone;
    }

    /* General case: array with multiple elements */
    arrlen = av_len(self);
    av_extend(root_clone, arrlen);

    {
        SV **dst = AvARRAY(root_clone);
        for (i = 0; i <= arrlen; i++) {
            svp = av_fetch(self, i, 0);
            if (svp) {
                dst[i] = sv_clone(*svp, hseen, 1, rdepth, weakrefs);
            }
        }
        AvFILLp(root_clone) = arrlen;
    }

    return (SV*)root_clone;
}

/* Iterative hash clone for use when rdepth exceeds MAX_DEPTH.
 * Mirrors av_clone_iterative: creates a new HV, registers it in hseen for
 * circular-ref safety, then clones each value via sv_clone (which will
 * re-enter this function for any nested HVs still above MAX_DEPTH). */
static SV *
hv_clone_iterative(SV * ref, HV* hseen, int rdepth, AV * weakrefs)
{
    HV *self;
    HV *root_clone;
    SV **seen = NULL;
    HE *next = NULL;

    if (!ref) return NULL;

    self = (HV *)ref;

    /* Return cached clone if we have already visited this HV (circular refs) */
    if ((seen = CLONE_FETCH(ref))) {
        return SvREFCNT_inc(*seen);
    }

    root_clone = newHV();
    CLONE_STORE(ref, (SV *)root_clone);

    /* Pre-size to avoid incremental resizing */
    if (HvKEYS(self) > 0)
        hv_ksplit(root_clone, HvKEYS(self));

    /* Clone each value; sv_clone will use the iterative path again for any
     * nested structures that are still above MAX_DEPTH. */
    hv_iterinit(self);
    while ((next = hv_iternext(self))) {
        I32 klen;
        char *kpv = hv_iterkey(next, &klen);
        SV *val = sv_clone(hv_iterval(self, next), hseen, 1, rdepth, weakrefs);
        if (HeKUTF8(next))
            klen = -klen;
        hv_store(root_clone, kpv, klen, val, HeHASH(next));
    }

    return (SV *)root_clone;
}

/* Iterative clone for deeply nested scalar-ref chains past MAX_DEPTH.
 * Avoids stack overflow by unrolling the RV->RV->...->leaf chain without
 * recursion, then rebuilding from the bottom up.
 *
 * This mirrors av_clone_iterative/hv_clone_iterative: instead of returning
 * SvREFCNT_inc(ref) (a shared alias), it produces a true deep copy of the
 * entire scalar-ref chain, preserving isolation. (GH #107) */
static SV *
rv_clone_iterative(SV * ref, HV* hseen, int rdepth, AV * weakrefs)
{
    SV **chain;
    I32 chain_len;
    I32 chain_max;
    SV *current;
    SV *leaf_clone;
    SV *result;
    SV **seen;
    I32 i;

    if (!ref || !SvROK(ref)) return NULL;

    chain_max = 64;
    chain_len = 0;
    Newx(chain, chain_max, SV *);

    /* Walk the RV chain, collecting each node until we reach a non-RV leaf */
    current = ref;
    while (current && SvROK(current)) {
        if (chain_len >= chain_max) {
            chain_max *= 2;
            Renew(chain, chain_max, SV *);
        }
        chain[chain_len++] = current;
        current = SvRV(current);
    }

    /* current is now the non-RV leaf; clone it based on its type */
    leaf_clone = NULL;
    if (current) {
        if (SvTYPE(current) == SVt_PVAV) {
            leaf_clone = av_clone_iterative(current, hseen, rdepth, weakrefs);
        } else if (SvTYPE(current) == SVt_PVHV) {
            leaf_clone = hv_clone_iterative(current, hseen, rdepth, weakrefs);
        } else {
            seen = CLONE_FETCH(current);
            if (seen) {
                leaf_clone = SvREFCNT_inc(*seen);
            } else {
                leaf_clone = newSVsv(current);
                if ((SvREFCNT(current) > 1) || SvMAGICAL(current))
                    CLONE_STORE(current, leaf_clone);
            }
        }
    }

    if (!leaf_clone) {
        Safefree(chain);
        return SvREFCNT_inc(ref);
    }

    /* Rebuild the RV chain from the bottom up */
    result = leaf_clone;
    for (i = chain_len - 1; i >= 0; i--) {
        SV *rv = chain[i];
        SV *new_rv = newRV_noinc(result);
        if (SvOBJECT(SvRV(rv)))
            sv_bless(new_rv, SvSTASH(SvRV(rv)));
        if (SvWEAKREF(rv))
            av_push(weakrefs, SvREFCNT_inc_simple_NN(new_rv));
        result = new_rv;
    }

    Safefree(chain);
    return result;
}

static SV *
av_clone (SV * ref, SV * target, HV* hseen, int depth, int rdepth, AV * weakrefs)
{
    AV *clone;
    AV *self;
    SV **svp;
    SV **dst;
    I32 arrlen = 0;
    I32 i;
    int recur;

    /* For very deep structures, use the iterative approach */
    if (depth == 0) {
        return av_clone_iterative(ref, hseen, rdepth, weakrefs);
    }

    clone = (AV *) target;
    self = (AV *) ref;
    recur = depth > 0 ? depth - 1 : -1;

    assert(SvTYPE(ref) == SVt_PVAV);

    TRACEME(("ref = 0x%x(%d)\n", ref, SvREFCNT(ref)));

    arrlen = av_len(self);
    av_extend(clone, arrlen);

    /* Use av_fetch on the source (may be magical/tied) but write
     * directly to the target's AvARRAY (we just created it, no magic). */
    dst = AvARRAY(clone);
    for (i = 0; i <= arrlen; i++) {
        svp = av_fetch(self, i, 0);
        if (svp) {
            dst[i] = sv_clone(*svp, hseen, recur, rdepth, weakrefs);
        }
    }
    AvFILLp(clone) = arrlen;

    TRACEME(("clone = 0x%x(%d)\n", clone, SvREFCNT(clone)));
    return (SV *) clone;
}

static SV *
sv_clone (SV * ref, HV* hseen, int depth, int rdepth, AV * weakrefs)
{
    SV *clone;
    SV **seen = NULL;
    UV visible;
    int magic_ref = 0;

    if (!ref)
        return NULL;

    rdepth++;

    /* Check for deep recursion and switch to iterative mode.
     * A deeply nested arrayref like [[[...]]] alternates between RV and AV
     * at each level, consuming ~3 C stack frames per nesting level.
     * On Windows (1MB default stack), this overflows around depth 2000.
     * When we exceed MAX_DEPTH, handle both AV and RV-to-AV cases. */
    if (rdepth > MAX_DEPTH) {
        if (SvTYPE(ref) == SVt_PVAV) {
            return av_clone_iterative(ref, hseen, rdepth, weakrefs);
        }
        if (SvTYPE(ref) == SVt_PVHV) {
            return hv_clone_iterative(ref, hseen, rdepth, weakrefs);
        }
        /* For RVs pointing to AVs, follow the reference and use the
         * iterative path -- this is the common case for [[[...]]] */
        if (SvROK(ref) && SvTYPE(SvRV(ref)) == SVt_PVAV) {
            SV *clone_av = av_clone_iterative(SvRV(ref), hseen, rdepth, weakrefs);
            SV *clone_rv = newRV_noinc(clone_av);
            if (SvOBJECT(SvRV(ref)))
                sv_bless(clone_rv, SvSTASH(SvRV(ref)));
            return clone_rv;
        }
        /* For RVs pointing to HVs, use the iterative hash path */
        if (SvROK(ref) && SvTYPE(SvRV(ref)) == SVt_PVHV) {
            SV *clone_hv = hv_clone_iterative(SvRV(ref), hseen, rdepth, weakrefs);
            SV *clone_rv = newRV_noinc(clone_hv);
            if (SvOBJECT(SvRV(ref)))
                sv_bless(clone_rv, SvSTASH(SvRV(ref)));
            return clone_rv;
        }
        /* For other RV types (e.g. deeply nested scalar refs), unroll the
         * chain iteratively to produce a true deep copy.  This prevents the
         * "shared alias" vulnerability described in GH #107. */
        if (SvROK(ref))
            return rv_clone_iterative(ref, hseen, rdepth, weakrefs);
        /* Simple scalars (non-reference, non-container) can always be
         * safely copied without recursion.  newSVsv creates an independent
         * copy, preventing aliasing of leaf values inside iteratively-cloned
         * containers.  Without this, hv_clone_iterative / av_clone_iterative
         * would share leaf SVs between original and clone — mutations
         * through a reference to the clone's value would corrupt the
         * original.  (GH #113) */
        switch (SvTYPE(ref)) {
            case SVt_NULL:
            case SVt_IV:
            case SVt_NV:
#if PERL_VERSION <= 10
            case SVt_RV:
#endif
            case SVt_PV:
            case SVt_PVIV:
            case SVt_PVNV:
            case SVt_PVMG:
                return newSVsv(ref);
            default:
                break;
        }
        /* Non-clonable types past MAX_DEPTH (e.g. PVGV, PVCV, PVFM, PVIO):
         * these cannot be deep-copied regardless of depth; share with a
         * warning. */
        {
            SV *warn_sv = get_sv("Clone::WARN", 0);
            if (!warn_sv || SvTRUE(warn_sv))
                Perl_warn(aTHX_ "Clone: depth limit (%d) exceeded; "
                          "reference will be shared, not deep-copied", MAX_DEPTH);
        }
        return SvREFCNT_inc(ref);
    }

    clone = ref;

  /* Track this SV in hseen only if it could be reached from multiple
   * paths in the data structure.  Single-refcount, non-magical SVs
   * are unique leaves — skipping the hash lookup/store for them is a
   * significant win on structures with many distinct scalar values.
   *
   * Cases that require tracking:
   *  - SvREFCNT > 1 : SV is shared (appears in multiple slots)
   *  - SvMAGICAL     : may be a weakref target (backref '<' magic
   *                    for non-HV types), tied, or carry other magic
   *  - HV with SvOOK : since Perl 5.10, weakref back-references for
   *                    HVs are stored in the HV's AUX struct (via
   *                    SvOOK) rather than as PERL_MAGIC_backref.  An
   *                    HV that is the target of a weakened reference
   *                    has SvOOK set but is NOT SvMAGICAL, so we must
   *                    check SvOOK explicitly for HVs.
   *
   * Historical note: Perl 5.9.x moved HV backrefs from magic to
   * HvAUX; a blanket "visible = 1" was used as a workaround.  The
   * check below replaces that with a targeted condition. */
  visible = (SvREFCNT(ref) > 1) || SvMAGICAL(ref)
          || (SvTYPE(ref) == SVt_PVHV && SvOOK(ref));

  TRACEME(("ref = 0x%x(%d)\n", ref, SvREFCNT(ref)));

  if (depth == 0)
    return SvREFCNT_inc(ref);

  if (visible && (seen = CLONE_FETCH(ref)))
    {
      TRACEME(("fetch ref (0x%x)\n", ref));
      return SvREFCNT_inc(*seen);
    }

  /* threads::shared tiedelem PVLVs are proxies to shared data.
   * They would normally be returned by SvREFCNT_inc (like other PVLVs),
   * but that shares the proxy — mutations go back to the shared var.
   * Copy through magic to get a plain unshared value. (GH #18) */
  if (SvTYPE(ref) == SVt_PVLV && SvMAGICAL(ref))
  {
    MAGIC *mg;
    for (mg = SvMAGIC(ref); mg; mg = mg->mg_moremagic)
    {
      if ((mg->mg_type == PERL_MAGIC_tiedelem
           || mg->mg_type == PERL_MAGIC_tiedscalar)
          && is_threads_shared_tie(mg->mg_obj))
      {
        TRACEME(("threads::shared tiedelem PVLV — copy value\n"));
        clone = newSVsv(ref);
        if (visible && ref != clone)
          CLONE_STORE(ref, clone);
        return clone;
      }
    }
  }

  TRACEME(("switch: (0x%x)\n", ref));
  switch (SvTYPE (ref))
    {
      case SVt_NULL:	/* 0 */
        TRACEME(("sv_null\n"));
        clone = newSVsv (ref);
        break;
      case SVt_IV:		/* 1 */
        TRACEME(("int scalar\n"));
      case SVt_NV:		/* 2 */
        TRACEME(("double scalar\n"));
        clone = newSVsv (ref);
        break;
#if PERL_VERSION <= 10
      case SVt_RV:		/* 3 */
        TRACEME(("ref scalar\n"));
        clone = newSVsv (ref);
        break;
#endif
      case SVt_PV:		/* 4 */
        TRACEME(("string scalar\n"));
/*
* Note: when using a Debug Perl with READONLY_COW
* we cannot do 'sv_buf_to_rw + sv_buf_to_ro' as these APIs calls are not exported
*/
#if defined(SV_COW_REFCNT_MAX) && !defined(PERL_DEBUG_READONLY_COW)
        /* only for simple PVs unblessed */
        if ( SvIsCOW(ref) && !SvOOK(ref) && SvLEN(ref) > 0 ) {

          if ( CowREFCNT(ref) < (SV_COW_REFCNT_MAX - 1) ) {
            /* cannot use newSVpv_share as this going to use a new PV we do not want to clone it */
            /* create a fresh new PV */
            clone = newSV(0);
            sv_upgrade(clone, SVt_PV);
            SvPOK_on(clone);
            SvIsCOW_on(clone);

            /* points the str slot to the COWed one */
            SvPV_set(clone, SvPVX(ref) );
            CowREFCNT(ref)++;

            /* preserve cur, len, and value-relevant flags */
            SvCUR_set(clone, SvCUR(ref));
            SvLEN_set(clone, SvLEN(ref));
            if (SvUTF8(ref))
              SvUTF8_on(clone);
          } else {
            /* we are above SV_COW_REFCNT_MAX, create a new SvPV but preserve the COW */
            clone = newSVsv (ref);
            SvIsCOW_on(clone);
            CowREFCNT(clone) = 0; /* set the CowREFCNT to 0 */
          }

        } else {
          clone = newSVsv (ref);
        }
#else
        clone = newSVsv (ref);
#endif
        break;
      case SVt_PVIV:		/* 5 */
        TRACEME (("PVIV double-type\n"));
      case SVt_PVNV:		/* 6 */
        TRACEME (("PVNV double-type\n"));
        clone = newSVsv (ref);
        break;
      case SVt_PVMG:	/* 7 */
        TRACEME(("magic scalar\n"));
        clone = newSVsv (ref);
        break;
      case SVt_PVAV:	/* 10 */
        clone = (SV *) newAV();
        break;
      case SVt_PVHV:	/* 11 */
        clone = (SV *) newHV();
        break;
      #if PERL_VERSION <= 8
      case SVt_PVBM:	/* 8 */
      #elif PERL_VERSION >= 11
      case SVt_REGEXP:	/* 8 */
      #endif
      case SVt_PVLV:	/* 9 */
      case SVt_PVCV:	/* 12 */
      case SVt_PVGV:	/* 13 */
      case SVt_PVFM:	/* 14 */
      case SVt_PVIO:	/* 15 */
        TRACEME(("default: type = 0x%x\n", SvTYPE (ref)));
        clone = SvREFCNT_inc(ref);  /* just return the ref */
        break;
      default:
        croak("unknown type: 0x%x", SvTYPE(ref));
    }

  /**
    * It is *vital* that this is performed *before* recursion,
    * to properly handle circular references. cb 2001-02-06
    */

  if ( visible && ref != clone )
      CLONE_STORE(ref,clone);

    /* If clone == ref (e.g. for PVLV, PVGV, PVCV types), we just
     * incremented the refcount — skip all internal cloning to avoid
     * adding duplicate magic entries or corrupting the original SV.
     * (fixes GH #42: memory leak when cloning non-existent hash values) */
  if (ref == clone)
      return clone;

    /*
     * We'll assume (in the absence of evidence to the contrary) that A) a
     * tied hash/array doesn't store its elements in the usual way (i.e.
     * the mg->mg_object(s) take full responsibility for them) and B) that
     * references aren't tied.
     *
     * If theses assumptions hold, the three options below are mutually
     * exclusive.
     *
     * More precisely: 1 & 2 are probably mutually exclusive; 2 & 3 are
     * definitely mutually exclusive; we have to test 1 before giving 2
     * a chance; and we'll assume that 1 & 3 are mutually exclusive unless
     * and until we can be test-cased out of our delusion.
     *
     * chocolateboy: 2001-05-29
     */

    /* 1: TIED */
  if (SvMAGICAL(ref) )
    {
      MAGIC* mg;
      int has_qr = 0;

      for (mg = SvMAGIC(ref); mg; mg = mg->mg_moremagic)
      {
        SV *obj = (SV *) NULL;
        TRACEME(("magic type: %c\n", mg->mg_type));

        /* PERL_MAGIC_ext: opaque XS data, handle before the mg_obj check
         * since ext magic often has mg_obj == NULL (GH #27, GH #16) */
        if (mg->mg_type == '~')
        {
#if defined(MGf_DUP) && defined(sv_magicext)
          /* If the ext magic has a dup callback (e.g. Math::BigInt::GMP),
           * clone it properly via sv_magicext + svt_dup.
           * Otherwise skip it (e.g. DBI handles have no dup).
           * Note: we check only for svt_dup presence, not MGf_DUP flag,
           * because some older XS modules (e.g. Math::BigInt::GMP on
           * Perl 5.22) provide svt_dup without setting MGf_DUP. (GH #76) */
          if (mg->mg_virtual && mg->mg_virtual->svt_dup)
          {
            MAGIC *new_mg;
            new_mg = sv_magicext(clone, mg->mg_obj,
                                 mg->mg_type, mg->mg_virtual,
                                 mg->mg_ptr, mg->mg_len);
            new_mg->mg_flags |= MGf_DUP;
            /* CLONE_PARAMS is NULL since we are not in a thread clone.
             * Known callers (e.g. Math::BigInt::GMP) ignore it. */
            mg->mg_virtual->svt_dup(aTHX_ new_mg, NULL);
          }
#endif
          continue;
        }

        /* threads::shared uses tie magic ('P') with a threads::shared::tie
         * object, and shared_scalar magic ('n'/'N') for scalars.
         * Cloning these produces invalid tie objects that crash on access.
         * Strip the sharing magic so hv_clone/av_clone can iterate through
         * the tie to read the actual data. (GH #18) */
        if (mg->mg_type == PERL_MAGIC_shared_scalar
            || mg->mg_type == PERL_MAGIC_shared)
          continue;

        /* Some mg_obj's can be null, don't bother cloning */
        if ( mg->mg_obj != NULL )
        {
          switch (mg->mg_type)
          {
            case 'r':	/* PERL_MAGIC_qr  */
              obj = mg->mg_obj;
              has_qr = 1;
              break;
            case 't':	/* PERL_MAGIC_taint */
            case '<': /* PERL_MAGIC_backref */
            case '@':  /* PERL_MAGIC_arylen_p */
              continue; /* resumes the outer magic iteration loop */
            case 'P': /* PERL_MAGIC_tied */
            case 'p': /* PERL_MAGIC_tiedelem */
            case 'q': /* PERL_MAGIC_tiedscalar */
              /* threads::shared::tie objects are not real tie objects --
               * skip them so the clone becomes a plain unshared copy.
               * The data will be read through the tie during hv_clone/av_clone. */
              if (is_threads_shared_tie(mg->mg_obj))
                continue;
	            magic_ref++;
	      /* fall through */
            default:
              obj = sv_clone(mg->mg_obj, hseen, -1, rdepth, weakrefs);
          }
        } else {
          TRACEME(("magic object for type %c in NULL\n", mg->mg_type));
        }

        { /* clone the mg_ptr pv */
          char *mg_ptr = mg->mg_ptr; /* default */

          if (mg->mg_len >= 0) {
            /* sv_magic() with non-negative namlen calls savepvn()
             * internally to make its own copy — no need to allocate
             * an intermediate buffer here; just pass the original
             * mg_ptr through.  (fixes 20-year-old memory leak) */
          } else if (mg->mg_len == HEf_SVKEY) {
            /* mg_ptr is an SV*; sv_magic() below will SvREFCNT_inc it */
          } else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8) { /* copy the cache */
            if (mg->mg_ptr) {
              STRLEN *cache;
              Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
              mg_ptr = (char *) cache;
              Copy(mg->mg_ptr, mg_ptr, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
            }
          } else if ( mg->mg_ptr != NULL) {
            croak("Unsupported magic_ptr clone");
          }

          sv_magic(clone,
                   obj,
                   mg->mg_type,
                   mg_ptr,
                   mg->mg_len);

        }
      }
      /* Null the qr vtable -- avoid mg_find traversal if we already know */
      if (has_qr && (mg = mg_find(clone, 'r')))
        mg->mg_virtual = (MGVTBL *) NULL;
    }
    /* 2: HASH/ARRAY  - (with 'internal' elements) */
    /* For tied HV/AV (magic_ref > 0): skip direct element iteration;
     * the tie magic cloned above handles the data. */
  if ( !magic_ref )
  {
    if ( SvTYPE(ref) == SVt_PVHV )
      clone = hv_clone (ref, clone, hseen, depth, rdepth, weakrefs);
    else if ( SvTYPE(ref) == SVt_PVAV )
      clone = av_clone (ref, clone, hseen, depth, rdepth, weakrefs);
    /* 3: REFERENCE (inlined for speed) */
    else if (SvROK (ref))
      {
        TRACEME(("clone = 0x%x(%d)\n", clone, SvREFCNT(clone)));
        SvREFCNT_dec(SvRV(clone));
        SvRV(clone) = sv_clone (SvRV(ref), hseen, depth, rdepth, weakrefs); /* Clone the referent */
        if (SvOBJECT(SvRV(ref)))
        {
            sv_bless (clone, SvSTASH (SvRV (ref)));
        }
        if (SvWEAKREF(ref)) {
            /* Defer weakening until after the entire clone graph is built.
             * sv_rvweaken decrements the referent's refcount, which can
             * destroy it if no other strong references exist yet.
             * By deferring, we ensure all strong references are in place
             * before any weakening occurs. (fixes GH #15) */
            av_push(weakrefs, SvREFCNT_inc_simple_NN(clone));
        }
      }
  }

  TRACEME(("clone = 0x%x(%d)\n", clone, SvREFCNT(clone)));
  return clone;
}

MODULE = Clone		PACKAGE = Clone

PROTOTYPES: ENABLE

void
clone(self, depth=-1)
	SV *self
	int depth
	PREINIT:
	SV *clone = &PL_sv_undef;
	HV *hseen;
	AV *weakrefs;
	PPCODE:
	hseen = newHV();
	weakrefs = newAV();
	/* Register for automatic cleanup on scope exit.  If sv_clone()
	 * or the weakening loop croaks, the longjmp would skip the
	 * explicit SvREFCNT_dec below — SAVEFREESV ensures both are
	 * freed during stack unwinding. */
	SAVEFREESV((SV *)hseen);
	SAVEFREESV((SV *)weakrefs);
	TRACEME(("ref = 0x%x\n", self));
	clone = sv_clone(self, hseen, depth, 0, weakrefs);
	/* Now apply deferred weakening (GH #15).
	 * All strong references in the clone graph are established,
	 * so it is safe to weaken references without destroying referents. */
	{
	    I32 i;
	    I32 len = av_len(weakrefs);
	    for (i = 0; i <= len; i++) {
	        SV **svp = av_fetch(weakrefs, i, 0);
	        if (svp && *svp && SvROK(*svp)) {
	            sv_rvweaken(*svp);
	        }
	    }
	}
	/* hseen and weakrefs are freed automatically via SAVEFREESV */
	EXTEND(SP,1);
	PUSHs(sv_2mortal(clone));