Ancient
view release on metacpan or search on metacpan
xs/util/util.c view on Meta::CPAN
#ifndef HAVE_MEMMEM
#if defined(__GLIBC__) || defined(__APPLE__) || defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__NetBSD__)
#define HAVE_MEMMEM 1
#endif
#endif
#if HAVE_MEMMEM
#define util_memmem memmem
#else
static void *util_memmem(const void *haystack, size_t haystacklen,
const void *needle, size_t needlelen) {
if (needlelen == 0) return (void*)haystack;
if (needlelen > haystacklen) return NULL;
const char *h = (const char*)haystack;
const char *n = (const char*)needle;
const char *end = h + haystacklen - needlelen + 1;
char first = *n;
for (; h < end; h++) {
if (*h == first && memcmp(h, n, needlelen) == 0) {
return (void*)h;
}
}
return NULL;
}
#endif
/* ============================================
Custom op structures
============================================ */
static XOP identity_xop;
static XOP always_xop;
static XOP clamp_xop;
static XOP nvl_xop;
static XOP coalesce_xop;
/* Type predicate custom ops - blazing fast, single SV flag check */
static XOP is_ref_xop;
static XOP is_array_xop;
static XOP is_hash_xop;
static XOP is_code_xop;
static XOP is_defined_xop;
/* String predicate custom ops - direct SvPV/SvCUR access */
static XOP is_empty_xop;
static XOP starts_with_xop;
static XOP ends_with_xop;
/* Boolean/Truthiness custom ops - fast truth checks */
static XOP is_true_xop;
static XOP is_false_xop;
static XOP bool_xop;
/* Extended type predicate custom ops */
static XOP is_num_xop;
static XOP is_int_xop;
static XOP is_blessed_xop;
static XOP is_scalar_ref_xop;
static XOP is_regex_xop;
static XOP is_glob_xop;
static XOP is_string_xop;
/* Numeric predicate custom ops */
static XOP is_positive_xop;
static XOP is_negative_xop;
static XOP is_zero_xop;
/* Numeric utility custom ops */
static XOP is_even_xop;
static XOP is_odd_xop;
static XOP is_between_xop;
/* Collection custom ops - direct AvFILL/HvKEYS access */
static XOP is_empty_array_xop;
static XOP is_empty_hash_xop;
static XOP array_len_xop;
static XOP hash_size_xop;
static XOP array_first_xop;
static XOP array_last_xop;
/* String manipulation custom ops */
static XOP trim_xop;
static XOP ltrim_xop;
static XOP rtrim_xop;
/* Conditional custom ops */
static XOP maybe_xop;
/* Numeric custom ops */
static XOP sign_xop;
static XOP min2_xop;
static XOP max2_xop;
/* ============================================
Memoization structures
============================================ */
typedef struct {
SV *func; /* Original coderef */
HV *cache; /* Result cache */
IV hits; /* Cache hits (stats) */
IV misses; /* Cache misses (stats) */
} MemoizedFunc;
static MemoizedFunc *g_memos = NULL;
static IV g_memo_size = 0;
static IV g_memo_count = 0;
/* ============================================
Lazy evaluation structures
============================================ */
typedef struct {
SV *thunk; /* Deferred computation (coderef) */
SV *value; /* Cached result */
bool forced; /* Has been evaluated? */
} LazyValue;
static LazyValue *g_lazies = NULL;
static IV g_lazy_size = 0;
xs/util/util.c view on Meta::CPAN
return (val % 2) == 0;
}
static bool builtin_is_odd(pTHX_ SV *elem) {
if (!SvIOK(elem) && !SvNOK(elem)) {
if (!SvPOK(elem) || !looks_like_number(elem)) return FALSE;
}
IV val = SvIV(elem);
return (val % 2) != 0;
}
static bool builtin_is_empty(pTHX_ SV *elem) {
if (!SvOK(elem)) return TRUE;
if (SvROK(elem)) {
SV *rv = SvRV(elem);
if (SvTYPE(rv) == SVt_PVAV) return AvFILL((AV*)rv) < 0;
if (SvTYPE(rv) == SVt_PVHV) return HvKEYS((HV*)rv) == 0;
return FALSE;
}
if (SvPOK(elem)) return SvCUR(elem) == 0;
return FALSE;
}
static bool builtin_is_nonempty(pTHX_ SV *elem) {
return !builtin_is_empty(aTHX_ elem);
}
static bool builtin_is_string(pTHX_ SV *elem) {
return (SvPOK(elem) && !SvIOK(elem) && !SvNOK(elem) && !SvROK(elem)) ? TRUE : FALSE;
}
static bool builtin_is_number(pTHX_ SV *elem) {
if (SvIOK(elem) || SvNOK(elem)) return TRUE;
if (SvPOK(elem) && looks_like_number(elem)) return TRUE;
return FALSE;
}
static bool builtin_is_integer(pTHX_ SV *elem) {
if (SvIOK(elem) && !SvNOK(elem)) return TRUE;
if (SvNOK(elem)) {
NV val = SvNV(elem);
return val == (NV)(IV)val;
}
if (SvPOK(elem) && looks_like_number(elem)) {
NV val = SvNV(elem);
return val == (NV)(IV)val;
}
return FALSE;
}
/* ============================================
Callback registry functions
============================================ */
static void init_callback_registry(pTHX) {
if (!g_callback_registry) {
g_callback_registry = newHV();
}
}
/* Cleanup callback registry during global destruction */
static void cleanup_callback_registry(pTHX_ void *data) {
HE *entry;
PERL_UNUSED_ARG(data);
if (!g_callback_registry) return;
/* During global destruction, just NULL out the registry pointer.
* Perl will handle freeing the SVs. Trying to free them ourselves
* can cause crashes due to destruction order issues. */
if (PL_dirty) {
g_callback_registry = NULL;
return;
}
/* Normal cleanup (not during global destruction) */
hv_iterinit(g_callback_registry);
while ((entry = hv_iternext(g_callback_registry))) {
SV *sv = HeVAL(entry);
if (sv && SvOK(sv)) {
RegisteredCallback *cb = (RegisteredCallback*)SvIVX(sv);
if (cb) {
if (cb->perl_callback) {
SvREFCNT_dec(cb->perl_callback);
cb->perl_callback = NULL;
}
if (cb->name) {
Safefree(cb->name);
cb->name = NULL;
}
Safefree(cb);
}
}
}
SvREFCNT_dec((SV*)g_callback_registry);
g_callback_registry = NULL;
}
static RegisteredCallback* get_registered_callback(pTHX_ const char *name) {
SV **svp;
if (!g_callback_registry) return NULL;
svp = hv_fetch(g_callback_registry, name, strlen(name), 0);
if (!svp || !SvOK(*svp)) return NULL;
return (RegisteredCallback*)SvIVX(*svp);
}
/* Register a built-in predicate */
static void register_builtin_predicate(pTHX_ const char *name, UtilPredicateFunc func) {
RegisteredCallback *cb;
SV *sv;
init_callback_registry(aTHX);
Newxz(cb, 1, RegisteredCallback);
cb->name = savepv(name);
cb->predicate = func;
cb->mapper = NULL;
cb->reducer = NULL;
cb->perl_callback = NULL;
sv = newSViv(PTR2IV(cb));
hv_store(g_callback_registry, name, strlen(name), sv, 0);
}
/* Public API for XS modules to register predicates */
PERL_CALLCONV void util_register_predicate_xs(pTHX_ const char *name,
UtilPredicateFunc func) {
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);
}
xs/util/util.c view on Meta::CPAN
NV nv = SvNV(sv);
SETs((nv == (NV)(IV)nv) ? &PL_sv_yes : &PL_sv_no);
} else if (looks_like_number(sv)) {
/* String that looks like a number - check if integer */
STRLEN len;
const char *pv = SvPV(sv, len);
/* Simple check: no decimal point or exponent */
bool has_dot = FALSE;
STRLEN i;
for (i = 0; i < len; i++) {
if (pv[i] == '.' || pv[i] == 'e' || pv[i] == 'E') {
has_dot = TRUE;
break;
}
}
if (has_dot) {
/* Has decimal - check if value is actually integer */
NV nv = SvNV(sv);
SETs((nv == (NV)(IV)nv) ? &PL_sv_yes : &PL_sv_no);
} else {
SETs(&PL_sv_yes);
}
} else {
SETs(&PL_sv_no);
}
RETURN;
}
/* is_blessed: check if value is a blessed reference */
static OP* pp_is_blessed(pTHX) {
dSP;
SV *sv = TOPs;
SETs(sv_isobject(sv) ? &PL_sv_yes : &PL_sv_no);
RETURN;
}
/* is_scalar_ref: check if value is a scalar reference (not array/hash/code/etc) */
static OP* pp_is_scalar_ref(pTHX) {
dSP;
SV *sv = TOPs;
if (SvROK(sv)) {
SV *rv = SvRV(sv);
svtype type = SvTYPE(rv);
/* Scalar refs are < SVt_PVAV (array) */
SETs((type < SVt_PVAV) ? &PL_sv_yes : &PL_sv_no);
} else {
SETs(&PL_sv_no);
}
RETURN;
}
/* is_regex: check if value is a compiled regex */
static OP* pp_is_regex(pTHX) {
dSP;
SV *sv = TOPs;
/* SvRXOK: check if SV is a regex (qr//) - available since Perl 5.10 */
SETs(SvRXOK(sv) ? &PL_sv_yes : &PL_sv_no);
RETURN;
}
/* is_glob: check if value is a glob (*foo) */
static OP* pp_is_glob(pTHX) {
dSP;
SV *sv = TOPs;
SETs((SvTYPE(sv) == SVt_PVGV) ? &PL_sv_yes : &PL_sv_no);
RETURN;
}
/* is_string: check if value is a plain scalar (defined, not a reference) */
static OP* pp_is_string(pTHX) {
dSP;
SV *sv = TOPs;
SETs((SvOK(sv) && !SvROK(sv)) ? &PL_sv_yes : &PL_sv_no);
RETURN;
}
/* ============================================
Numeric predicate custom ops - blazing fast!
Direct SvNV comparison, minimal overhead
============================================ */
/* is_positive: check if value is > 0 */
static OP* pp_is_positive(pTHX) {
dSP;
SV *sv = TOPs;
if (SvNIOK(sv) || looks_like_number(sv)) {
NV nv = SvNV(sv);
SETs((nv > 0) ? &PL_sv_yes : &PL_sv_no);
} else {
SETs(&PL_sv_no);
}
RETURN;
}
/* is_negative: check if value is < 0 */
static OP* pp_is_negative(pTHX) {
dSP;
SV *sv = TOPs;
if (SvNIOK(sv) || looks_like_number(sv)) {
NV nv = SvNV(sv);
SETs((nv < 0) ? &PL_sv_yes : &PL_sv_no);
} else {
SETs(&PL_sv_no);
}
RETURN;
}
/* is_zero: check if value is == 0 */
static OP* pp_is_zero(pTHX) {
dSP;
SV *sv = TOPs;
if (SvNIOK(sv) || looks_like_number(sv)) {
NV nv = SvNV(sv);
SETs((nv == 0) ? &PL_sv_yes : &PL_sv_no);
} else {
SETs(&PL_sv_no);
}
RETURN;
}
/* ============================================
Numeric utility custom ops
xs/util/util.c view on Meta::CPAN
OpMORESIB_set(arg1, arg2);
OpLASTSIB_set(arg2, NULL);
/*
* Create a custom BINOP-style op.
* Use newBINOP to create a proper binary op structure where
* both arguments are children. The optimizer won't eliminate
* children of an op that's going to use them.
*/
OP *binop = newBINOP(OP_NULL, 0, arg1, arg2);
binop->op_type = OP_CUSTOM;
binop->op_ppaddr = pp_func;
binop->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_STACKED;
op_free(entersubop);
return binop;
}
static OP* starts_with_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
return two_arg_string_call_checker(aTHX_ entersubop, namegv, ckobj, pp_starts_with);
}
static OP* ends_with_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
return two_arg_string_call_checker(aTHX_ entersubop, namegv, ckobj, pp_ends_with);
}
/* Boolean/Truthiness call checkers */
static OP* is_true_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
return type_predicate_call_checker(aTHX_ entersubop, namegv, ckobj, pp_is_true);
}
static OP* is_false_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
return type_predicate_call_checker(aTHX_ entersubop, namegv, ckobj, pp_is_false);
}
static OP* bool_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
return type_predicate_call_checker(aTHX_ entersubop, namegv, ckobj, pp_bool);
}
/* Extended type predicate call checkers */
static OP* is_num_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
return type_predicate_call_checker(aTHX_ entersubop, namegv, ckobj, pp_is_num);
}
static OP* is_int_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
return type_predicate_call_checker(aTHX_ entersubop, namegv, ckobj, pp_is_int);
}
static OP* is_blessed_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
return type_predicate_call_checker(aTHX_ entersubop, namegv, ckobj, pp_is_blessed);
}
static OP* is_scalar_ref_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
return type_predicate_call_checker(aTHX_ entersubop, namegv, ckobj, pp_is_scalar_ref);
}
static OP* is_regex_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
return type_predicate_call_checker(aTHX_ entersubop, namegv, ckobj, pp_is_regex);
}
static OP* is_glob_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
return type_predicate_call_checker(aTHX_ entersubop, namegv, ckobj, pp_is_glob);
}
static OP* is_string_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
return type_predicate_call_checker(aTHX_ entersubop, namegv, ckobj, pp_is_string);
}
/* Numeric predicate call checkers */
static OP* is_positive_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
return type_predicate_call_checker(aTHX_ entersubop, namegv, ckobj, pp_is_positive);
}
static OP* is_negative_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
return type_predicate_call_checker(aTHX_ entersubop, namegv, ckobj, pp_is_negative);
}
static OP* is_zero_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
return type_predicate_call_checker(aTHX_ entersubop, namegv, ckobj, pp_is_zero);
}
/* Numeric utility call checkers */
static OP* is_even_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
return type_predicate_call_checker(aTHX_ entersubop, namegv, ckobj, pp_is_even);
}
static OP* is_odd_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
return type_predicate_call_checker(aTHX_ entersubop, namegv, ckobj, pp_is_odd);
}
/* is_between needs 3 args - use same pattern as clamp */
static OP* is_between_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
/* 3-arg ops are complex to optimize with custom ops.
* Fall back to XS function for now. */
PERL_UNUSED_ARG(namegv);
PERL_UNUSED_ARG(ckobj);
return entersubop;
}
/* Collection call checkers */
static OP* is_empty_array_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
return type_predicate_call_checker(aTHX_ entersubop, namegv, ckobj, pp_is_empty_array);
}
static OP* is_empty_hash_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
return type_predicate_call_checker(aTHX_ entersubop, namegv, ckobj, pp_is_empty_hash);
}
static OP* array_len_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
return type_predicate_call_checker(aTHX_ entersubop, namegv, ckobj, pp_array_len);
}
static OP* hash_size_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
return type_predicate_call_checker(aTHX_ entersubop, namegv, ckobj, pp_hash_size);
}
static OP* array_first_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
return type_predicate_call_checker(aTHX_ entersubop, namegv, ckobj, pp_array_first);
}
static OP* array_last_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
return type_predicate_call_checker(aTHX_ entersubop, namegv, ckobj, pp_array_last);
xs/util/util.c view on Meta::CPAN
static XS(xs_is_int) {
dXSARGS;
if (items != 1) croak("Usage: util::is_int($value)");
SV *sv = ST(0);
if (SvIOK(sv)) {
ST(0) = &PL_sv_yes;
} else if (SvNOK(sv)) {
NV nv = SvNV(sv);
ST(0) = (nv == (NV)(IV)nv) ? &PL_sv_yes : &PL_sv_no;
} else if (looks_like_number(sv)) {
STRLEN len;
const char *pv = SvPV(sv, len);
bool has_dot = FALSE;
STRLEN i;
for (i = 0; i < len; i++) {
if (pv[i] == '.' || pv[i] == 'e' || pv[i] == 'E') {
has_dot = TRUE;
break;
}
}
if (has_dot) {
NV nv = SvNV(sv);
ST(0) = (nv == (NV)(IV)nv) ? &PL_sv_yes : &PL_sv_no;
} else {
ST(0) = &PL_sv_yes;
}
} else {
ST(0) = &PL_sv_no;
}
XSRETURN(1);
}
static XS(xs_is_blessed) {
dXSARGS;
if (items != 1) croak("Usage: util::is_blessed($value)");
ST(0) = sv_isobject(ST(0)) ? &PL_sv_yes : &PL_sv_no;
XSRETURN(1);
}
static XS(xs_is_scalar_ref) {
dXSARGS;
if (items != 1) croak("Usage: util::is_scalar_ref($value)");
SV *sv = ST(0);
if (SvROK(sv)) {
SV *rv = SvRV(sv);
svtype type = SvTYPE(rv);
ST(0) = (type < SVt_PVAV) ? &PL_sv_yes : &PL_sv_no;
} else {
ST(0) = &PL_sv_no;
}
XSRETURN(1);
}
static XS(xs_is_regex) {
dXSARGS;
if (items != 1) croak("Usage: util::is_regex($value)");
ST(0) = SvRXOK(ST(0)) ? &PL_sv_yes : &PL_sv_no;
XSRETURN(1);
}
static XS(xs_is_glob) {
dXSARGS;
if (items != 1) croak("Usage: util::is_glob($value)");
ST(0) = (SvTYPE(ST(0)) == SVt_PVGV) ? &PL_sv_yes : &PL_sv_no;
XSRETURN(1);
}
static XS(xs_is_string) {
dXSARGS;
if (items != 1) croak("Usage: util::is_string($value)");
SV *sv = ST(0);
ST(0) = (SvOK(sv) && !SvROK(sv)) ? &PL_sv_yes : &PL_sv_no;
XSRETURN(1);
}
/* ============================================
Numeric predicate XS fallbacks
============================================ */
static XS(xs_is_positive) {
dXSARGS;
if (items != 1) croak("Usage: util::is_positive($value)");
SV *sv = ST(0);
if (SvNIOK(sv) || looks_like_number(sv)) {
NV nv = SvNV(sv);
ST(0) = (nv > 0) ? &PL_sv_yes : &PL_sv_no;
} else {
ST(0) = &PL_sv_no;
}
XSRETURN(1);
}
static XS(xs_is_negative) {
dXSARGS;
if (items != 1) croak("Usage: util::is_negative($value)");
SV *sv = ST(0);
if (SvNIOK(sv) || looks_like_number(sv)) {
NV nv = SvNV(sv);
ST(0) = (nv < 0) ? &PL_sv_yes : &PL_sv_no;
} else {
ST(0) = &PL_sv_no;
}
XSRETURN(1);
}
static XS(xs_is_zero) {
dXSARGS;
if (items != 1) croak("Usage: util::is_zero($value)");
SV *sv = ST(0);
if (SvNIOK(sv) || looks_like_number(sv)) {
NV nv = SvNV(sv);
ST(0) = (nv == 0) ? &PL_sv_yes : &PL_sv_no;
} else {
ST(0) = &PL_sv_no;
}
XSRETURN(1);
}
/* ============================================
Numeric utility XS fallbacks
============================================ */
static XS(xs_is_even) {
xs/util/util.c view on Meta::CPAN
register_export(aTHX_ "any_gt", xs_any_gt, NULL);
register_export(aTHX_ "any_lt", xs_any_lt, NULL);
register_export(aTHX_ "any_ge", xs_any_ge, NULL);
register_export(aTHX_ "any_le", xs_any_le, NULL);
register_export(aTHX_ "any_eq", xs_any_eq, NULL);
register_export(aTHX_ "any_ne", xs_any_ne, NULL);
/* Specialized predicates - all_* */
register_export(aTHX_ "all_gt", xs_all_gt, NULL);
register_export(aTHX_ "all_lt", xs_all_lt, NULL);
register_export(aTHX_ "all_ge", xs_all_ge, NULL);
register_export(aTHX_ "all_le", xs_all_le, NULL);
register_export(aTHX_ "all_eq", xs_all_eq, NULL);
register_export(aTHX_ "all_ne", xs_all_ne, NULL);
/* Specialized predicates - none_* */
register_export(aTHX_ "none_gt", xs_none_gt, NULL);
register_export(aTHX_ "none_lt", xs_none_lt, NULL);
register_export(aTHX_ "none_ge", xs_none_ge, NULL);
register_export(aTHX_ "none_le", xs_none_le, NULL);
register_export(aTHX_ "none_eq", xs_none_eq, NULL);
register_export(aTHX_ "none_ne", xs_none_ne, NULL);
/* Collection functions */
register_export(aTHX_ "pick", xs_pick, NULL);
register_export(aTHX_ "pluck", xs_pluck, NULL);
register_export(aTHX_ "omit", xs_omit, NULL);
register_export(aTHX_ "uniq", xs_uniq, NULL);
register_export(aTHX_ "partition", xs_partition, NULL);
register_export(aTHX_ "defaults", xs_defaults, NULL);
register_export(aTHX_ "count", xs_count, NULL);
register_export(aTHX_ "replace_all", xs_replace_all, NULL);
/* Type predicates */
register_export(aTHX_ "is_ref", xs_is_ref, is_ref_call_checker);
register_export(aTHX_ "is_array", xs_is_array, is_array_call_checker);
register_export(aTHX_ "is_hash", xs_is_hash, is_hash_call_checker);
register_export(aTHX_ "is_code", xs_is_code, is_code_call_checker);
register_export(aTHX_ "is_defined", xs_is_defined, is_defined_call_checker);
register_export(aTHX_ "is_string", xs_is_string, is_string_call_checker);
/* String predicates */
register_export(aTHX_ "is_empty", xs_is_empty, is_empty_call_checker);
register_export(aTHX_ "starts_with", xs_starts_with, starts_with_call_checker);
register_export(aTHX_ "ends_with", xs_ends_with, ends_with_call_checker);
register_export(aTHX_ "trim", xs_trim, trim_call_checker);
register_export(aTHX_ "ltrim", xs_ltrim, ltrim_call_checker);
register_export(aTHX_ "rtrim", xs_rtrim, rtrim_call_checker);
/* Boolean predicates */
register_export(aTHX_ "is_true", xs_is_true, is_true_call_checker);
register_export(aTHX_ "is_false", xs_is_false, is_false_call_checker);
register_export(aTHX_ "bool", xs_bool, bool_call_checker);
/* Extended type predicates */
register_export(aTHX_ "is_num", xs_is_num, is_num_call_checker);
register_export(aTHX_ "is_int", xs_is_int, is_int_call_checker);
register_export(aTHX_ "is_blessed", xs_is_blessed, is_blessed_call_checker);
register_export(aTHX_ "is_scalar_ref", xs_is_scalar_ref, is_scalar_ref_call_checker);
register_export(aTHX_ "is_regex", xs_is_regex, is_regex_call_checker);
register_export(aTHX_ "is_glob", xs_is_glob, is_glob_call_checker);
/* Numeric predicates */
register_export(aTHX_ "is_positive", xs_is_positive, is_positive_call_checker);
register_export(aTHX_ "is_negative", xs_is_negative, is_negative_call_checker);
register_export(aTHX_ "is_zero", xs_is_zero, is_zero_call_checker);
register_export(aTHX_ "is_even", xs_is_even, is_even_call_checker);
register_export(aTHX_ "is_odd", xs_is_odd, is_odd_call_checker);
register_export(aTHX_ "is_between", xs_is_between, is_between_call_checker);
/* Collection predicates */
register_export(aTHX_ "is_empty_array", xs_is_empty_array, is_empty_array_call_checker);
register_export(aTHX_ "is_empty_hash", xs_is_empty_hash, is_empty_hash_call_checker);
register_export(aTHX_ "array_len", xs_array_len, array_len_call_checker);
register_export(aTHX_ "hash_size", xs_hash_size, hash_size_call_checker);
register_export(aTHX_ "array_first", xs_array_first, array_first_call_checker);
register_export(aTHX_ "array_last", xs_array_last, array_last_call_checker);
/* Conditional/numeric ops */
register_export(aTHX_ "maybe", xs_maybe, maybe_call_checker);
register_export(aTHX_ "sign", xs_sign, sign_call_checker);
register_export(aTHX_ "min2", xs_min2, min2_call_checker);
register_export(aTHX_ "max2", xs_max2, max2_call_checker);
}
static char* get_caller(pTHX) {
return HvNAME((HV*)CopSTASH(PL_curcop));
}
/* Fast O(1) import using hash lookup */
static XS(xs_import) {
dXSARGS;
char *pkg = get_caller(aTHX);
IV i;
STRLEN name_len;
char full[512];
for (i = 1; i < items; i++) {
char *name = SvPV(ST(i), name_len);
SV **entry_sv = hv_fetch(g_export_hash, name, name_len, 0);
if (!entry_sv || !*entry_sv) {
croak("util: unknown export '%s'", name);
}
ExportEntry *entry = INT2PTR(ExportEntry*, SvIV(*entry_sv));
snprintf(full, sizeof(full), "%s::%s", pkg, name);
if (entry->xs_func) {
/* XS function: create XS stub in caller's namespace.
* Note: We intentionally do NOT install call checkers on exported
* functions. Call checkers are compile-time optimizations that work
* by transforming the op tree. They work on util::* functions because
* those are installed at boot time before any user code compiles.
* Users who want compile-time optimization should call util::func()
* directly instead of importing. */
CV *cv = newXS(full, entry->xs_func, __FILE__);
PERL_UNUSED_VAR(cv);
} else if (entry->perl_cv) {
/* Perl coderef: create alias in caller's namespace */
GV *gv = gv_fetchpv(full, GV_ADD, SVt_PVCV);
if (gv) {
/* Get the actual CV from the reference */
CV *src_cv = (CV*)SvRV(entry->perl_cv);
/* Assign the CV to the glob's CODE slot */
SvREFCNT_inc((SV*)src_cv);
GvCV_set(gv, src_cv);
}
}
}
XSRETURN_EMPTY;
}
/* ============================================
Boot
============================================ */
XS_EXTERNAL(boot_util) {
dXSBOOTARGSXSAPIVERCHK;
PERL_UNUSED_VAR(items);
/* Initialize built-in loop callbacks */
init_builtin_callbacks(aTHX);
/* Register custom ops */
XopENTRY_set(&identity_xop, xop_name, "identity");
XopENTRY_set(&identity_xop, xop_desc, "identity passthrough");
Perl_custom_op_register(aTHX_ pp_identity, &identity_xop);
XopENTRY_set(&always_xop, xop_name, "always");
XopENTRY_set(&always_xop, xop_desc, "always return stored value");
Perl_custom_op_register(aTHX_ pp_always, &always_xop);
XopENTRY_set(&clamp_xop, xop_name, "clamp");
XopENTRY_set(&clamp_xop, xop_desc, "clamp value between min and max");
Perl_custom_op_register(aTHX_ pp_clamp, &clamp_xop);
/* Register type predicate custom ops */
XopENTRY_set(&is_ref_xop, xop_name, "is_ref");
XopENTRY_set(&is_ref_xop, xop_desc, "check if value is a reference");
Perl_custom_op_register(aTHX_ pp_is_ref, &is_ref_xop);
XopENTRY_set(&is_array_xop, xop_name, "is_array");
XopENTRY_set(&is_array_xop, xop_desc, "check if value is an arrayref");
Perl_custom_op_register(aTHX_ pp_is_array, &is_array_xop);
XopENTRY_set(&is_hash_xop, xop_name, "is_hash");
XopENTRY_set(&is_hash_xop, xop_desc, "check if value is a hashref");
Perl_custom_op_register(aTHX_ pp_is_hash, &is_hash_xop);
XopENTRY_set(&is_code_xop, xop_name, "is_code");
XopENTRY_set(&is_code_xop, xop_desc, "check if value is a coderef");
Perl_custom_op_register(aTHX_ pp_is_code, &is_code_xop);
XopENTRY_set(&is_defined_xop, xop_name, "is_defined");
XopENTRY_set(&is_defined_xop, xop_desc, "check if value is defined");
Perl_custom_op_register(aTHX_ pp_is_defined, &is_defined_xop);
/* Register string predicate custom ops */
XopENTRY_set(&is_empty_xop, xop_name, "is_empty");
XopENTRY_set(&is_empty_xop, xop_desc, "check if string is empty");
Perl_custom_op_register(aTHX_ pp_is_empty, &is_empty_xop);
XopENTRY_set(&starts_with_xop, xop_name, "starts_with");
XopENTRY_set(&starts_with_xop, xop_desc, "check if string starts with prefix");
Perl_custom_op_register(aTHX_ pp_starts_with, &starts_with_xop);
XopENTRY_set(&ends_with_xop, xop_name, "ends_with");
XopENTRY_set(&ends_with_xop, xop_desc, "check if string ends with suffix");
Perl_custom_op_register(aTHX_ pp_ends_with, &ends_with_xop);
/* Register boolean/truthiness custom ops */
XopENTRY_set(&is_true_xop, xop_name, "is_true");
XopENTRY_set(&is_true_xop, xop_desc, "check if value is truthy");
Perl_custom_op_register(aTHX_ pp_is_true, &is_true_xop);
XopENTRY_set(&is_false_xop, xop_name, "is_false");
XopENTRY_set(&is_false_xop, xop_desc, "check if value is falsy");
Perl_custom_op_register(aTHX_ pp_is_false, &is_false_xop);
XopENTRY_set(&bool_xop, xop_name, "bool");
XopENTRY_set(&bool_xop, xop_desc, "normalize to boolean");
Perl_custom_op_register(aTHX_ pp_bool, &bool_xop);
/* Register extended type predicate custom ops */
XopENTRY_set(&is_num_xop, xop_name, "is_num");
XopENTRY_set(&is_num_xop, xop_desc, "check if value is numeric");
Perl_custom_op_register(aTHX_ pp_is_num, &is_num_xop);
XopENTRY_set(&is_int_xop, xop_name, "is_int");
XopENTRY_set(&is_int_xop, xop_desc, "check if value is integer");
Perl_custom_op_register(aTHX_ pp_is_int, &is_int_xop);
XopENTRY_set(&is_blessed_xop, xop_name, "is_blessed");
XopENTRY_set(&is_blessed_xop, xop_desc, "check if value is blessed");
Perl_custom_op_register(aTHX_ pp_is_blessed, &is_blessed_xop);
XopENTRY_set(&is_scalar_ref_xop, xop_name, "is_scalar_ref");
XopENTRY_set(&is_scalar_ref_xop, xop_desc, "check if value is scalar reference");
Perl_custom_op_register(aTHX_ pp_is_scalar_ref, &is_scalar_ref_xop);
XopENTRY_set(&is_regex_xop, xop_name, "is_regex");
XopENTRY_set(&is_regex_xop, xop_desc, "check if value is compiled regex");
Perl_custom_op_register(aTHX_ pp_is_regex, &is_regex_xop);
XopENTRY_set(&is_glob_xop, xop_name, "is_glob");
XopENTRY_set(&is_glob_xop, xop_desc, "check if value is glob");
Perl_custom_op_register(aTHX_ pp_is_glob, &is_glob_xop);
XopENTRY_set(&is_string_xop, xop_name, "is_string");
XopENTRY_set(&is_string_xop, xop_desc, "check if value is plain scalar");
Perl_custom_op_register(aTHX_ pp_is_string, &is_string_xop);
/* Register numeric predicate custom ops */
XopENTRY_set(&is_positive_xop, xop_name, "is_positive");
XopENTRY_set(&is_positive_xop, xop_desc, "check if value is positive");
Perl_custom_op_register(aTHX_ pp_is_positive, &is_positive_xop);
XopENTRY_set(&is_negative_xop, xop_name, "is_negative");
XopENTRY_set(&is_negative_xop, xop_desc, "check if value is negative");
Perl_custom_op_register(aTHX_ pp_is_negative, &is_negative_xop);
XopENTRY_set(&is_zero_xop, xop_name, "is_zero");
XopENTRY_set(&is_zero_xop, xop_desc, "check if value is zero");
Perl_custom_op_register(aTHX_ pp_is_zero, &is_zero_xop);
/* Register numeric utility custom ops */
XopENTRY_set(&is_even_xop, xop_name, "is_even");
XopENTRY_set(&is_even_xop, xop_desc, "check if integer is even");
Perl_custom_op_register(aTHX_ pp_is_even, &is_even_xop);
XopENTRY_set(&is_odd_xop, xop_name, "is_odd");
XopENTRY_set(&is_odd_xop, xop_desc, "check if integer is odd");
Perl_custom_op_register(aTHX_ pp_is_odd, &is_odd_xop);
XopENTRY_set(&is_between_xop, xop_name, "is_between");
XopENTRY_set(&is_between_xop, xop_desc, "check if value is between min and max");
Perl_custom_op_register(aTHX_ pp_is_between, &is_between_xop);
/* Register collection custom ops */
XopENTRY_set(&is_empty_array_xop, xop_name, "is_empty_array");
XopENTRY_set(&is_empty_array_xop, xop_desc, "check if arrayref is empty");
Perl_custom_op_register(aTHX_ pp_is_empty_array, &is_empty_array_xop);
XopENTRY_set(&is_empty_hash_xop, xop_name, "is_empty_hash");
XopENTRY_set(&is_empty_hash_xop, xop_desc, "check if hashref is empty");
Perl_custom_op_register(aTHX_ pp_is_empty_hash, &is_empty_hash_xop);
XopENTRY_set(&array_len_xop, xop_name, "array_len");
XopENTRY_set(&array_len_xop, xop_desc, "get array length");
Perl_custom_op_register(aTHX_ pp_array_len, &array_len_xop);
XopENTRY_set(&hash_size_xop, xop_name, "hash_size");
XopENTRY_set(&hash_size_xop, xop_desc, "get hash key count");
Perl_custom_op_register(aTHX_ pp_hash_size, &hash_size_xop);
XopENTRY_set(&array_first_xop, xop_name, "array_first");
XopENTRY_set(&array_first_xop, xop_desc, "get first array element");
Perl_custom_op_register(aTHX_ pp_array_first, &array_first_xop);
XopENTRY_set(&array_last_xop, xop_name, "array_last");
XopENTRY_set(&array_last_xop, xop_desc, "get last array element");
Perl_custom_op_register(aTHX_ pp_array_last, &array_last_xop);
/* Register string manipulation custom ops */
XopENTRY_set(&trim_xop, xop_name, "trim");
XopENTRY_set(&trim_xop, xop_desc, "trim whitespace from string");
Perl_custom_op_register(aTHX_ pp_trim, &trim_xop);
xs/util/util.c view on Meta::CPAN
CV *cv = newXS("util::is_code", xs_is_code, __FILE__);
cv_set_call_checker(cv, is_code_call_checker, (SV*)cv);
}
{
CV *cv = newXS("util::is_defined", xs_is_defined, __FILE__);
cv_set_call_checker(cv, is_defined_call_checker, (SV*)cv);
}
/* String predicates with call checkers */
{
CV *cv = newXS("util::is_empty", xs_is_empty, __FILE__);
cv_set_call_checker(cv, is_empty_call_checker, (SV*)cv);
}
{
CV *cv = newXS("util::starts_with", xs_starts_with, __FILE__);
cv_set_call_checker(cv, starts_with_call_checker, (SV*)cv);
}
{
CV *cv = newXS("util::ends_with", xs_ends_with, __FILE__);
cv_set_call_checker(cv, ends_with_call_checker, (SV*)cv);
}
newXS("util::count", xs_count, __FILE__);
newXS("util::replace_all", xs_replace_all, __FILE__);
/* Boolean/Truthiness predicates with call checkers */
{
CV *cv = newXS("util::is_true", xs_is_true, __FILE__);
cv_set_call_checker(cv, is_true_call_checker, (SV*)cv);
}
{
CV *cv = newXS("util::is_false", xs_is_false, __FILE__);
cv_set_call_checker(cv, is_false_call_checker, (SV*)cv);
}
{
CV *cv = newXS("util::bool", xs_bool, __FILE__);
cv_set_call_checker(cv, bool_call_checker, (SV*)cv);
}
/* Extended type predicates with call checkers */
{
CV *cv = newXS("util::is_num", xs_is_num, __FILE__);
cv_set_call_checker(cv, is_num_call_checker, (SV*)cv);
}
{
CV *cv = newXS("util::is_int", xs_is_int, __FILE__);
cv_set_call_checker(cv, is_int_call_checker, (SV*)cv);
}
{
CV *cv = newXS("util::is_blessed", xs_is_blessed, __FILE__);
cv_set_call_checker(cv, is_blessed_call_checker, (SV*)cv);
}
{
CV *cv = newXS("util::is_scalar_ref", xs_is_scalar_ref, __FILE__);
cv_set_call_checker(cv, is_scalar_ref_call_checker, (SV*)cv);
}
{
CV *cv = newXS("util::is_regex", xs_is_regex, __FILE__);
cv_set_call_checker(cv, is_regex_call_checker, (SV*)cv);
}
{
CV *cv = newXS("util::is_glob", xs_is_glob, __FILE__);
cv_set_call_checker(cv, is_glob_call_checker, (SV*)cv);
}
/* Numeric predicates with call checkers */
{
CV *cv = newXS("util::is_positive", xs_is_positive, __FILE__);
cv_set_call_checker(cv, is_positive_call_checker, (SV*)cv);
}
{
CV *cv = newXS("util::is_negative", xs_is_negative, __FILE__);
cv_set_call_checker(cv, is_negative_call_checker, (SV*)cv);
}
{
CV *cv = newXS("util::is_zero", xs_is_zero, __FILE__);
cv_set_call_checker(cv, is_zero_call_checker, (SV*)cv);
}
/* Numeric utility ops with call checkers */
{
CV *cv = newXS("util::is_even", xs_is_even, __FILE__);
cv_set_call_checker(cv, is_even_call_checker, (SV*)cv);
}
{
CV *cv = newXS("util::is_odd", xs_is_odd, __FILE__);
cv_set_call_checker(cv, is_odd_call_checker, (SV*)cv);
}
{
CV *cv = newXS("util::is_between", xs_is_between, __FILE__);
cv_set_call_checker(cv, is_between_call_checker, (SV*)cv);
}
/* Collection ops with call checkers */
{
CV *cv = newXS("util::is_empty_array", xs_is_empty_array, __FILE__);
cv_set_call_checker(cv, is_empty_array_call_checker, (SV*)cv);
}
{
CV *cv = newXS("util::is_empty_hash", xs_is_empty_hash, __FILE__);
cv_set_call_checker(cv, is_empty_hash_call_checker, (SV*)cv);
}
{
CV *cv = newXS("util::array_len", xs_array_len, __FILE__);
cv_set_call_checker(cv, array_len_call_checker, (SV*)cv);
}
{
CV *cv = newXS("util::hash_size", xs_hash_size, __FILE__);
cv_set_call_checker(cv, hash_size_call_checker, (SV*)cv);
}
{
CV *cv = newXS("util::array_first", xs_array_first, __FILE__);
cv_set_call_checker(cv, array_first_call_checker, (SV*)cv);
}
{
CV *cv = newXS("util::array_last", xs_array_last, __FILE__);
cv_set_call_checker(cv, array_last_call_checker, (SV*)cv);
}
/* String manipulation ops with call checkers */
{
CV *cv = newXS("util::trim", xs_trim, __FILE__);
cv_set_call_checker(cv, trim_call_checker, (SV*)cv);
}
{
CV *cv = newXS("util::ltrim", xs_ltrim, __FILE__);
cv_set_call_checker(cv, ltrim_call_checker, (SV*)cv);
}
{
CV *cv = newXS("util::rtrim", xs_rtrim, __FILE__);
cv_set_call_checker(cv, rtrim_call_checker, (SV*)cv);
}
/* Conditional ops with call checkers */
{
CV *cv = newXS("util::maybe", xs_maybe, __FILE__);
cv_set_call_checker(cv, maybe_call_checker, (SV*)cv);
}
/* Numeric ops with call checkers */
{
CV *cv = newXS("util::sign", xs_sign, __FILE__);
cv_set_call_checker(cv, sign_call_checker, (SV*)cv);
}
{
CV *cv = newXS("util::min2", xs_min2, __FILE__);
cv_set_call_checker(cv, min2_call_checker, (SV*)cv);
}
{
CV *cv = newXS("util::max2", xs_max2, __FILE__);
cv_set_call_checker(cv, max2_call_checker, (SV*)cv);
}
/* Register cleanup for global destruction */
Perl_call_atexit(aTHX_ cleanup_callback_registry, NULL);
Perl_xs_boot_epilog(aTHX_ ax);
}
( run in 0.569 second using v1.01-cache-2.11-cpan-df04353d9ac )