view release on metacpan or  search on metacpan

lib/Clone/Closure.xs  view on Meta::CPAN

            /* closed-over lexicals need checking */
            else {
                CV *scope;

                /* start with the scope that declared the lexical... */
                scope = pad_findscope(clone, name_sv);

                /* even if this scope is unique, it may be inside one
                 * which isn't:
                 *     sub foo { eval q/my $x; sub { $x; }/; }
                 * eval STRING is always CvUNIQUE */
                while (scope && CvUNIQUE(scope)) {
                    scope = CvOUTSIDE(scope);
                    TRACE_SCOPE(scope);
                }

                /* XXX handle locating loops: see cop@269 */

                /* if this lexical was defined in a scope that can only
                 * run once it can be copied, otherwise it must be
                 * cloned */
                can_copy = (!scope || CvUNIQUE(scope));
            }
        }

        /* just in case :) */
        else {
            warn("Clone::Closure: unknown pad entry: please report a bug!");
#ifdef DEBUG_CLONE
            warn("name:\n");
            sv_dump(name_sv);
            warn("val:\n");
            sv_dump(val_sv);
#endif
            continue;
        }

        TRACE_SV("ref", name, val_sv);

        if (is_proto) {
            assert(PERL_VERSION < 9);
#ifdef CvWEAKOUTSIDE_on
            assert(CvWEAKOUTSIDE(val_sv));
#endif

            new_sv = (SV *)CC_cv_clone((CV *)val_sv);

            CvCLONE_on(new_sv);
            SvPADMY_on(new_sv);

#ifndef CvWEAKOUTSIDE_on
            {
                CV *old = CvOUTSIDE(new_sv);
                SvREFCNT_dec(old);
                TRACE_SV("ref", "outside", old);
            }
#endif
            CvOUTSIDE(new_sv) = clone;
#ifdef CvWEAKOUTSIDE_on
            TRACE_SV("weaken", name, new_sv);
            TRACE_SV("outside", name, clone);
            CvWEAKOUTSIDE_on(new_sv);
#else
            SvREFCNT_inc(clone);
            TRACE_SV("clone", "outside", clone);
#endif

            pad_clone(SEEN, (CV *)val_sv, (CV *)new_sv);
        }
        else if (can_copy) {
            new_sv = SvREFCNT_inc(val_sv);
            CLONE_STORE(val_sv, new_sv);
        }
        else {
            new_sv = sv_clone(SEEN, val_sv);
        }
         
        TRACE_SV("ref, again", name, val_sv);
        TRACE_SV(can_copy ? "copy" : "clone", name, new_sv);

        old_p    = av_fetch(padv, i, 0);
        old_sv   = old_p ? *old_p : &PL_sv_undef;

        /* can't use av_store as the refcounts get wrong:
         * pads are AvREAL even though they shouldn't be */
        (AvARRAY(padv))[i] = new_sv;

        /* XXX I don't like this: sometimes the refcnt gets too low */
        if ( SvREFCNT(old_sv) > 1 ) {
            SvREFCNT_dec(old_sv);
            TRACE_SV("drop", name, old_sv);
        }
        else
            TRACE_SV("NO DROP", name, old_sv);
    }

    TRACE_SV("clone", "pad", clone);
}

/* locate the scope in which a lexical was declared */
/* mostly stolen from pad.c:pad_findlex */

static CV *
pad_findscope(CV *scope, SV *name_sv)
{
    const char  *name = SvPVX_const(name_sv);
    U32          seq;
    CV          *last_fake = scope;

#ifdef CvOUTSIDE_SEQ
#define MOVE_OUT(scp, sq) sq = CvOUTSIDE_SEQ(scp), scp = CvOUTSIDE(scp)
#else
    seq = SvIVX(name_sv);
#define MOVE_OUT(scp, sq) scp = CvOUTSIDE(scp)
#endif

    TRACE_SCOPE(scope);

    for ( MOVE_OUT(scope, seq); scope; MOVE_OUT(scope, seq) ) {
        SV **svp, *sv;

lib/Clone/Closure.xs  view on Meta::CPAN

                    keepmg = 0;
                    break;
            }

            if (copymg)
                obj = obj ? sv_clone(SEEN, mg->mg_obj) : NULL;

            if (keepmg) {
                TRACE_MG("clone", mg->mg_type, ptr, mg->mg_len, obj);
                sv_magicext(
                    clone, 
                    obj,
                    mg->mg_type, 
                    mg->mg_virtual,
                    ptr, 
                    mg->mg_len
                );
            }
            else {
                TRACE_MG("drop", mg->mg_type, mg->mg_ptr, mg->mg_len,
                mg->mg_obj);
            }
        }

        if (shared > 0) {
#ifdef SvSHARE
            TRACE_SV("share", "SV", clone);
            SvSHARE(clone);
#else
            croak("can't share values in this version of perl");
#endif
        }
    }

    if (!recurse) {
        TRACE_SV("skip", "SV", clone);
    }
    else if ( SvTYPE(ref) == SVt_PVHV ) {
        hv_clone(SEEN, (HV *)ref, (HV *)clone);
    }
    else if ( SvTYPE(ref) == SVt_PVAV ) {
        av_clone(SEEN, (AV *)ref, (AV *)clone);
    }
    else if ( SvTYPE(ref) == SVt_PVCV ) {
        if (CvCLONED((CV *)ref)) {
            pad_clone(SEEN, (CV *)ref, (CV *)clone);
        }
    }
    /* 3: REFERENCE (inlined for speed) */
    else if (SvROK(ref)) {
        TRACE_SV("ref", "RV", ref);

        SvROK_on(clone);
        SvRV(clone) = sv_clone(SEEN, SvRV(ref));

        if (sv_isobject(ref)) {
            sv_bless(clone, SvSTASH(SvRV(ref)));
        }

        if (SvWEAKREF(ref)) {
            TRACE_SV("weaken", "RV", clone);
            sv_rvweaken(clone);
        }

        TRACE_SV("clone", "RV", clone);
    }

    if (SvREADONLY(ref))
        SvREADONLY_on(clone);

    TRACE_SV("clone", "SV", clone);
    return clone;
}

MODULE = Clone::Closure		PACKAGE = Clone::Closure

PROTOTYPES: ENABLE

void
_breakpoint()
    PPCODE:
        XSRETURN_UNDEF;

void
clone(ref)
	SV *ref
    PREINIT:
	SV *clone;
        HV *SEEN;
    PPCODE:
        SEEN = newHV();

        TRACE_SV("ref", "clone", ref);
	clone = sv_clone(SEEN, ref);
        TRACE_SV("clone", "clone", clone);

        SvREFCNT_dec(SEEN);

	EXTEND(SP,1);
	PUSHs(sv_2mortal(clone));