view release on metacpan or  search on metacpan

Lazy.xs  view on Meta::CPAN

/* First applies the delay magic to the entersubop, then
 * adds one extra op to be run before the entersub itself
 * but after the arguments for it are in the stack
 */
STATIC OP *
THX_ck_delay_caller_args(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
{
    OP* op = THX_ck_delay(aTHX_ entersubop, namegv, ckobj);
    UNOP *newop;
    OP *aop;
    
    aop = cUNOPx(op)->op_first;
    
    if (!aop->op_sibling)
        aop = cUNOPx(aop)->op_first;
    
    for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
    }
    
    NewOp(1234, newop, 1, UNOP);
    newop->op_type    = OP_CUSTOM;
    newop->op_ppaddr  = S_pp_delay;
    newop->op_private = use_caller_args_hint();
    
    aop->op_sibling = (OP*)newop;
    return op;
}

#ifdef USE_ITHREADS
STATIC SV*
clone_sv(pTHX_ SV* sv, tTHX owner)
#define clone_sv(s,v) clone_sv(aTHX_ (s), (v))
{
    CLONE_PARAMS param;
    param.stashes    = NULL;
    param.flags      = 0;
    param.proto_perl = owner;

    return sv_dup_inc(sv, &param);
}

#define clone_av(s,v) MUTABLE_AV(clone_sv((SV*)(s), (v)))
#endif /* USE_ITHREADS */

#ifdef XopENTRY_set
static XOP my_xop, my_wrapop;
#endif

MODULE = Params::Lazy		PACKAGE = Params::Lazy		

PROTOTYPES: ENABLE

void
cv_set_call_checker_delay(CV *cv, SV *proto)
CODE:
    cv_set_call_checker(cv, THX_ck_delay_caller_args, proto);

void
force(sv)
PROTOTYPE: $
PPCODE:
    SV *sv = *PL_stack_sp--;
    S_do_force(aTHX_ sv, use_caller_args_hint());
    SP = PL_stack_sp;

#ifdef USE_ITHREADS

void
CLONE(...)
INIT:
    SV *defav_clone = NULL;
    AV *comppad_clone = NULL;
CODE:
{
    PERL_UNUSED_ARG(items);
    {
        dMY_CXT;
        tTHX owner = MY_CXT.owner;
        
        if ( MY_CXT.orig_defav ) {
            SV *defavref = MY_CXT.orig_defav;
            AV *defav    = MUTABLE_AV(SvRV(defavref));
            defav_clone  = newRV_noinc((SV*)clone_av(defav, owner));
        }
        if ( MY_CXT.orig_comppad ) {
            comppad_clone = clone_av(MY_CXT.orig_comppad, owner);
        }
        /* not needed?
        if ( MY_CXT.orig_curcop ) {
            curcop_clone = (COP*)any_dup(MY_CXT.orig_curcop, owner);
        }
        */
    }
    {
        MY_CXT_CLONE;
        MY_CXT.orig_defav = defav_clone;
        MY_CXT.orig_comppad = comppad_clone;
        MY_CXT.owner      = aTHX;
    }
}

#endif /* USE_ITHREADS */


BOOT:
{
    CV * const cv = get_cvn_flags("Params::Lazy::force", 19, 0);
    MY_CXT_INIT;
    MY_CXT.orig_defav = NULL;
    MY_CXT.orig_comppad = NULL;
    MY_CXT.orig_curcop  = NULL;
    MY_CXT.orig_cxstack_ix = 0;
#ifdef USE_ITHREADS
    MY_CXT.owner = aTHX;
#endif
    cv_set_call_checker(cv, S_ck_force, (SV *)cv);
#ifdef XopENTRY_set
    XopENTRY_set(&my_xop, xop_name, "force");
    XopENTRY_set(&my_xop, xop_desc, "force");
    XopENTRY_set(&my_xop, xop_class, OA_UNOP);
    Perl_custom_op_register(aTHX_ S_pp_force, &my_xop);