PUT results from the CPAN

Ancient

    if (!g_callback_registry) return result;

    hv_iterinit(g_callback_registry);
    while ((entry = hv_iternext(g_callback_registry))) {
        I32 klen;
        char *key = hv_iterkey(entry, &klen);
        av_push(result, newSVpvn(key, klen));
    }
    return result;
}

/* Initialize built-in callbacks (called from BOOT) */
static void init_builtin_callbacks(pTHX) {
    register_builtin_predicate(aTHX_ ":is_defined", builtin_is_defined);
    register_builtin_predicate(aTHX_ ":is_true", builtin_is_true);
    register_builtin_predicate(aTHX_ ":is_false", builtin_is_false);
    register_builtin_predicate(aTHX_ ":is_ref", builtin_is_ref);
    register_builtin_predicate(aTHX_ ":is_array", builtin_is_array);
    register_builtin_predicate(aTHX_ ":is_hash", builtin_is_hash);
    register_builtin_predicate(aTHX_ ":is_code", builtin_is_code);
    register_builtin_predicate(aTHX_ ":is_positive", builtin_is_positive);
    register_builtin_predicate(aTHX_ ":is_negative", builtin_is_negative);
    register_builtin_predicate(aTHX_ ":is_zero", builtin_is_zero);
    register_builtin_predicate(aTHX_ ":is_even", builtin_is_even);
    register_builtin_predicate(aTHX_ ":is_odd", builtin_is_odd);
    register_builtin_predicate(aTHX_ ":is_empty", builtin_is_empty);
    register_builtin_predicate(aTHX_ ":is_nonempty", builtin_is_nonempty);
    register_builtin_predicate(aTHX_ ":is_string", builtin_is_string);
    register_builtin_predicate(aTHX_ ":is_number", builtin_is_number);
    register_builtin_predicate(aTHX_ ":is_integer", builtin_is_integer);
}

/* ============================================
   Custom OP implementations - fastest path
   ============================================ */

/* identity: just return the top of stack */
static OP* pp_identity(pTHX) {
    /* Value already on stack, nothing to do */
    return NORMAL;
}

/* always: push stored value from op_targ index */
static OP* pp_always(pTHX) {
    dSP;
    IV idx = PL_op->op_targ;
    XPUSHs(g_always_values[idx]);
    RETURN;
}

/* clamp: 3 values on stack, return clamped */
static OP* pp_clamp(pTHX) {
    dSP; dMARK; dORIGMARK;
    SV *val_sv, *min_sv, *max_sv;
    NV value, min, max, result;
    
    /* We get 3 args on stack after the mark */
    if (SP - MARK != 3) {
        /* Fallback: just use direct POPs if no mark context */
        SP = ORIGMARK;
        PUTBACK;
        /* Pop without mark - shouldn't happen in list context */
        dSP;
        max_sv = POPs;
        min_sv = POPs;
        val_sv = POPs;
    } else {
        val_sv = MARK[1];
        min_sv = MARK[2];
        max_sv = MARK[3];
        SP = ORIGMARK;  /* reset stack to before args */
    }

    value = SvNV(val_sv);
    min = SvNV(min_sv);
    max = SvNV(max_sv);

    if (value < min) {
        result = min;
    } else if (value > max) {
        result = max;
    } else {
        result = value;
    }
    
    PUSHs(sv_2mortal(newSVnv(result)));
    RETURN;
}

/* nvl: 2 values on stack, return first if defined */
static OP* pp_nvl(pTHX) {
    dSP;
    SV *def_sv = POPs;
    SV *val_sv = TOPs;

    if (!SvOK(val_sv)) {
        SETs(def_sv);
    }
    RETURN;
}

/* ============================================
   Type predicate custom ops - blazing fast!
   These are the fastest possible type checks:
   single SV flag check, no function call overhead
   ============================================ */

/* is_ref: check if value is a reference */
static OP* pp_is_ref(pTHX) {
    dSP;
    SV *sv = TOPs;
    SETs(SvROK(sv) ? &PL_sv_yes : &PL_sv_no);
    RETURN;
}

/* is_array: check if value is an arrayref */
static OP* pp_is_array(pTHX) {
    dSP;
    SV *sv = TOPs;
    SETs((SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV) ? &PL_sv_yes : &PL_sv_no);
    RETURN;

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


    MemoizedFunc *mf = &g_memos[idx];
    mf->func = SvREFCNT_inc_simple_NN(func);
    mf->cache = newHV();
    mf->hits = 0;
    mf->misses = 0;

    /* Create wrapper CV */
    CV *wrapper = newXS(NULL, xs_memo_call, __FILE__);
    CvXSUBANY(wrapper).any_iv = idx;

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

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

static XS(xs_memo_call) {
    dXSARGS;
    IV idx = CvXSUBANY(cv).any_iv;
    MemoizedFunc *mf = &g_memos[idx];

    /* Build cache key from arguments */
    SV *key = build_cache_key(aTHX_ &ST(0), items);
    STRLEN key_len;
    const char *key_pv = SvPV(key, key_len);

    /* Check cache */
    SV **cached = hv_fetch(mf->cache, key_pv, key_len, 0);
    if (cached && SvOK(*cached)) {
        mf->hits++;
        SvREFCNT_dec_NN(key);
        if (SvROK(*cached) && SvTYPE(SvRV(*cached)) == SVt_PVAV) {
            AV *av = (AV*)SvRV(*cached);
            IV len = av_len(av) + 1;
            IV i;
            EXTEND(SP, len);
            for (i = 0; i < len; i++) {
                SV **elem = av_fetch(av, i, 0);
                ST(i) = elem ? *elem : &PL_sv_undef;
            }
            XSRETURN(len);
        } else {
            ST(0) = *cached;
            XSRETURN(1);
        }
    }

    mf->misses++;

    ENTER;
    SAVETMPS;
    PUSHMARK(SP);

    IV i;
    EXTEND(SP, items);
    for (i = 0; i < items; i++) {
        PUSHs(ST(i));
    }
    PUTBACK;

    IV count = call_sv(mf->func, G_ARRAY);

    SPAGAIN;

    if (count == 1) {
        SV *result = SvREFCNT_inc(POPs);
        hv_store(mf->cache, key_pv, key_len, result, 0);
        PUTBACK;
        FREETMPS;
        LEAVE;
        SvREFCNT_dec_NN(key);
        ST(0) = result;
        XSRETURN(1);
    } else if (count > 0) {
        AV *av = newAV();
        av_extend(av, count - 1);
        for (i = count - 1; i >= 0; i--) {
            av_store(av, i, SvREFCNT_inc(POPs));
        }
        SV *result = newRV_noinc((SV*)av);
        hv_store(mf->cache, key_pv, key_len, result, 0);
        PUTBACK;
        FREETMPS;
        LEAVE;
        SvREFCNT_dec_NN(key);
        for (i = 0; i < count; i++) {
            SV **elem = av_fetch(av, i, 0);
            ST(i) = elem ? *elem : &PL_sv_undef;
        }
        XSRETURN(count);
    } else {
        hv_store(mf->cache, key_pv, key_len, &PL_sv_undef, 0);
        PUTBACK;
        FREETMPS;
        LEAVE;
        SvREFCNT_dec_NN(key);
        XSRETURN_EMPTY;
    }
}

/* ============================================
   Pipe/Compose implementation
   ============================================ */

static XS(xs_pipe) {
    dXSARGS;
    if (items < 2) croak("Usage: util::pipeline($value, \\&fn1, \\&fn2, ...)");

    SV *value = SvREFCNT_inc(ST(0));
    IV i;

    for (i = 1; i < items; i++) {
        SV *func = ST(i);
        if (!SvROK(func) || SvTYPE(SvRV(func)) != SVt_PVCV) {
            SvREFCNT_dec(value);
            croak("util::pipeline: argument %d is not a coderef", (int)i);
        }

        ENTER;
        SAVETMPS;
        PUSHMARK(SP);
        XPUSHs(value);
        PUTBACK;

        call_sv(func, G_SCALAR);

        SPAGAIN;
        SV *new_value = POPs;
        SvREFCNT_inc(new_value);
        PUTBACK;
        FREETMPS;
        LEAVE;

        SvREFCNT_dec(value);
        value = new_value;
    }

    ST(0) = sv_2mortal(value);
    XSRETURN(1);
}

static XS(xs_compose) {
    dXSARGS;
    if (items < 1) croak("Usage: util::compose(\\&fn1, \\&fn2, ...)");

    AV *funcs = newAV();
    av_extend(funcs, items - 1);
    IV i;
    for (i = 0; i < items; i++) {
        SV *func = ST(i);
        if (!SvROK(func) || SvTYPE(SvRV(func)) != SVt_PVCV) {
            croak("util::compose: argument %d is not a coderef", (int)(i+1));
        }
        av_store(funcs, i, SvREFCNT_inc_simple_NN(func));
    }

    CV *wrapper = newXS(NULL, xs_compose_call, __FILE__);
    CvXSUBANY(wrapper).any_ptr = (void*)funcs;

    /* Attach magic for cleanup when wrapper is freed - pass AV via mg_ptr */
    sv_magicext((SV*)wrapper, NULL, PERL_MAGIC_ext, &util_compose_vtbl, (char*)funcs, 0);

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

static XS(xs_compose_call) {
    dXSARGS;
    AV *funcs = (AV*)CvXSUBANY(cv).any_ptr;
    IV func_count = av_len(funcs) + 1;

    SV *value = NULL;

    IV i;
    for (i = func_count - 1; i >= 0; i--) {
        SV **func_ptr = av_fetch(funcs, i, 0);
        if (!func_ptr) continue;

        ENTER;
        SAVETMPS;
        PUSHMARK(SP);

        if (i == func_count - 1) {
            IV j;
            EXTEND(SP, items);
            for (j = 0; j < items; j++) {
                PUSHs(ST(j));
            }
        } else {
            XPUSHs(value);
        }
        PUTBACK;

        call_sv(*func_ptr, G_SCALAR);

        SPAGAIN;
        SV *new_value = POPs;
        SvREFCNT_inc(new_value);
        PUTBACK;
        FREETMPS;
        LEAVE;

        if (value) SvREFCNT_dec(value);
        value = new_value;
    }

    ST(0) = value ? sv_2mortal(value) : &PL_sv_undef;
    XSRETURN(1);
}

/* ============================================
   Lazy evaluation implementation
   ============================================ */

static XS(xs_lazy) {
    dXSARGS;
    if (items != 1) croak("Usage: util::lazy(sub { ... })");

    SV *thunk = ST(0);
    if (!SvROK(thunk) || SvTYPE(SvRV(thunk)) != SVt_PVCV) {
        croak("util::lazy requires a coderef");
    }

    IV idx = g_lazy_count++;
    ensure_lazy_capacity(idx);

    LazyValue *lv = &g_lazies[idx];
    lv->thunk = SvREFCNT_inc_simple_NN(thunk);
    lv->value = NULL;
    lv->forced = FALSE;

    SV *obj = newSViv(idx);
    SV *ref = newRV_noinc(obj);
    sv_bless(ref, gv_stashpv("util::Lazy", GV_ADD));

    /* Attach magic for cleanup when lazy object is freed */
    sv_magicext(obj, NULL, PERL_MAGIC_ext, &util_lazy_vtbl, NULL, idx);

    ST(0) = sv_2mortal(ref);
    XSRETURN(1);
}

static XS(xs_force) {
    dXSARGS;
    if (items != 1) croak("Usage: util::force($lazy)");

    SV *lazy = ST(0);

    if (!SvROK(lazy) || !sv_derived_from(lazy, "util::Lazy")) {
        ST(0) = lazy;
        XSRETURN(1);
    }

    IV idx = SvIV(SvRV(lazy));
    if (idx < 0 || idx >= g_lazy_count) {
        croak("util::force: invalid lazy value");
    }

    LazyValue *lv = &g_lazies[idx];

    if (lv->forced) {
        ST(0) = lv->value;
        XSRETURN(1);
    }

    ENTER;
    SAVETMPS;
    PUSHMARK(SP);
    PUTBACK;

    call_sv(lv->thunk, G_SCALAR);

    SPAGAIN;
    lv->value = SvREFCNT_inc(POPs);
    lv->forced = TRUE;
    PUTBACK;
    FREETMPS;
    LEAVE;

    SvREFCNT_dec(lv->thunk);
    lv->thunk = NULL;

    ST(0) = lv->value;
    XSRETURN(1);
}

/* ============================================
   Safe navigation (dig) implementation
   ============================================ */

static XS(xs_dig) {
    dXSARGS;
    if (items < 2) croak("Usage: util::dig($hash, @keys)");

    SV *current = ST(0);
    IV i;

    for (i = 1; i < items; i++) {
        if (!SvROK(current) || SvTYPE(SvRV(current)) != SVt_PVHV) {
            XSRETURN_UNDEF;
        }

        HV *hv = (HV*)SvRV(current);
        SV *key = ST(i);
        STRLEN key_len;
        const char *key_pv = SvPV(key, key_len);

        SV **val = hv_fetch(hv, key_pv, key_len, 0);
        if (!val || !SvOK(*val)) {
            XSRETURN_UNDEF;
        }

        current = *val;
    }

    ST(0) = current;
    XSRETURN(1);
}

/* ============================================
   Tap implementation
   ============================================ */

static XS(xs_tap) {
    dXSARGS;
    if (items != 2) croak("Usage: util::tap(\\&block, $value)");

    SV *func = ST(0);
    SV *value = ST(1);

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

    ENTER;
    SAVETMPS;
    SAVE_DEFSV;
    DEFSV_set(value);

    PUSHMARK(SP);
    XPUSHs(value);
    PUTBACK;

    call_sv(func, G_DISCARD | G_VOID);

    SPAGAIN;
    FREETMPS;
    LEAVE;

    ST(0) = value;
    XSRETURN(1);
}

/* ============================================
   Clamp XS fallback
   ============================================ */

static XS(xs_clamp) {
    dXSARGS;
    NV value, min, max, result;
    if (items != 3) croak("Usage: util::clamp($value, $min, $max)");

    value = SvNV(ST(0));
    min = SvNV(ST(1));
    max = SvNV(ST(2));

    if (value < min) {
        result = min;
    } else if (value > max) {
        result = max;
    } else {
        result = value;
    }

    ST(0) = sv_2mortal(newSVnv(result));
    XSRETURN(1);
}

/* ============================================
   Identity XS fallback
   ============================================ */

static XS(xs_identity) {
    dXSARGS;
    if (items != 1) croak("Usage: util::identity($value)");
    XSRETURN(1);
}

/* ============================================
   Always implementation
   ============================================ */

static XS(xs_always) {
    dXSARGS;
    if (items != 1) croak("Usage: util::always($value)");

    IV idx = g_always_count++;
    ensure_always_capacity(idx);

    g_always_values[idx] = SvREFCNT_inc_simple_NN(ST(0));

    CV *wrapper = newXS(NULL, xs_always_call, __FILE__);

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

    dXSARGS;
    PERL_UNUSED_VAR(items);
    if (GIMME_V == G_ARRAY) {
        XSRETURN_EMPTY;
    }
    ST(0) = sv_2mortal(newRV_noinc((SV*)newHV()));
    XSRETURN(1);
}

/* stub_string() - always returns empty string '' */
static XS(xs_stub_string) {
    dXSARGS;
    PERL_UNUSED_VAR(items);
    /* Return shared empty string constant - XSRETURN_NO returns '' */
    XSRETURN_NO;
}

/* stub_zero() - always returns 0 */
static XS(xs_stub_zero) {
    dXSARGS;
    PERL_UNUSED_VAR(items);
    /* Return shared 0 SV */
    ST(0) = &PL_sv_zero;
    XSRETURN(1);
}

/* ============================================
   Functional combinators
   ============================================ */

/* negate(\&pred) - returns a function that returns the opposite */
static XS(xs_negate) {
    dXSARGS;
    if (items != 1) croak("Usage: util::negate(\\&predicate)");

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

    CV *wrapper = newXS(NULL, xs_negate_call, __FILE__);
    CvXSUBANY(wrapper).any_ptr = SvREFCNT_inc_simple_NN(pred);

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

static XS(xs_negate_call) {
    dXSARGS;
    SV *pred = (SV*)CvXSUBANY(cv).any_ptr;

    ENTER;
    SAVETMPS;
    PUSHMARK(SP);

    IV i;
    EXTEND(SP, items);
    for (i = 0; i < items; i++) {
        PUSHs(ST(i));
    }
    PUTBACK;

    call_sv(pred, G_SCALAR);

    SPAGAIN;
    SV *result = POPs;
    bool val = SvTRUE(result);
    PUTBACK;
    FREETMPS;
    LEAVE;

    ST(0) = val ? &PL_sv_no : &PL_sv_yes;
    XSRETURN(1);
}

/* once(\&f) - execute once, cache forever */
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);

    SPAGAIN;
    SV *result = count > 0 ? POPs : &PL_sv_undef;
    SvREFCNT_inc(result);
    PUTBACK;
    FREETMPS;
    LEAVE;

    ST(0) = sv_2mortal(result);
    XSRETURN(1);
}

/* ============================================
   Data extraction functions
   ============================================ */

/* pick($hash, @keys) - extract subset of keys
 * Returns hashref in scalar context, flattened list in list context */
static XS(xs_pick) {
    dXSARGS;
    if (items < 1) croak("Usage: util::pick(\\%%hash, @keys)");

    SV *href = ST(0);
    if (!SvROK(href) || SvTYPE(SvRV(href)) != SVt_PVHV) {
        croak("util::pick: first argument must be a hashref");
    }

    HV *src = (HV*)SvRV(href);
    HV *dest = newHV();

    IV i;
    for (i = 1; i < items; i++) {
        SV *key = ST(i);
        STRLEN key_len;
        const char *key_pv = SvPV(key, key_len);

        SV **val = hv_fetch(src, key_pv, key_len, 0);
        if (val && SvOK(*val)) {
            hv_store(dest, key_pv, key_len, SvREFCNT_inc(*val), 0);
        }
    }

    /* Check calling context */
    if (GIMME_V == G_ARRAY) {
        /* List context - return flattened key-value pairs */
        IV n = HvUSEDKEYS(dest);
        SP -= items;  /* Reset stack pointer */
        EXTEND(SP, n * 2);

        hv_iterinit(dest);
        HE *he;
        while ((he = hv_iternext(dest)) != NULL) {
            STRLEN klen;
            const char *key = HePV(he, klen);
            mPUSHp(key, klen);
            mPUSHs(SvREFCNT_inc(HeVAL(he)));
        }
        SvREFCNT_dec((SV*)dest);  /* Free the temp hash */
        PUTBACK;
        return;
    }

    /* Scalar context - return hashref */
    ST(0) = sv_2mortal(newRV_noinc((SV*)dest));
    XSRETURN(1);
}

/* pluck(\@hashes, $field) - extract field from each hash */
static XS(xs_pluck) {
    dXSARGS;
    if (items != 2) croak("Usage: util::pluck(\\@array, $field)");

    SV *aref = ST(0);
    if (!SvROK(aref) || SvTYPE(SvRV(aref)) != SVt_PVAV) {
        croak("util::pluck: first argument must be an arrayref");
    }

    SV *field = ST(1);
    STRLEN field_len;
    const char *field_pv = SvPV(field, field_len);

    AV *src = (AV*)SvRV(aref);
    IV len = av_len(src) + 1;
    AV *dest = newAV();
    av_extend(dest, len - 1);

    IV i;
    for (i = 0; i < len; i++) {
        SV **elem = av_fetch(src, i, 0);
        if (elem && SvROK(*elem) && SvTYPE(SvRV(*elem)) == SVt_PVHV) {
            HV *hv = (HV*)SvRV(*elem);
            SV **val = hv_fetch(hv, field_pv, field_len, 0);
            if (val && SvOK(*val)) {
                av_push(dest, SvREFCNT_inc(*val));
            } else {
                av_push(dest, &PL_sv_undef);
            }
        } else {
            av_push(dest, &PL_sv_undef);
        }
    }

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

/* omit($hash, @keys) - exclude subset of keys (inverse of pick)
 * Returns hashref in scalar context, flattened list in list context */
static XS(xs_omit) {
    dXSARGS;
    if (items < 1) croak("Usage: util::omit(\\%%hash, @keys)");

    SV *href = ST(0);
    if (!SvROK(href) || SvTYPE(SvRV(href)) != SVt_PVHV) {
        croak("util::omit: first argument must be a hashref");
    }

    HV *src = (HV*)SvRV(href);
    HV *dest = newHV();

    /* Build exclusion set for O(1) lookup */
    HV *exclude = newHV();
    IV i;
    for (i = 1; i < items; i++) {
        SV *key = ST(i);
        STRLEN key_len;
        const char *key_pv = SvPV(key, key_len);
        hv_store(exclude, key_pv, key_len, &PL_sv_yes, 0);
    }

    /* Iterate source, copy non-excluded keys */
    hv_iterinit(src);
    HE *entry;
    while ((entry = hv_iternext(src)) != NULL) {
        SV *key = hv_iterkeysv(entry);
        STRLEN key_len;
        const char *key_pv = SvPV(key, key_len);

        if (!hv_exists(exclude, key_pv, key_len)) {
            SV *val = hv_iterval(src, entry);
            if (SvOK(val)) {
                hv_store(dest, key_pv, key_len, SvREFCNT_inc(val), 0);
            }
        }
    }

    SvREFCNT_dec((SV*)exclude);

    /* Check calling context */
    if (GIMME_V == G_ARRAY) {
        /* List context - return flattened key-value pairs */
        IV n = HvUSEDKEYS(dest);
        SP -= items;  /* Reset stack pointer */
        EXTEND(SP, n * 2);

        hv_iterinit(dest);
        HE *he;
        while ((he = hv_iternext(dest)) != NULL) {
            STRLEN klen;
            const char *key = HePV(he, klen);
            mPUSHp(key, klen);
            mPUSHs(SvREFCNT_inc(HeVAL(he)));
        }
        SvREFCNT_dec((SV*)dest);  /* Free the temp hash */
        PUTBACK;
        return;
    }

    /* Scalar context - return hashref */
    ST(0) = sv_2mortal(newRV_noinc((SV*)dest));
    XSRETURN(1);
}

/* uniq(@list) - return unique elements (preserves order) */
static XS(xs_uniq) {
    dXSARGS;

    if (items == 0) {
        XSRETURN(0);
    }

    if (items == 1) {
        XSRETURN(1);
    }

    /* For small lists, use simple O(n^2) - faster due to no hash overhead */
    if (items <= 8) {
        IV out = 0;
        IV i, j;
        for (i = 0; i < items; i++) {
            SV *elem = ST(i);
            STRLEN len_i;
            const char *key_i = SvOK(elem) ? SvPV_const(elem, len_i) : "\x00UNDEF\x00";
            if (!SvOK(elem)) len_i = 7;
            
            bool dup = FALSE;
            for (j = 0; j < out; j++) {
                SV *prev = ST(j);
                STRLEN len_j;
                const char *key_j = SvOK(prev) ? SvPV_const(prev, len_j) : "\x00UNDEF\x00";
                if (!SvOK(prev)) len_j = 7;
                
                if (len_i == len_j && memcmp(key_i, key_j, len_i) == 0) {
                    dup = TRUE;
                    break;
                }
            }
            if (!dup) ST(out++) = elem;
        }
        XSRETURN(out);
    }

    HV *seen = newHV();
    IV out = 0;
    hv_ksplit(seen, items);

    IV i;
    for (i = 0; i < items; i++) {
        SV *elem = ST(i);
        STRLEN len;
        const char *key;
        U32 hash;

        key = SvOK(elem) ? SvPV_const(elem, len) : (len = 7, "\x00UNDEF\x00");

        PERL_HASH(hash, key, len);

        if (!hv_common(seen, NULL, key, len, 0, HV_FETCH_ISEXISTS, NULL, hash)) {
            hv_common(seen, NULL, key, len, 0, HV_FETCH_ISSTORE, &PL_sv_yes, hash);
            ST(out++) = elem;
        }
    }

    SvREFCNT_dec_NN((SV*)seen);
    XSRETURN(out);
}

/* partition(\&pred, @list) - split into [matches], [non-matches] */
static XS(xs_partition) {
    dXSARGS;
    if (items < 1) croak("Usage: util::partition(\\&block, @list)");

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

    IV list_len = items - 1;
    
    if (list_len == 0) {
        AV *pass = newAV();
        AV *fail = newAV();
        AV *outer = newAV();
        av_push(outer, newRV_noinc((SV*)pass));
        av_push(outer, newRV_noinc((SV*)fail));
        ST(0) = sv_2mortal(newRV_noinc((SV*)outer));
        XSRETURN(1);
    }

    AV *pass = newAV();
    AV *fail = newAV();
    av_extend(pass, list_len >> 1);
    av_extend(fail, list_len >> 1);

    SV *orig_defsv = DEFSV;

    IV i;
    for (i = 1; i < items; i++) {
        SV *elem = ST(i);

        DEFSV_set(elem);

        ENTER;
        SAVETMPS;
        PUSHMARK(SP);
        XPUSHs(elem);
        PUTBACK;

        call_sv(block, G_SCALAR);

        SPAGAIN;
        SV *result = POPs;
        bool matched = SvTRUE(result);
        PUTBACK;
        FREETMPS;
        LEAVE;

        if (matched) {
            av_push(pass, SvREFCNT_inc_simple_NN(elem));
        } else {
            av_push(fail, SvREFCNT_inc_simple_NN(elem));
        }
    }

    DEFSV_set(orig_defsv);

    AV *outer = newAV();
    av_push(outer, newRV_noinc((SV*)pass));
    av_push(outer, newRV_noinc((SV*)fail));

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

/* defaults($hash, $defaults) - fill in missing keys from defaults
 * Returns hashref in scalar context, flattened list in list context */
static XS(xs_defaults) {
    dXSARGS;
    if (items != 2) croak("Usage: util::defaults(\\%%hash, \\%%defaults)");

    SV *href = ST(0);
    SV *dref = ST(1);

    if (!SvROK(href) || SvTYPE(SvRV(href)) != SVt_PVHV) {
        croak("util::defaults: first argument must be a hashref");
    }
    if (!SvROK(dref) || SvTYPE(SvRV(dref)) != SVt_PVHV) {
        croak("util::defaults: second argument must be a hashref");
    }

    HV *src = (HV*)SvRV(href);
    HV *def = (HV*)SvRV(dref);

    /* Pre-size dest hash */
    IV src_keys = HvUSEDKEYS(src);
    IV def_keys = HvUSEDKEYS(def);
    HV *dest = newHV();
    hv_ksplit(dest, src_keys + def_keys);

    /* Copy all from source first */
    hv_iterinit(src);
    HE *entry;
    while ((entry = hv_iternext(src)) != NULL) {
        STRLEN key_len;
        const char *key_pv = HePV(entry, key_len);
        SV *val = HeVAL(entry);
        hv_store(dest, key_pv, key_len, SvREFCNT_inc_simple_NN(val), HeHASH(entry));
    }

    /* Fill in missing from defaults - use pre-computed hash */
    hv_iterinit(def);
    while ((entry = hv_iternext(def)) != NULL) {
        STRLEN key_len;
        const char *key_pv = HePV(entry, key_len);
        U32 hash = HeHASH(entry);

        /* Check if exists and is defined in dest */
        SV **existing = hv_fetch(dest, key_pv, key_len, 0);
        if (!existing || !SvOK(*existing)) {
            SV *val = HeVAL(entry);
            hv_store(dest, key_pv, key_len, SvREFCNT_inc_simple_NN(val), hash);
        }
    }

    /* Check calling context */
    if (GIMME_V == G_ARRAY) {
        /* List context - return flattened key-value pairs */
        IV n = HvUSEDKEYS(dest);
        SP -= items;  /* Reset stack pointer */
        EXTEND(SP, n * 2);

        hv_iterinit(dest);
        HE *he;
        while ((he = hv_iternext(dest)) != NULL) {
            STRLEN klen;
            const char *key = HePV(he, klen);
            mPUSHp(key, klen);
            mPUSHs(SvREFCNT_inc(HeVAL(he)));
        }
        SvREFCNT_dec((SV*)dest);  /* Free the temp hash */
        PUTBACK;
        return;
    }

    /* Scalar context - return hashref */
    ST(0) = sv_2mortal(newRV_noinc((SV*)dest));
    XSRETURN(1);
}

/* ============================================
   Null coalescing functions
   ============================================ */

/* nvl($x, $default) - return $x if defined, else $default */
static XS(xs_nvl) {
    dXSARGS;
    if (items != 2) croak("Usage: util::nvl($value, $default)");

    SV *val = ST(0);
    if (SvOK(val)) {
        XSRETURN(1);  /* Return first arg */
    }
    ST(0) = ST(1);
    XSRETURN(1);
}

/* coalesce($a, $b, ...) - return first defined value */
static XS(xs_coalesce) {
    dXSARGS;
    if (items < 1) croak("Usage: util::coalesce($val, ...)");

    IV i;
    for (i = 0; i < items; i++) {
        if (SvOK(ST(i))) {
            ST(0) = ST(i);
            XSRETURN(1);
        }
    }
    /* All undefined, return undef */
    ST(0) = &PL_sv_undef;
    XSRETURN(1);
}

/* ============================================
   List functions (first, any, all, none)

   These use MULTICALL for pure Perl subs which is significantly
   faster than call_sv() for repeated invocations.

   For XS subs, we fall back to call_sv().
   ============================================ */

/* Inline CALLRUNOPS - experimental optimization to skip function call overhead.
   Use cautiously - this inlines the runops loop directly. */
#define INLINE_RUNOPS() \
    STMT_START { \
        OP *_inline_op = PL_op; \
        while ((_inline_op = _inline_op->op_ppaddr(aTHX))) ; \
    } STMT_END

/* ============================================

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


    ST(0) = a >= b ? ST(0) : ST(1);
    XSRETURN(1);
}

/* ============================================
   Named callback loop functions
   These accept a callback name instead of coderef
   ============================================ */

/* any_cb(\@list, ':predicate') - true if any element matches */
static XS(xs_any_cb) {
    dXSARGS;
    if (items != 2) croak("Usage: util::any_cb(\\@list, $callback_name)");

    SV *list_sv = ST(0);
    if (!SvROK(list_sv) || SvTYPE(SvRV(list_sv)) != SVt_PVAV) {
        croak("util::any_cb: first argument must be an arrayref");
    }
    AV *list = (AV*)SvRV(list_sv);

    STRLEN name_len;
    const char *name = SvPV(ST(1), name_len);

    RegisteredCallback *cb = get_registered_callback(aTHX_ name);
    if (!cb) {
        croak("util::any_cb: unknown callback '%s'", name);
    }
    if (!cb->predicate && !cb->perl_callback) {
        croak("util::any_cb: callback '%s' is not a predicate", name);
    }

    IV len = av_len(list) + 1;
    IV i;

    if (cb->predicate) {
        /* Fast C path */
        for (i = 0; i < len; i++) {
            SV **svp = av_fetch(list, i, 0);
            if (svp && cb->predicate(aTHX_ *svp)) {
                XSRETURN_YES;
            }
        }
    } else if (cb->perl_callback) {
        /* Perl callback fallback - use isolated stack scope */
        for (i = 0; i < len; i++) {
            SV **svp = av_fetch(list, i, 0);
            if (!svp) continue;

            bool matches = FALSE;
            {
                dSP;
                int count;
                SV *result;

                ENTER;
                SAVETMPS;

                PUSHMARK(SP);
                XPUSHs(*svp);
                PUTBACK;

                count = call_sv(cb->perl_callback, G_SCALAR);

                SPAGAIN;
                if (count > 0) {
                    result = POPs;
                    matches = SvTRUE(result);
                }
                PUTBACK;

                FREETMPS;
                LEAVE;
            }

            if (matches) {
                XSRETURN_YES;
            }
        }
    }

    XSRETURN_NO;
}

/* all_cb(\@list, ':predicate') - true if all elements match */
static XS(xs_all_cb) {
    dXSARGS;
    if (items != 2) croak("Usage: util::all_cb(\\@list, $callback_name)");

    SV *list_sv = ST(0);
    if (!SvROK(list_sv) || SvTYPE(SvRV(list_sv)) != SVt_PVAV) {
        croak("util::all_cb: first argument must be an arrayref");
    }
    AV *list = (AV*)SvRV(list_sv);

    STRLEN name_len;
    const char *name = SvPV(ST(1), name_len);

    RegisteredCallback *cb = get_registered_callback(aTHX_ name);
    if (!cb) {
        croak("util::all_cb: unknown callback '%s'", name);
    }
    if (!cb->predicate && !cb->perl_callback) {
        croak("util::all_cb: callback '%s' is not a predicate", name);
    }

    IV len = av_len(list) + 1;
    IV i;

    /* Empty list returns true (vacuous truth) */
    if (len == 0) {
        XSRETURN_YES;
    }

    if (cb->predicate) {
        for (i = 0; i < len; i++) {
            SV **svp = av_fetch(list, i, 0);
            if (!svp || !cb->predicate(aTHX_ *svp)) {
                XSRETURN_NO;
            }
        }
    } else if (cb->perl_callback) {
        for (i = 0; i < len; i++) {
            SV **svp = av_fetch(list, i, 0);
            if (!svp) { XSRETURN_NO; }
            bool matches = FALSE;
            {
                dSP;
                int count;
                SV *result;
                ENTER; SAVETMPS;
                PUSHMARK(SP);
                XPUSHs(*svp);
                PUTBACK;
                count = call_sv(cb->perl_callback, G_SCALAR);
                SPAGAIN;
                if (count > 0) {
                    result = POPs;
                    matches = SvTRUE(result);
                }
                PUTBACK;
                FREETMPS; LEAVE;
            }
            if (!matches) {
                XSRETURN_NO;
            }
        }
    }

    XSRETURN_YES;
}

/* none_cb(\@list, ':predicate') - true if no elements match */
static XS(xs_none_cb) {
    dXSARGS;
    if (items != 2) croak("Usage: util::none_cb(\\@list, $callback_name)");

    SV *list_sv = ST(0);
    if (!SvROK(list_sv) || SvTYPE(SvRV(list_sv)) != SVt_PVAV) {
        croak("util::none_cb: first argument must be an arrayref");
    }
    AV *list = (AV*)SvRV(list_sv);

    STRLEN name_len;
    const char *name = SvPV(ST(1), name_len);

    RegisteredCallback *cb = get_registered_callback(aTHX_ name);
    if (!cb) {
        croak("util::none_cb: unknown callback '%s'", name);
    }
    if (!cb->predicate && !cb->perl_callback) {
        croak("util::none_cb: callback '%s' is not a predicate", name);
    }

    IV len = av_len(list) + 1;
    IV i;

    if (cb->predicate) {
        for (i = 0; i < len; i++) {
            SV **svp = av_fetch(list, i, 0);
            if (svp && cb->predicate(aTHX_ *svp)) {
                XSRETURN_NO;
            }
        }
    } else if (cb->perl_callback) {
        for (i = 0; i < len; i++) {
            SV **svp = av_fetch(list, i, 0);
            if (!svp) continue;
            bool matches = FALSE;
            {
                dSP;
                int count;
                SV *result;
                ENTER; SAVETMPS;
                PUSHMARK(SP);
                XPUSHs(*svp);
                PUTBACK;
                count = call_sv(cb->perl_callback, G_SCALAR);
                SPAGAIN;
                if (count > 0) {
                    result = POPs;
                    matches = SvTRUE(result);
                }
                PUTBACK;
                FREETMPS; LEAVE;
            }
            if (matches) {
                XSRETURN_NO;
            }
        }
    }

    XSRETURN_YES;
}

/* first_cb(\@list, ':predicate') - first matching element */
static XS(xs_first_cb) {
    dXSARGS;
    if (items != 2) croak("Usage: util::first_cb(\\@list, $callback_name)");

    SV *list_sv = ST(0);
    if (!SvROK(list_sv) || SvTYPE(SvRV(list_sv)) != SVt_PVAV) {
        croak("util::first_cb: first argument must be an arrayref");
    }
    AV *list = (AV*)SvRV(list_sv);

    STRLEN name_len;
    const char *name = SvPV(ST(1), name_len);

    RegisteredCallback *cb = get_registered_callback(aTHX_ name);
    if (!cb) {
        croak("util::first_cb: unknown callback '%s'", name);
    }
    if (!cb->predicate && !cb->perl_callback) {
        croak("util::first_cb: callback '%s' is not a predicate", name);
    }

    IV len = av_len(list) + 1;
    IV i;

    if (cb->predicate) {
        for (i = 0; i < len; i++) {
            SV **svp = av_fetch(list, i, 0);
            if (svp && cb->predicate(aTHX_ *svp)) {
                ST(0) = *svp;
                XSRETURN(1);
            }
        }
    } else if (cb->perl_callback) {
        for (i = 0; i < len; i++) {
            SV **svp = av_fetch(list, i, 0);
            if (!svp) continue;
            bool matches = FALSE;
            {
                dSP;
                int count;
                SV *result;
                ENTER; SAVETMPS;
                PUSHMARK(SP);
                XPUSHs(*svp);
                PUTBACK;
                count = call_sv(cb->perl_callback, G_SCALAR);
                SPAGAIN;
                if (count > 0) {
                    result = POPs;
                    matches = SvTRUE(result);
                }
                PUTBACK;
                FREETMPS; LEAVE;
            }
            if (matches) {
                ST(0) = *svp;
                XSRETURN(1);
            }
        }
    }

    XSRETURN_UNDEF;
}

/* grep_cb(\@list, ':predicate') - all matching elements */
static XS(xs_grep_cb) {
    dXSARGS;
    if (items != 2) croak("Usage: util::grep_cb(\\@list, $callback_name)");

    SV *list_sv = ST(0);
    if (!SvROK(list_sv) || SvTYPE(SvRV(list_sv)) != SVt_PVAV) {
        croak("util::grep_cb: first argument must be an arrayref");
    }
    AV *list = (AV*)SvRV(list_sv);

    STRLEN name_len;
    const char *name = SvPV(ST(1), name_len);

    RegisteredCallback *cb = get_registered_callback(aTHX_ name);
    if (!cb) {
        croak("util::grep_cb: unknown callback '%s'", name);
    }
    if (!cb->predicate && !cb->perl_callback) {
        croak("util::grep_cb: callback '%s' is not a predicate", name);
    }

    IV len = av_len(list) + 1;
    IV i;
    IV count = 0;

    /* Collect matching elements in a temporary array first */
    AV *results = newAV();
    sv_2mortal((SV*)results);

    if (cb->predicate) {
        for (i = 0; i < len; i++) {
            SV **svp = av_fetch(list, i, 0);
            if (svp && cb->predicate(aTHX_ *svp)) {
                av_push(results, SvREFCNT_inc(*svp));
                count++;
            }
        }
    } else if (cb->perl_callback) {
        for (i = 0; i < len; i++) {
            SV **svp = av_fetch(list, i, 0);
            if (!svp) continue;
            SV *elem = *svp;
            bool matches = FALSE;
            {
                dSP;
                int call_count;
                SV *result;
                ENTER; SAVETMPS;
                PUSHMARK(SP);
                XPUSHs(elem);
                PUTBACK;
                call_count = call_sv(cb->perl_callback, G_SCALAR);
                SPAGAIN;
                if (call_count > 0) {
                    result = POPs;
                    matches = SvTRUE(result);
                }
                PUTBACK;
                FREETMPS; LEAVE;
            }
            if (matches) {
                av_push(results, SvREFCNT_inc(elem));
                count++;
            }
        }
    }

    /* Now push all results to the stack */
    SP -= items;
    for (i = 0; i < count; i++) {
        SV **svp = av_fetch(results, i, 0);
        if (svp) {
            XPUSHs(sv_2mortal(SvREFCNT_inc(*svp)));
        }
    }

    PUTBACK;
    XSRETURN(count);
}

/* count_cb(\@list, ':predicate') - count matching elements */
static XS(xs_count_cb) {
    dXSARGS;
    if (items != 2) croak("Usage: util::count_cb(\\@list, $callback_name)");

    SV *list_sv = ST(0);
    if (!SvROK(list_sv) || SvTYPE(SvRV(list_sv)) != SVt_PVAV) {
        croak("util::count_cb: first argument must be an arrayref");
    }
    AV *list = (AV*)SvRV(list_sv);

    STRLEN name_len;
    const char *name = SvPV(ST(1), name_len);

    RegisteredCallback *cb = get_registered_callback(aTHX_ name);
    if (!cb) {
        croak("util::count_cb: unknown callback '%s'", name);
    }
    if (!cb->predicate && !cb->perl_callback) {
        croak("util::count_cb: callback '%s' is not a predicate", name);
    }

    IV len = av_len(list) + 1;
    IV i;
    IV count = 0;

    if (cb->predicate) {
        for (i = 0; i < len; i++) {
            SV **svp = av_fetch(list, i, 0);
            if (svp && cb->predicate(aTHX_ *svp)) {
                count++;
            }
        }
    } else if (cb->perl_callback) {
        for (i = 0; i < len; i++) {
            SV **svp = av_fetch(list, i, 0);
            if (!svp) continue;
            bool matches = FALSE;
            {
                dSP;
                int call_count;
                SV *result;
                ENTER; SAVETMPS;
                PUSHMARK(SP);
                XPUSHs(*svp);
                PUTBACK;
                call_count = call_sv(cb->perl_callback, G_SCALAR);
                SPAGAIN;
                if (call_count > 0) {
                    result = POPs;
                    matches = SvTRUE(result);
                }
                PUTBACK;
                FREETMPS; LEAVE;
            }
            if (matches) {
                count++;
            }
        }
    }

    XSRETURN_IV(count);
}

/* partition_cb(\@list, ':predicate') - split into [matches], [non-matches] */
static XS(xs_partition_cb) {
    dXSARGS;
    if (items != 2) croak("Usage: util::partition_cb(\\@list, $callback_name)");

    SV *list_sv = ST(0);
    if (!SvROK(list_sv) || SvTYPE(SvRV(list_sv)) != SVt_PVAV) {
        croak("util::partition_cb: first argument must be an arrayref");
    }
    AV *list = (AV*)SvRV(list_sv);

    STRLEN name_len;
    const char *name = SvPV(ST(1), name_len);

    RegisteredCallback *cb = get_registered_callback(aTHX_ name);
    if (!cb) {
        croak("util::partition_cb: unknown callback '%s'", name);
    }
    if (!cb->predicate && !cb->perl_callback) {
        croak("util::partition_cb: callback '%s' is not a predicate", name);
    }

    IV len = av_len(list) + 1;
    AV *pass = newAV();
    AV *fail = newAV();
    av_extend(pass, len >> 1);
    av_extend(fail, len >> 1);

    IV i;
    if (cb->predicate) {
        for (i = 0; i < len; i++) {
            SV **svp = av_fetch(list, i, 0);
            if (!svp) continue;
            if (cb->predicate(aTHX_ *svp)) {
                av_push(pass, SvREFCNT_inc_simple_NN(*svp));
            } else {
                av_push(fail, SvREFCNT_inc_simple_NN(*svp));
            }
        }
    } else if (cb->perl_callback) {
        for (i = 0; i < len; i++) {
            SV **svp = av_fetch(list, i, 0);
            if (!svp) continue;
            bool matches = FALSE;
            {
                dSP;
                int call_count;
                SV *result;

                ENTER;
                SAVETMPS;

                PUSHMARK(SP);
                XPUSHs(*svp);
                PUTBACK;

                call_count = call_sv(cb->perl_callback, G_SCALAR);

                SPAGAIN;
                if (call_count > 0) {
                    result = POPs;
                    matches = SvTRUE(result);
                }
                PUTBACK;

                FREETMPS;
                LEAVE;
            }
            if (matches) {
                av_push(pass, SvREFCNT_inc_simple_NN(*svp));
            } else {
                av_push(fail, SvREFCNT_inc_simple_NN(*svp));
            }
        }
    }

    /* Return list of two arrayrefs */
    ST(0) = sv_2mortal(newRV_noinc((SV*)pass));
    ST(1) = sv_2mortal(newRV_noinc((SV*)fail));
    XSRETURN(2);
}

/* final_cb(\@list, ':predicate') - find last matching element */
static XS(xs_final_cb) {
    dXSARGS;
    if (items != 2) croak("Usage: util::final_cb(\\@list, $callback_name)");

    SV *list_sv = ST(0);
    if (!SvROK(list_sv) || SvTYPE(SvRV(list_sv)) != SVt_PVAV) {
        croak("util::final_cb: first argument must be an arrayref");
    }
    AV *list = (AV*)SvRV(list_sv);

    STRLEN name_len;
    const char *name = SvPV(ST(1), name_len);

    RegisteredCallback *cb = get_registered_callback(aTHX_ name);
    if (!cb) {
        croak("util::final_cb: unknown callback '%s'", name);
    }
    if (!cb->predicate && !cb->perl_callback) {
        croak("util::final_cb: callback '%s' is not a predicate", name);
    }

    IV len = av_len(list) + 1;
    IV i;

    if (cb->predicate) {
        /* Search from end - C predicate path */
        for (i = len - 1; i >= 0; i--) {
            SV **svp = av_fetch(list, i, 0);
            if (svp && cb->predicate(aTHX_ *svp)) {
                ST(0) = *svp;
                XSRETURN(1);
            }
        }
    } else if (cb->perl_callback) {
        /* Search from end - Perl callback path */
        for (i = len - 1; i >= 0; i--) {
            SV **svp = av_fetch(list, i, 0);
            if (!svp) continue;
            bool matches = FALSE;
            {
                dSP;
                int count;
                SV *result;
                ENTER; SAVETMPS;
                PUSHMARK(SP);
                XPUSHs(*svp);
                PUTBACK;
                count = call_sv(cb->perl_callback, G_SCALAR);
                SPAGAIN;
                if (count > 0) {
                    result = POPs;
                    matches = SvTRUE(result);
                }
                PUTBACK;
                FREETMPS; LEAVE;
            }
            if (matches) {
                ST(0) = *svp;
                XSRETURN(1);
            }
        }
    }

    XSRETURN_UNDEF;
}

/* Perl-level callback registration */
static XS(xs_register_callback) {
    dXSARGS;
    if (items != 2) croak("Usage: util::register_callback($name, \\&coderef)");

    STRLEN name_len;
    const char *name = SvPV(ST(0), name_len);

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

    RegisteredCallback *cb;
    SV *sv;

    init_callback_registry(aTHX);

    /* Check if already registered */
    if (get_registered_callback(aTHX_ name)) {
        croak("Callback '%s' is already registered", name);
    }

    Newxz(cb, 1, RegisteredCallback);
    cb->name = savepv(name);
    cb->predicate = NULL;
    cb->mapper = NULL;
    cb->reducer = NULL;
    /* Store a copy of the coderef (RV to CV) */
    cb->perl_callback = newSVsv(coderef);

    sv = newSViv(PTR2IV(cb));
    hv_store(g_callback_registry, name, name_len, sv, 0);

    XSRETURN_YES;
}

/* Check if callback exists */
static XS(xs_has_callback) {
    dXSARGS;
    if (items != 1) croak("Usage: util::has_callback($name)");

    STRLEN name_len;
    const char *name = SvPV(ST(0), name_len);

    if (has_callback(aTHX_ name)) {
        XSRETURN_YES;
    }

( run in 1.746 second using v1.01-cache-2.11-cpan-13bb782fe5a )