Ancient
view release on metacpan or search on metacpan
xs/util/util.c view on Meta::CPAN
IV new_size = g_partial_size ? g_partial_size * 2 : 16;
while (new_size <= needed) new_size *= 2;
Renew(g_partials, new_size, PartialFunc);
g_partial_size = new_size;
}
}
/* Build cache key from stack arguments */
static SV* build_cache_key(pTHX_ SV **args, IV count) {
SV *key = newSVpvs("");
IV i;
for (i = 0; i < count; i++) {
if (i > 0) sv_catpvs(key, "\x00");
if (SvOK(args[i])) {
STRLEN len;
const char *pv = SvPV(args[i], len);
sv_catpvn(key, pv, len);
} else {
sv_catpvs(key, "\x01UNDEF\x01");
}
}
return key;
}
/* ============================================
Built-in predicates for loop callbacks
(prefixed with ':' for built-in names)
============================================ */
static bool builtin_is_defined(pTHX_ SV *elem) {
return SvOK(elem) ? TRUE : FALSE;
}
static bool builtin_is_true(pTHX_ SV *elem) {
return SvTRUE(elem) ? TRUE : FALSE;
}
static bool builtin_is_false(pTHX_ SV *elem) {
return !SvTRUE(elem) ? TRUE : FALSE;
}
static bool builtin_is_ref(pTHX_ SV *elem) {
return SvROK(elem) ? TRUE : FALSE;
}
static bool builtin_is_array(pTHX_ SV *elem) {
return (SvROK(elem) && SvTYPE(SvRV(elem)) == SVt_PVAV) ? TRUE : FALSE;
}
static bool builtin_is_hash(pTHX_ SV *elem) {
return (SvROK(elem) && SvTYPE(SvRV(elem)) == SVt_PVHV) ? TRUE : FALSE;
}
static bool builtin_is_code(pTHX_ SV *elem) {
return (SvROK(elem) && SvTYPE(SvRV(elem)) == SVt_PVCV) ? TRUE : FALSE;
}
static bool builtin_is_positive(pTHX_ SV *elem) {
if (SvIOK(elem)) return SvIV(elem) > 0;
if (SvNOK(elem)) return SvNV(elem) > 0;
if (SvPOK(elem) && looks_like_number(elem)) return SvNV(elem) > 0;
return FALSE;
}
static bool builtin_is_negative(pTHX_ SV *elem) {
if (SvIOK(elem)) return SvIV(elem) < 0;
if (SvNOK(elem)) return SvNV(elem) < 0;
if (SvPOK(elem) && looks_like_number(elem)) return SvNV(elem) < 0;
return FALSE;
}
static bool builtin_is_zero(pTHX_ SV *elem) {
if (SvIOK(elem)) return SvIV(elem) == 0;
if (SvNOK(elem)) return SvNV(elem) == 0.0;
if (SvPOK(elem) && looks_like_number(elem)) return SvNV(elem) == 0.0;
return FALSE;
}
static bool builtin_is_even(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_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);
xs/util/util.c view on Meta::CPAN
/* ends_with: check if string ends with suffix */
static OP* pp_ends_with(pTHX) {
dSP;
SV *suffix_sv = POPs;
SV *str_sv = TOPs;
if (!SvOK(str_sv) || !SvOK(suffix_sv)) {
SETs(&PL_sv_no);
RETURN;
}
STRLEN str_len, suffix_len;
const char *str = SvPV(str_sv, str_len);
const char *suffix = SvPV(suffix_sv, suffix_len);
if (suffix_len > str_len) {
SETs(&PL_sv_no);
} else if (suffix_len == 0) {
SETs(&PL_sv_yes); /* Empty suffix always matches */
} else {
const char *str_end = str + str_len - suffix_len;
SETs(memcmp(str_end, suffix, suffix_len) == 0 ? &PL_sv_yes : &PL_sv_no);
}
RETURN;
}
/* ============================================
Boolean/Truthiness custom ops - blazing fast!
Direct SvTRUE check, minimal overhead
============================================ */
/* is_true: check if value is truthy (Perl truth semantics) */
static OP* pp_is_true(pTHX) {
dSP;
SV *sv = TOPs;
SETs(SvTRUE(sv) ? &PL_sv_yes : &PL_sv_no);
RETURN;
}
/* is_false: check if value is falsy (Perl truth semantics) */
static OP* pp_is_false(pTHX) {
dSP;
SV *sv = TOPs;
SETs(SvTRUE(sv) ? &PL_sv_no : &PL_sv_yes);
RETURN;
}
/* bool: normalize to boolean (1 or empty string) */
static OP* pp_bool(pTHX) {
dSP;
SV *sv = TOPs;
SETs(SvTRUE(sv) ? &PL_sv_yes : &PL_sv_no);
RETURN;
}
/* ============================================
Extended type predicate custom ops - blazing fast!
============================================ */
/* is_num: check if value is numeric (has numeric value or looks like number) */
static OP* pp_is_num(pTHX) {
dSP;
SV *sv = TOPs;
/* SvNIOK: has numeric (NV or IV) value cached */
/* Also check looks_like_number for strings that can be numbers */
SETs((SvNIOK(sv) || looks_like_number(sv)) ? &PL_sv_yes : &PL_sv_no);
RETURN;
}
/* is_int: check if value is an integer */
static OP* pp_is_int(pTHX) {
dSP;
SV *sv = TOPs;
/* SvIOK: has integer value cached */
if (SvIOK(sv)) {
SETs(&PL_sv_yes);
} else if (SvNOK(sv)) {
/* It's a float - check if it's a whole number */
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
============================================ */
/* is_even: check if integer is even (single bitwise AND) */
static OP* pp_is_even(pTHX) {
dSP;
SV *sv = TOPs;
if (SvIOK(sv)) {
SETs((SvIVX(sv) & 1) == 0 ? &PL_sv_yes : &PL_sv_no);
} else if (SvNIOK(sv)) {
NV nv = SvNV(sv);
if (nv == (NV)(IV)nv) {
SETs(((IV)nv & 1) == 0 ? &PL_sv_yes : &PL_sv_no);
} else {
SETs(&PL_sv_no);
}
} else if (looks_like_number(sv)) {
SETs((SvIV(sv) & 1) == 0 ? &PL_sv_yes : &PL_sv_no);
} else {
SETs(&PL_sv_no);
}
RETURN;
}
/* is_odd: check if integer is odd (single bitwise AND) */
static OP* pp_is_odd(pTHX) {
dSP;
SV *sv = TOPs;
if (SvIOK(sv)) {
SETs((SvIVX(sv) & 1) == 1 ? &PL_sv_yes : &PL_sv_no);
} else if (SvNIOK(sv)) {
NV nv = SvNV(sv);
if (nv == (NV)(IV)nv) {
SETs(((IV)nv & 1) == 1 ? &PL_sv_yes : &PL_sv_no);
} else {
SETs(&PL_sv_no);
}
} else if (looks_like_number(sv)) {
SETs((SvIV(sv) & 1) == 1 ? &PL_sv_yes : &PL_sv_no);
} else {
SETs(&PL_sv_no);
}
RETURN;
}
/* is_between: check if value is between min and max (inclusive) */
static OP* pp_is_between(pTHX) {
dSP;
SV *max_sv = POPs;
SV *min_sv = POPs;
SV *val_sv = TOPs;
if (SvNIOK(val_sv) || looks_like_number(val_sv)) {
NV val = SvNV(val_sv);
NV min = SvNV(min_sv);
NV max = SvNV(max_sv);
SETs((val >= min && val <= max) ? &PL_sv_yes : &PL_sv_no);
} else {
SETs(&PL_sv_no);
}
RETURN;
}
/* ============================================
Collection custom ops - direct AvFILL/HvKEYS access
============================================ */
/* is_empty_array: check if arrayref is empty - direct AvFILL */
static OP* pp_is_empty_array(pTHX) {
dSP;
SV *sv = TOPs;
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV) {
AV *av = (AV*)SvRV(sv);
SETs(AvFILL(av) < 0 ? &PL_sv_yes : &PL_sv_no);
} else {
SETs(&PL_sv_no); /* Not an arrayref */
}
RETURN;
}
/* is_empty_hash: check if hashref is empty - direct HvKEYS */
static OP* pp_is_empty_hash(pTHX) {
dSP;
SV *sv = TOPs;
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV) {
HV *hv = (HV*)SvRV(sv);
SETs(HvKEYS(hv) == 0 ? &PL_sv_yes : &PL_sv_no);
} else {
SETs(&PL_sv_no); /* Not a hashref */
}
RETURN;
}
/* array_len: get array length - direct AvFILL + 1 */
static OP* pp_array_len(pTHX) {
dSP;
SV *sv = TOPs;
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV) {
AV *av = (AV*)SvRV(sv);
SV *len = sv_2mortal(newSViv(AvFILL(av) + 1));
SETs(len);
} else {
SETs(&PL_sv_undef); /* Not an arrayref */
}
RETURN;
}
/* hash_size: get hash key count - direct HvKEYS */
static OP* pp_hash_size(pTHX) {
dSP;
SV *sv = TOPs;
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV) {
HV *hv = (HV*)SvRV(sv);
xs/util/util.c view on Meta::CPAN
while (start < end && isSPACE(*start)) {
start++;
}
SV *result = sv_2mortal(newSVpvn(start, end - start));
SETs(result);
RETURN;
}
/* rtrim: remove trailing whitespace only */
static OP* pp_rtrim(pTHX) {
dSP;
SV *sv = TOPs;
if (!SvOK(sv)) {
SETs(&PL_sv_undef);
RETURN;
}
STRLEN len;
const char *str = SvPV(sv, len);
const char *end = str + len;
/* Skip trailing whitespace */
while (end > str && isSPACE(*(end - 1))) {
end--;
}
SV *result = sv_2mortal(newSVpvn(str, end - str));
SETs(result);
RETURN;
}
/* ============================================
Conditional custom ops
============================================ */
/* maybe: return $then if $val is defined, else undef */
static OP* pp_maybe(pTHX) {
dSP;
SV *then_sv = POPs;
SV *val_sv = TOPs;
if (SvOK(val_sv)) {
SETs(then_sv);
} else {
SETs(&PL_sv_undef);
}
RETURN;
}
/* ============================================
Numeric custom ops
============================================ */
/* sign: return -1, 0, or 1 based on value */
static OP* pp_sign(pTHX) {
dSP;
SV *sv = TOPs;
if (!SvNIOK(sv) && !looks_like_number(sv)) {
SETs(&PL_sv_undef);
RETURN;
}
NV nv = SvNV(sv);
if (nv > 0) {
SETs(sv_2mortal(newSViv(1)));
} else if (nv < 0) {
SETs(sv_2mortal(newSViv(-1)));
} else {
SETs(sv_2mortal(newSViv(0)));
}
RETURN;
}
/* min2: return smaller of two values */
static OP* pp_min2(pTHX) {
dSP;
SV *b_sv = POPs;
SV *a_sv = TOPs;
NV a = SvNV(a_sv);
NV b = SvNV(b_sv);
SETs(a <= b ? a_sv : b_sv);
RETURN;
}
/* max2: return larger of two values */
static OP* pp_max2(pTHX) {
dSP;
SV *b_sv = POPs;
SV *a_sv = TOPs;
NV a = SvNV(a_sv);
NV b = SvNV(b_sv);
SETs(a >= b ? a_sv : b_sv);
RETURN;
}
/* ============================================
Call checkers - replace function calls with custom ops
============================================ */
/*
* Check if an op is accessing $_ (the default variable).
* Custom ops now properly handle list context with marks,
* but we still fall back to XS for $_ because of how map/grep
* set up the op tree with $_ - the argument evaluation is different.
* Returns TRUE if we should fall back to XS.
*/
static bool op_is_dollar_underscore(pTHX_ OP *op) {
if (!op) return FALSE;
/* Check for $_ access: rv2sv -> gv for "_" */
if (op->op_type == OP_RV2SV) {
OP *gvop = cUNOPx(op)->op_first;
if (gvop && gvop->op_type == OP_GV) {
xs/util/util.c view on Meta::CPAN
SV *str_sv = ST(0);
SV *delim_sv = ST(1);
if (!SvOK(str_sv)) {
ST(0) = &PL_sv_undef;
XSRETURN(1);
}
STRLEN str_len, delim_len;
const char *str = SvPV_const(str_sv, str_len);
const char *delim = SvPV_const(delim_sv, delim_len);
if (delim_len == 0 || delim_len > str_len) {
ST(0) = sv_2mortal(newSVpvn("", 0));
XSRETURN(1);
}
const char *found = (const char *)util_memmem(str, str_len, delim, delim_len);
if (found) {
const char *after_delim = found + delim_len;
ST(0) = sv_2mortal(newSVpvn(after_delim, str + str_len - after_delim));
} else {
ST(0) = sv_2mortal(newSVpvn("", 0));
}
XSRETURN(1);
}
/* ============================================
Boolean/Truthiness XS fallbacks
============================================ */
static XS(xs_is_true) {
dXSARGS;
if (items != 1) croak("Usage: util::is_true($value)");
ST(0) = SvTRUE(ST(0)) ? &PL_sv_yes : &PL_sv_no;
XSRETURN(1);
}
static XS(xs_is_false) {
dXSARGS;
if (items != 1) croak("Usage: util::is_false($value)");
ST(0) = SvTRUE(ST(0)) ? &PL_sv_no : &PL_sv_yes;
XSRETURN(1);
}
static XS(xs_bool) {
dXSARGS;
if (items != 1) croak("Usage: util::bool($value)");
ST(0) = SvTRUE(ST(0)) ? &PL_sv_yes : &PL_sv_no;
XSRETURN(1);
}
/* ============================================
Extended type predicate XS fallbacks
============================================ */
static XS(xs_is_num) {
dXSARGS;
if (items != 1) croak("Usage: util::is_num($value)");
SV *sv = ST(0);
ST(0) = (SvNIOK(sv) || looks_like_number(sv)) ? &PL_sv_yes : &PL_sv_no;
XSRETURN(1);
}
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) {
dXSARGS;
if (items != 1) croak("Usage: util::is_even($value)");
SV *sv = ST(0);
if (SvIOK(sv)) {
ST(0) = (SvIVX(sv) & 1) == 0 ? &PL_sv_yes : &PL_sv_no;
} else if (SvNIOK(sv)) {
NV nv = SvNV(sv);
if (nv == (NV)(IV)nv) {
ST(0) = ((IV)nv & 1) == 0 ? &PL_sv_yes : &PL_sv_no;
} else {
ST(0) = &PL_sv_no;
}
} else if (looks_like_number(sv)) {
ST(0) = (SvIV(sv) & 1) == 0 ? &PL_sv_yes : &PL_sv_no;
} else {
ST(0) = &PL_sv_no;
}
XSRETURN(1);
}
static XS(xs_is_odd) {
dXSARGS;
if (items != 1) croak("Usage: util::is_odd($value)");
SV *sv = ST(0);
if (SvIOK(sv)) {
ST(0) = (SvIVX(sv) & 1) == 1 ? &PL_sv_yes : &PL_sv_no;
} else if (SvNIOK(sv)) {
NV nv = SvNV(sv);
if (nv == (NV)(IV)nv) {
ST(0) = ((IV)nv & 1) == 1 ? &PL_sv_yes : &PL_sv_no;
} else {
ST(0) = &PL_sv_no;
}
} else if (looks_like_number(sv)) {
ST(0) = (SvIV(sv) & 1) == 1 ? &PL_sv_yes : &PL_sv_no;
} else {
ST(0) = &PL_sv_no;
}
XSRETURN(1);
}
static XS(xs_is_between) {
dXSARGS;
if (items != 3) croak("Usage: util::is_between($value, $min, $max)");
SV *val_sv = ST(0);
SV *min_sv = ST(1);
SV *max_sv = ST(2);
if (SvNIOK(val_sv) || looks_like_number(val_sv)) {
NV val = SvNV(val_sv);
NV min = SvNV(min_sv);
NV max = SvNV(max_sv);
ST(0) = (val >= min && val <= max) ? &PL_sv_yes : &PL_sv_no;
} else {
ST(0) = &PL_sv_no;
}
XSRETURN(1);
}
/* ============================================
Collection XS fallbacks
============================================ */
static XS(xs_is_empty_array) {
dXSARGS;
if (items != 1) croak("Usage: util::is_empty_array($arrayref)");
SV *sv = ST(0);
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV) {
AV *av = (AV*)SvRV(sv);
ST(0) = AvFILL(av) < 0 ? &PL_sv_yes : &PL_sv_no;
} else {
ST(0) = &PL_sv_no;
}
XSRETURN(1);
}
static XS(xs_is_empty_hash) {
dXSARGS;
if (items != 1) croak("Usage: util::is_empty_hash($hashref)");
SV *sv = ST(0);
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV) {
HV *hv = (HV*)SvRV(sv);
ST(0) = HvKEYS(hv) == 0 ? &PL_sv_yes : &PL_sv_no;
} else {
ST(0) = &PL_sv_no;
}
XSRETURN(1);
}
static XS(xs_array_len) {
dXSARGS;
if (items != 1) croak("Usage: util::array_len($arrayref)");
SV *sv = ST(0);
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV) {
AV *av = (AV*)SvRV(sv);
ST(0) = sv_2mortal(newSViv(AvFILL(av) + 1));
} else {
ST(0) = &PL_sv_undef;
}
XSRETURN(1);
}
static XS(xs_hash_size) {
dXSARGS;
if (items != 1) croak("Usage: util::hash_size($hashref)");
SV *sv = ST(0);
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV) {
HV *hv = (HV*)SvRV(sv);
ST(0) = sv_2mortal(newSViv(HvKEYS(hv)));
xs/util/util.c view on Meta::CPAN
const char *str = SvPV(sv, len);
const char *start = str;
const char *end = str + len;
while (start < end && isSPACE(*start)) {
start++;
}
ST(0) = sv_2mortal(newSVpvn(start, end - start));
XSRETURN(1);
}
static XS(xs_rtrim) {
dXSARGS;
if (items != 1) croak("Usage: util::rtrim($string)");
SV *sv = ST(0);
if (!SvOK(sv)) {
ST(0) = &PL_sv_undef;
XSRETURN(1);
}
STRLEN len;
const char *str = SvPV(sv, len);
const char *end = str + len;
while (end > str && isSPACE(*(end - 1))) {
end--;
}
ST(0) = sv_2mortal(newSVpvn(str, end - str));
XSRETURN(1);
}
/* ============================================
Conditional XS fallbacks
============================================ */
static XS(xs_maybe) {
dXSARGS;
if (items != 2) croak("Usage: util::maybe($value, $then)");
SV *val = ST(0);
if (SvOK(val)) {
ST(0) = ST(1);
} else {
ST(0) = &PL_sv_undef;
}
XSRETURN(1);
}
/* ============================================
Numeric XS fallbacks
============================================ */
static XS(xs_sign) {
dXSARGS;
if (items != 1) croak("Usage: util::sign($number)");
SV *sv = ST(0);
if (!SvNIOK(sv) && !looks_like_number(sv)) {
ST(0) = &PL_sv_undef;
XSRETURN(1);
}
NV nv = SvNV(sv);
if (nv > 0) {
ST(0) = sv_2mortal(newSViv(1));
} else if (nv < 0) {
ST(0) = sv_2mortal(newSViv(-1));
} else {
ST(0) = sv_2mortal(newSViv(0));
}
XSRETURN(1);
}
static XS(xs_min2) {
dXSARGS;
if (items != 2) croak("Usage: util::min2($a, $b)");
NV a = SvNV(ST(0));
NV b = SvNV(ST(1));
ST(0) = a <= b ? ST(0) : ST(1);
XSRETURN(1);
}
static XS(xs_max2) {
dXSARGS;
if (items != 2) croak("Usage: util::max2($a, $b)");
NV a = SvNV(ST(0));
NV b = SvNV(ST(1));
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);
}
( run in 2.138 seconds using v1.01-cache-2.11-cpan-5a3173703d6 )