File Coverage

lib/Data/Clone.xs

Criterion	Covered	Total	%
statement	136	146	93.1
branch	89	124	71.7
condition			n/a
subroutine			n/a
pod			n/a
total	225	270	83.3

#define PERL_NO_GET_CONTEXT
#define NO_XSLOCKS /* for exceptions */
#include "xshelper.h"

#include "data_clone.h"

#ifndef SvRXOK
#define SvRXOK(sv) (SvROK(sv) && SvMAGICAL(SvRV(sv)) && mg_find(SvRV(sv), PERL_MAGIC_qr))
#endif

#define REINTERPRET_CAST(T, value) ((T)value)

#define PTR2STR(ptr) REINTERPRET_CAST(const char*, (&ptr))

#define MY_CXT_KEY "Data::Clone::_guts" XS_VERSION
typedef struct {
    U32 depth;
    HV* seen;
    CV* caller_cv;
    GV* my_clone;
    GV* object_callback;

    SV* clone_method;    /* "clone" */
    SV* tieclone_method; /* "TIECLONE" */
} my_cxt_t;
START_MY_CXT

static SV*
clone_rv(pTHX_ pMY_CXT_ SV* const cloning);

static SV*
clone_sv(pTHX_ pMY_CXT_ SV* const cloning) {
    assert(cloning);

    SvGETMAGIC(cloning);

    if(SvROK(cloning)){
        return clone_rv(aTHX_ aMY_CXT_ cloning);
    }
    else{
        SV* const cloned = newSV(0);
        /* no need to set SV_GMAGIC */
        sv_setsv_flags(cloned, cloning, SV_NOSTEAL);
        return cloned;
    }
}

static void
clone_hv_to(pTHX_ pMY_CXT_ HV* const cloning, HV* const cloned) {
    HE* iter;

    assert(cloning);
    assert(cloned);

    hv_iterinit(cloning);
    while((iter = hv_iternext(cloning))){
        SV* const key = hv_iterkeysv(iter);
        SV* const val = clone_sv(aTHX_ aMY_CXT_ hv_iterval(cloning, iter));
        (void)hv_store_ent(cloned, key, val, 0U);
    }
}

static void
clone_av_to(pTHX_ pMY_CXT_ AV* const cloning, AV* const cloned) {
    I32 last, i;

    assert(cloning);
    assert(cloned);

    last = av_len(cloning);
    av_extend(cloned, last);

    for(i = 0; i <= last; i++){
        SV** const svp = av_fetch(cloning, i, FALSE);
        if(svp){
            (void)av_store(cloned, i, clone_sv(aTHX_ aMY_CXT_ *svp));
        }
    }
}


static GV*
find_method_sv(pTHX_ HV* const stash, SV* const name) {
    HE* const he = hv_fetch_ent(stash, name, FALSE, 0U);

    if(he && isGV(HeVAL(he)) && GvCV((GV*)HeVAL(he))){ /* shortcut */
        return (GV*)HeVAL(he);
    }

    assert(SvPOKp(name));
    return gv_fetchmeth_autoload(stash, SvPVX(name), SvCUR(name), 0);
}

static int
sv_has_backrefs(pTHX_ SV* const sv) {
    if(SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_backref)) {
        return TRUE;
    }
#ifdef HvAUX
    else if(SvTYPE(sv) == SVt_PVHV){
        return SvOOK(sv) && HvAUX((HV*)sv)->xhv_backreferences != NULL;
    }
#endif
    return FALSE;
}

/* my_dopoptosub_at() and caller_cv() are stolen from pp_ctl.c */
static I32
my_dopoptosub_at(pTHX_ const PERL_CONTEXT* const cxstk, I32 const startingblock) {
    I32 i;

    assert(cxstk);

    for (i = startingblock; i >= 0; i--) {
        const PERL_CONTEXT* const cx = &cxstk[i];
        if(CxTYPE(cx) == CXt_SUB){
            break;
        }
    }
    return i;
}

static CV*
caller_cv(pTHX) {
    const PERL_CONTEXT* cx;
    const PERL_CONTEXT* ccstack = cxstack;
    const PERL_SI *si           = PL_curstackinfo;
    I32 cxix                    = my_dopoptosub_at(aTHX_ ccstack, cxstack_ix);
    I32 count                   = 0;

    for (;;) {
        /* we may be in a higher stacklevel, so dig down deeper */
        while (cxix < 0 && si->si_type != PERLSI_MAIN) {
            si      = si->si_prev;
            ccstack = si->si_cxstack;
            cxix = my_dopoptosub_at(aTHX_ ccstack, si->si_cxix);
        }
        if (cxix < 0) {
            return NULL;
        }
        /* skip &DB::sub */
        if (PL_DBsub && GvCV(PL_DBsub) &&
                ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
            count++;
        if (!count--)
            break;

        cxix = my_dopoptosub_at(aTHX_ ccstack, cxix - 1);
    }

    cx = &ccstack[cxix];
    return cx->blk_sub.cv;
}

static void
store_to_seen(pTHX_ pMY_CXT_ SV* const sv, SV* const proto) {
    (void)hv_store(MY_CXT.seen, PTR2STR(sv), sizeof(sv), proto, 0U);
    SvREFCNT_inc_simple_void_NN(proto);
}

static SV*
dc_call_sv1(pTHX_ SV* const proc, SV* const arg1) {
    dSP;
    SV* ret;

    assert(proc);
    assert(arg1);

    ENTER;
    SAVETMPS;

    PUSHMARK(SP);
    XPUSHs(arg1);
    PUTBACK;

    call_sv(proc, G_SCALAR);

    SPAGAIN;
    ret = POPs;
    PUTBACK;

    SvREFCNT_inc_simple_void_NN(ret);

    FREETMPS;
    LEAVE;

    return sv_2mortal(ret);
}

static int
dc_need_to_call(pTHX_ pMY_CXT_ const CV* const method) {
    //warn("dc_need_co_call 0x%p 0x%p 0x%p", method, GvCV(MY_CXT.my_clone), MY_CXT.caller_cv);

    return method != GvCV(MY_CXT.my_clone) && method != MY_CXT.caller_cv;
}


static SV*
dc_clone_object(pTHX_ pMY_CXT_ SV* const cloning, SV* const method_sv) {
    SV* const sv     = SvRV(cloning);
    GV* const method = find_method_sv(aTHX_ SvSTASH(sv), method_sv);

    if(!method){ /* not a clonable object */
        SV* const object_callback = GvSVn(MY_CXT.object_callback);
        /* try to $Data::Clone::ObjectCallback->($cloning) */

        SvGETMAGIC(object_callback);

        if(SvOK(object_callback)){
            SV* const x = dc_call_sv1(aTHX_ object_callback, cloning);

            if(!SvROK(x)){
                croak("ObjectCallback function returned %s, but it must return a reference",
                    SvOK(x) ? SvPV_nolen_const(x) : "undef");
            }

            return x;
        }

        return sv_mortalcopy(cloning);
        croak("Non-clonable object %"SVf" found (missing a %"SVf" method)",
            cloning, method_sv);
    }

    /* has its own clone method */
    if(dc_need_to_call(aTHX_ aMY_CXT_ GvCV(method))){
        SV* const x = dc_call_sv1(aTHX_ (SV*)GvCV(method), cloning);

        if(!SvROK(x)){
            croak("Cloning method '%"SVf"' returned %s, but it must return a reference",
                method_sv, SvOK(x) ? SvPV_nolen_const(x) : "undef");
        }

        return x;
    }
    else { /* default clone() behavior: deep copy */
        return NULL;
    }
}


static SV*
clone_rv(pTHX_ pMY_CXT_ SV* const cloning) {
    int may_be_circular;
    SV*  sv;
    SV*  proto;
    SV*  cloned;
    MAGIC* mg;
    //CV* old_cv;

    assert(cloning);
    assert(SvROK(cloning));

    sv = SvRV(cloning);
    may_be_circular = (SvREFCNT(sv) > 1 || sv_has_backrefs(aTHX_ sv) );

    if(may_be_circular){
        SV** const svp = hv_fetch(MY_CXT.seen, PTR2STR(sv), sizeof(sv), FALSE);
        if(svp){
            proto = *svp;
            goto finish;
        }
    }

    if(SvOBJECT(sv) && !SvRXOK(cloning)){
        proto = dc_clone_object(aTHX_ aMY_CXT_ cloning, MY_CXT.clone_method);

        if(proto){
            proto = SvRV(proto);
            goto finish;
        }

        /* fall through to make a deep copy */
    }
    else if((mg = SvTIED_mg(sv, PERL_MAGIC_tied))){
        assert(SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV);
        proto = dc_clone_object(aTHX_ aMY_CXT_ SvTIED_obj(sv, mg), MY_CXT.tieclone_method);

        if(proto){
            SV* const varsv = (SvTYPE(sv) == SVt_PVHV
                ? (SV*)newHV()
                : (SV*)newAV()); // can we use newSV_type()?
            sv_magic(varsv,  proto, PERL_MAGIC_tied, NULL, 0);
            proto = varsv;
            goto finish;
        }

        /* fall through to make a deep copy */
    }

    /* XXX: need to save caller_cv, or not? */
    //old_cv           = MY_CXT.caller_cv;
    MY_CXT.caller_cv = NULL;

    if(SvTYPE(sv) == SVt_PVAV){
        proto = sv_2mortal((SV*)newAV());
        if(may_be_circular){
            store_to_seen(aTHX_ aMY_CXT_ sv, proto);
        }
        clone_av_to(aTHX_ aMY_CXT_ (AV*)sv, (AV*)proto);
    }
    else if(SvTYPE(sv) == SVt_PVHV){
        proto = sv_2mortal((SV*)newHV());
        if(may_be_circular){
            store_to_seen(aTHX_ aMY_CXT_ sv, proto);
        }
        clone_hv_to(aTHX_ aMY_CXT_ (HV*)sv, (HV*)proto);
    }
    else {
        proto = sv; /* do nothing */
    }

    //MY_CXT.caller_cv = old_cv;

    finish:
    cloned = newRV_inc(proto);

    if(SvOBJECT(sv)){
        sv_bless(cloned, SvSTASH(sv));
    }

    return SvWEAKREF(cloning) ? sv_rvweaken(cloned) : cloned;
}

/* as SV* sv_clone(SV* sv) */
SV*
Data_Clone_sv_clone(pTHX_ SV* const sv) {
    SV* VOL retval = NULL;
    CV* VOL old_cv;
    dMY_CXT;
    dXCPT;

    if(++MY_CXT.depth == U32_MAX){
        croak("Depth overflow on clone()");
    }

    old_cv = MY_CXT.caller_cv;
    MY_CXT.caller_cv = caller_cv(aTHX);

    XCPT_TRY_START {
        retval = sv_2mortal(clone_sv(aTHX_ aMY_CXT_ sv));
    } XCPT_TRY_END

    MY_CXT.caller_cv = old_cv;

    if(--MY_CXT.depth == 0){
        hv_undef(MY_CXT.seen);
    }

    XCPT_CATCH {
        XCPT_RETHROW;
    }
    return retval;
}

static void
my_cxt_initialize(pTHX_ pMY_CXT) {
    MY_CXT.depth    = 0;
    MY_CXT.seen     = newHV();
    MY_CXT.my_clone = CvGV(get_cvs("Data::Clone::clone", GV_ADD));

    MY_CXT.object_callback = gv_fetchpvs("Data::Clone::ObjectCallback", GV_ADDMULTI, SVt_PV);

    MY_CXT.clone_method    = newSVpvs_share("clone");
    MY_CXT.tieclone_method = newSVpvs_share("TIECLONE");
}

MODULE = Data::Clone        PACKAGE = Data::Clone

PROTOTYPES: DISABLE

BOOT:
{
    MY_CXT_INIT;
    my_cxt_initialize(aTHX_ aMY_CXT);
}

#ifdef USE_ITHREADS

void
CLONE(...)
CODE:
{
    MY_CXT_CLONE;
    my_cxt_initialize(aTHX_ aMY_CXT);
    PERL_UNUSED_VAR(items);
}

#endif

void
clone(SV* sv)
CODE:
{
    sv = sv_clone(sv);
    ST(0) = sv;
    XSRETURN(1);
}

bool
is_cloning()
CODE:
{
    dMY_CXT;
    RETVAL = (MY_CXT.depth != 0);
}
OUTPUT:
    RETVAL