view release on metacpan or  search on metacpan

xs/util/util.c  view on Meta::CPAN

static XS(xs_once) {
    dXSARGS;
    if (items != 1) croak("Usage: util::once(\\&func)");

    SV *func = ST(0);
    if (!SvROK(func) || SvTYPE(SvRV(func)) != SVt_PVCV) {
        croak("util::once: argument must be a coderef");
    }

    IV idx = g_once_count++;
    ensure_once_capacity(idx);

    OnceFunc *of = &g_onces[idx];
    of->func = SvREFCNT_inc_simple_NN(func);
    of->result = NULL;
    of->called = FALSE;

    CV *wrapper = newXS(NULL, xs_once_call, __FILE__);
    CvXSUBANY(wrapper).any_iv = idx;

    /* Attach magic for cleanup when wrapper is freed */
    sv_magicext((SV*)wrapper, NULL, PERL_MAGIC_ext, &util_once_vtbl, NULL, idx);

    ST(0) = sv_2mortal(newRV_noinc((SV*)wrapper));
    XSRETURN(1);
}

static XS(xs_once_call) {
    dXSARGS;
    PERL_UNUSED_VAR(items);
    IV idx = CvXSUBANY(cv).any_iv;
    OnceFunc *of = &g_onces[idx];

    if (of->called) {
        ST(0) = of->result ? of->result : &PL_sv_undef;
        XSRETURN(1);
    }

    ENTER;
    SAVETMPS;
    PUSHMARK(SP);
    PUTBACK;

    call_sv(of->func, G_SCALAR);

    SPAGAIN;
    of->result = SvREFCNT_inc(POPs);
    of->called = TRUE;
    PUTBACK;
    FREETMPS;
    LEAVE;

    /* Free the original function, no longer needed */
    SvREFCNT_dec(of->func);
    of->func = NULL;

    ST(0) = of->result;
    XSRETURN(1);
}

/* partial(\&f, @bound) - bind first N args */
static XS(xs_partial) {
    dXSARGS;
    if (items < 1) croak("Usage: util::partial(\\&func, @bound_args)");

    SV *func = ST(0);
    if (!SvROK(func) || SvTYPE(SvRV(func)) != SVt_PVCV) {
        croak("util::partial: first argument must be a coderef");
    }

    IV idx = g_partial_count++;
    ensure_partial_capacity(idx);

    PartialFunc *pf = &g_partials[idx];
    pf->func = SvREFCNT_inc_simple_NN(func);
    pf->bound_args = newAV();

    /* Store bound arguments */
    IV i;
    for (i = 1; i < items; i++) {
        av_push(pf->bound_args, SvREFCNT_inc_simple_NN(ST(i)));
    }

    CV *wrapper = newXS(NULL, xs_partial_call, __FILE__);
    CvXSUBANY(wrapper).any_iv = idx;

    /* Attach magic for cleanup when wrapper is freed */
    sv_magicext((SV*)wrapper, NULL, PERL_MAGIC_ext, &util_partial_vtbl, NULL, idx);

    ST(0) = sv_2mortal(newRV_noinc((SV*)wrapper));
    XSRETURN(1);
}

static XS(xs_partial_call) {
    dXSARGS;
    IV idx = CvXSUBANY(cv).any_iv;
    PartialFunc *pf = &g_partials[idx];

    IV bound_count = av_len(pf->bound_args) + 1;
    IV total = bound_count + items;

    ENTER;
    SAVETMPS;
    PUSHMARK(SP);

    EXTEND(SP, total);

    /* Push bound args first */
    IV i;
    for (i = 0; i < bound_count; i++) {
        SV **elem = av_fetch(pf->bound_args, i, 0);
        PUSHs(elem ? *elem : &PL_sv_undef);
    }

    /* Push call-time args */
    for (i = 0; i < items; i++) {
        PUSHs(ST(i));
    }
    PUTBACK;

    IV count = call_sv(pf->func, G_SCALAR);