Horus
view release on metacpan or search on metacpan
#include "horus.h"
/* ── Helper: create an SV from a UUID in the given format ──────── */
static SV * horus_uuid_to_sv(pTHX_ const unsigned char *uuid, int fmt) {
int len = horus_format_length((horus_format_t)fmt);
SV *sv = newSV(len + 1);
char *buf = SvPVX(sv);
horus_format_uuid(buf, uuid, (horus_format_t)fmt);
buf[len] = '\0';
SvCUR_set(sv, len);
SvPOK_on(sv);
return sv;
}
/* ── Helper: parse namespace UUID string to binary ─────────────── */
static int horus_parse_ns(pTHX_ SV *ns_sv, unsigned char *ns_out) {
STRLEN ns_len;
const char *ns_str = SvPV(ns_sv, ns_len);
return horus_parse_uuid(ns_out, ns_str, ns_len);
}
/* â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•
* Custom ops - bypass XS subroutine dispatch overhead (5.14+)
* â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â• */
#if PERL_VERSION >= 14
/* ── Macro: ppaddr swap (for variable-arity functions) ───────────
* Quick approach that leaves entersub intact - use for optional args */
#define HORUS_CK(name) \
static OP *horus_ck_##name(pTHX_ OP *o, GV *namegv, SV *protosv) { \
PERL_UNUSED_ARG(namegv); PERL_UNUSED_ARG(protosv); \
o->op_ppaddr = pp_horus_##name; return o; \
}
/* ── Macro: proper call checker for zero-arg functions ─────────── */
#define HORUS_CK_NOARG(name) \
static OP *horus_ck_##name(pTHX_ OP *entersubop, GV *namegv, SV *protosv) { \
OP *pushop, *nextop, *newop; \
PERL_UNUSED_ARG(namegv); PERL_UNUSED_ARG(protosv); \
\
pushop = cLISTOPx(entersubop)->op_first; \
if (!pushop) return entersubop; \
\
if (pushop->op_type == OP_NULL && cLISTOPx(pushop)->op_first) { \
pushop = cLISTOPx(pushop)->op_first; \
} \
\
nextop = OpSIBLING(pushop); \
if (!nextop) return entersubop; \
if (OpSIBLING(nextop)) return entersubop; \
\
newop = newOP(OP_CUSTOM, 0); \
newop->op_ppaddr = pp_horus_##name; \
op_free(entersubop); \
return newop; \
}
/* ── Macro: proper call checker for unary functions ────────────── */
#define HORUS_CK_UNARY(name) \
static OP *horus_ck_##name(pTHX_ OP *entersubop, GV *namegv, SV *protosv) { \
OP *pushop, *argop, *nextop, *newop; \
PERL_UNUSED_ARG(namegv); PERL_UNUSED_ARG(protosv); \
\
pushop = cLISTOPx(entersubop)->op_first; \
if (!pushop) return entersubop; \
\
if (pushop->op_type == OP_NULL && cLISTOPx(pushop)->op_first) { \
pushop = cLISTOPx(pushop)->op_first; \
} \
\
argop = OpSIBLING(pushop); \
if (!argop) return entersubop; \
\
nextop = OpSIBLING(argop); \
if (!nextop) return entersubop; \
if (OpSIBLING(nextop)) return entersubop; \
\
OpMORESIB_set(pushop, nextop); \
OpLASTSIB_set(argop, NULL); \
\
newop = newUNOP(OP_NULL, 0, argop); \
newop->op_type = OP_CUSTOM; \
newop->op_ppaddr = pp_horus_##name; \
op_free(entersubop); \
return newop; \
}
/* ── Macro: proper call checker for binary functions ──────────── */
#define HORUS_CK_BINARY(name) \
static OP *horus_ck_##name(pTHX_ OP *entersubop, GV *namegv, SV *protosv) { \
OP *pushop, *arg1, *arg2, *nextop, *newop; \
PERL_UNUSED_ARG(namegv); PERL_UNUSED_ARG(protosv); \
\
pushop = cLISTOPx(entersubop)->op_first; \
if (!pushop) return entersubop; \
\
if (pushop->op_type == OP_NULL && cLISTOPx(pushop)->op_first) { \
pushop = cLISTOPx(pushop)->op_first; \
} \
\
arg1 = OpSIBLING(pushop); \
if (!arg1) return entersubop; \
\
arg2 = OpSIBLING(arg1); \
if (!arg2) return entersubop; \
\
nextop = OpSIBLING(arg2); \
if (!nextop) return entersubop; \
if (OpSIBLING(nextop)) return entersubop; \
\
OpMORESIB_set(pushop, nextop); \
OpLASTSIB_set(arg1, NULL); \
OpLASTSIB_set(arg2, NULL); \
\
newop = newBINOP(OP_NULL, 0, arg1, arg2); \
newop->op_type = OP_CUSTOM; \
newop->op_ppaddr = pp_horus_##name; \
op_free(entersubop); \
return newop; \
}
/* ── XOP descriptors (forward declarations) ──────────────────── */
/* Format constants */
static XOP horus_xop_fmt_str, horus_xop_fmt_hex, horus_xop_fmt_braces,
horus_xop_fmt_urn, horus_xop_fmt_base64, horus_xop_fmt_base32,
horus_xop_fmt_crockford, horus_xop_fmt_binary,
horus_xop_fmt_upper_str, horus_xop_fmt_upper_hex;
/* Namespace constants */
static XOP horus_xop_ns_dns, horus_xop_ns_url, horus_xop_ns_oid, horus_xop_ns_x500;
/* Generators */
static XOP horus_xop_uuid_v1, horus_xop_uuid_v2, horus_xop_uuid_v3,
horus_xop_uuid_v4, horus_xop_uuid_v5, horus_xop_uuid_v6,
horus_xop_uuid_v7, horus_xop_uuid_v8,
horus_xop_uuid_nil, horus_xop_uuid_max;
/* Batch */
static XOP horus_xop_uuid_v4_bulk;
/* Utilities */
static XOP horus_xop_uuid_parse, horus_xop_uuid_validate,
horus_xop_uuid_version, horus_xop_uuid_variant,
horus_xop_uuid_cmp, horus_xop_uuid_convert,
horus_xop_uuid_time, horus_xop_uuid_is_nil, horus_xop_uuid_is_max;
/* ── pp_* : Format constant ops (proper restructuring) ───────── */
#define PP_CONST_IV(name, val) \
static OP *pp_horus_##name(pTHX) { \
dSP; \
EXTEND(SP, 1); \
mPUSHi(val); \
RETURN; \
} \
HORUS_CK_NOARG(name)
PP_CONST_IV(fmt_str, HORUS_FMT_STR)
PP_CONST_IV(fmt_hex, HORUS_FMT_HEX)
PP_CONST_IV(fmt_braces, HORUS_FMT_BRACES)
PP_CONST_IV(fmt_urn, HORUS_FMT_URN)
PP_CONST_IV(fmt_base64, HORUS_FMT_BASE64)
PP_CONST_IV(fmt_base32, HORUS_FMT_BASE32)
PP_CONST_IV(fmt_crockford, HORUS_FMT_CROCKFORD)
PP_CONST_IV(fmt_binary, HORUS_FMT_BINARY)
PP_CONST_IV(fmt_upper_str, HORUS_FMT_UPPER_STR)
PP_CONST_IV(fmt_upper_hex, HORUS_FMT_UPPER_HEX)
/* ── pp_* : Namespace constant ops (proper restructuring) ────── */
#define PP_CONST_PV(name, str, slen) \
static OP *pp_horus_##name(pTHX) { \
dSP; \
EXTEND(SP, 1); \
mPUSHp(str, slen); \
RETURN; \
} \
HORUS_CK_NOARG(name)
PP_CONST_PV(ns_dns, "6ba7b810-9dad-11d1-80b4-00c04fd430c8", 36)
PP_CONST_PV(ns_url, "6ba7b811-9dad-11d1-80b4-00c04fd430c8", 36)
PP_CONST_PV(ns_oid, "6ba7b812-9dad-11d1-80b4-00c04fd430c8", 36)
PP_CONST_PV(ns_x500, "6ba7b814-9dad-11d1-80b4-00c04fd430c8", 36)
/* ── pp_* : Generator ops (proper restructuring) ─────────────── */
/* Macro for 0-or-1 arg generator call checker */
#define HORUS_CK_GEN01(name) \
static OP *horus_ck_##name(pTHX_ OP *entersubop, GV *namegv, SV *protosv) { \
OP *pushop, *argop, *nextop, *newop; \
int argc = 0; \
PERL_UNUSED_ARG(namegv); PERL_UNUSED_ARG(protosv); \
\
pushop = cLISTOPx(entersubop)->op_first; \
if (!pushop) return entersubop; \
\
if (pushop->op_type == OP_NULL && cLISTOPx(pushop)->op_first) { \
pushop = cLISTOPx(pushop)->op_first; \
} \
\
OP *cur = OpSIBLING(pushop); \
while (cur && OpSIBLING(cur)) { argc++; cur = OpSIBLING(cur); } \
\
if (argc == 0) { \
newop = newOP(OP_CUSTOM, 0); \
newop->op_ppaddr = pp_horus_##name##_noarg; \
} else if (argc == 1) { \
argop = OpSIBLING(pushop); \
nextop = OpSIBLING(argop); \
OpMORESIB_set(pushop, nextop); \
OpLASTSIB_set(argop, NULL); \
newop = newUNOP(OP_NULL, 0, argop); \
newop->op_type = OP_CUSTOM; \
newop->op_ppaddr = pp_horus_##name##_fmt; \
} else { \
return entersubop; \
} \
op_free(entersubop); \
return newop; \
}
/* uuid_v4 - hottest path, no state needed */
static OP *pp_horus_uuid_v4_noarg(pTHX) {
dSP;
unsigned char uuid[16];
horus_uuid_v4(uuid);
EXTEND(SP, 1);
mPUSHs(horus_uuid_to_sv(aTHX_ uuid, HORUS_FMT_STR));
RETURN;
}
static OP *pp_horus_uuid_v4_fmt(pTHX) {
dSP;
int fmt = POPi;
unsigned char uuid[16];
horus_uuid_v4(uuid);
EXTEND(SP, 1);
mPUSHs(horus_uuid_to_sv(aTHX_ uuid, fmt));
RETURN;
}
HORUS_CK_GEN01(uuid_v4)
/* uuid_v1 - time-based, needs MY_CXT */
static OP *pp_horus_uuid_v1_noarg(pTHX) {
dSP;
dMY_CXT;
unsigned char uuid[16];
return NORMAL;
}
HORUS_CK(uuid_v2)
/* uuid_v3(ns, name, fmt?) */
static OP *pp_horus_uuid_v3(pTHX) {
dSP;
I32 markix = POPMARK;
I32 ax = markix + 1;
I32 items = SP - PL_stack_base - markix - 1;
int fmt = HORUS_FMT_STR;
unsigned char ns_bytes[16], uuid[16];
STRLEN name_len;
const char *name_str;
if (items < 2) croak("uuid_v3 requires namespace and name arguments");
if (items > 2) fmt = SvIV(PL_stack_base[ax + 2]);
if (!horus_parse_ns(aTHX_ PL_stack_base[ax], ns_bytes))
croak("Horus: invalid namespace UUID");
name_str = SvPV(PL_stack_base[ax + 1], name_len);
horus_uuid_v3(uuid, ns_bytes, (const unsigned char *)name_str, name_len);
SP = PL_stack_base + markix;
XPUSHs(sv_2mortal(horus_uuid_to_sv(aTHX_ uuid, fmt)));
PUTBACK;
return NORMAL;
}
HORUS_CK(uuid_v3)
/* uuid_v5(ns, name, fmt?) */
static OP *pp_horus_uuid_v5(pTHX) {
dSP;
I32 markix = POPMARK;
I32 ax = markix + 1;
I32 items = SP - PL_stack_base - markix - 1;
int fmt = HORUS_FMT_STR;
unsigned char ns_bytes[16], uuid[16];
STRLEN name_len;
const char *name_str;
if (items < 2) croak("uuid_v5 requires namespace and name arguments");
if (items > 2) fmt = SvIV(PL_stack_base[ax + 2]);
if (!horus_parse_ns(aTHX_ PL_stack_base[ax], ns_bytes))
croak("Horus: invalid namespace UUID");
name_str = SvPV(PL_stack_base[ax + 1], name_len);
horus_uuid_v5(uuid, ns_bytes, (const unsigned char *)name_str, name_len);
SP = PL_stack_base + markix;
XPUSHs(sv_2mortal(horus_uuid_to_sv(aTHX_ uuid, fmt)));
PUTBACK;
return NORMAL;
}
HORUS_CK(uuid_v5)
/* uuid_v8(custom_data, fmt?) - 1 or 2 args */
/* Macro for 1-or-2 arg call checker */
#define HORUS_CK_GEN12(name, pp1, pp2) \
static OP *horus_ck_##name(pTHX_ OP *entersubop, GV *namegv, SV *protosv) { \
OP *pushop, *arg1, *arg2, *nextop, *newop; \
int argc = 0; \
PERL_UNUSED_ARG(namegv); PERL_UNUSED_ARG(protosv); \
\
pushop = cLISTOPx(entersubop)->op_first; \
if (!pushop) return entersubop; \
\
if (pushop->op_type == OP_NULL && cLISTOPx(pushop)->op_first) { \
pushop = cLISTOPx(pushop)->op_first; \
} \
\
OP *cur = OpSIBLING(pushop); \
while (cur && OpSIBLING(cur)) { argc++; cur = OpSIBLING(cur); } \
\
if (argc == 1) { \
arg1 = OpSIBLING(pushop); \
nextop = OpSIBLING(arg1); \
OpMORESIB_set(pushop, nextop); \
OpLASTSIB_set(arg1, NULL); \
newop = newUNOP(OP_NULL, 0, arg1); \
newop->op_type = OP_CUSTOM; \
newop->op_ppaddr = pp1; \
} else if (argc == 2) { \
arg1 = OpSIBLING(pushop); \
arg2 = OpSIBLING(arg1); \
nextop = OpSIBLING(arg2); \
OpMORESIB_set(pushop, nextop); \
OpLASTSIB_set(arg1, NULL); \
OpLASTSIB_set(arg2, NULL); \
newop = newBINOP(OP_NULL, 0, arg1, arg2); \
newop->op_type = OP_CUSTOM; \
newop->op_ppaddr = pp2; \
} else { \
return entersubop; \
} \
op_free(entersubop); \
return newop; \
}
static OP *pp_horus_uuid_v8_data(pTHX) {
dSP;
SV *sv_data = TOPs;
unsigned char uuid[16];
STRLEN data_len;
const char *data_str = SvPV(sv_data, data_len);
if (data_len < 16) croak("Horus: uuid_v8 requires 16 bytes of custom data");
horus_uuid_v8(uuid, (const unsigned char *)data_str);
SETs(sv_2mortal(horus_uuid_to_sv(aTHX_ uuid, HORUS_FMT_STR)));
RETURN;
}
static OP *pp_horus_uuid_v8_data_fmt(pTHX) {
dSP;
int fmt = POPi;
SV *sv_data = TOPs;
unsigned char uuid[16];
int fmt = SvIV(sv_fmt);
if (horus_parse_uuid(uuid, in_str, in_len) != HORUS_PARSE_OK)
croak("Horus: cannot parse UUID string");
SETs(sv_2mortal(horus_uuid_to_sv(aTHX_ uuid, fmt)));
RETURN;
}
HORUS_CK_BINARY(uuid_convert)
/* uuid_time(input) -> NV epoch seconds */
static OP *pp_horus_uuid_time(pTHX) {
dSP;
SV *input = TOPs;
unsigned char uuid[16];
STRLEN in_len;
const char *in_str = SvPV(input, in_len);
if (horus_parse_uuid(uuid, in_str, in_len) != HORUS_PARSE_OK)
croak("Horus: cannot parse UUID string");
SETs(sv_2mortal(newSVnv(horus_uuid_extract_time(uuid))));
RETURN;
}
HORUS_CK_UNARY(uuid_time)
/* uuid_is_nil(input) -> 1/0 */
static OP *pp_horus_uuid_is_nil(pTHX) {
dSP;
SV *input = TOPs;
unsigned char uuid[16];
STRLEN in_len;
const char *in_str = SvPV(input, in_len);
int result = 0;
if (horus_parse_uuid(uuid, in_str, in_len) == HORUS_PARSE_OK)
result = horus_uuid_is_nil_bin(uuid);
SETs(sv_2mortal(newSViv(result)));
RETURN;
}
HORUS_CK_UNARY(uuid_is_nil)
/* uuid_is_max(input) -> 1/0 */
static OP *pp_horus_uuid_is_max(pTHX) {
dSP;
SV *input = TOPs;
unsigned char uuid[16];
STRLEN in_len;
const char *in_str = SvPV(input, in_len);
int result = 0;
if (horus_parse_uuid(uuid, in_str, in_len) == HORUS_PARSE_OK)
result = horus_uuid_is_max_bin(uuid);
SETs(sv_2mortal(newSViv(result)));
RETURN;
}
HORUS_CK_UNARY(uuid_is_max)
/* ── Macro: XOP + call checker registration ──────────────────── */
#define HORUS_REG_XOP(c_name, desc) \
XopENTRY_set(&horus_xop_##c_name, xop_name, "horus_" #c_name); \
XopENTRY_set(&horus_xop_##c_name, xop_desc, desc); \
Perl_custom_op_register(aTHX_ pp_horus_##c_name, &horus_xop_##c_name);
/* Register both variants of a 0-or-1 arg function under same XOP */
#define HORUS_REG_XOP_GEN01(c_name, desc) \
XopENTRY_set(&horus_xop_##c_name, xop_name, "horus_" #c_name); \
XopENTRY_set(&horus_xop_##c_name, xop_desc, desc); \
Perl_custom_op_register(aTHX_ pp_horus_##c_name##_noarg, &horus_xop_##c_name); \
Perl_custom_op_register(aTHX_ pp_horus_##c_name##_fmt, &horus_xop_##c_name);
/* Register both variants of a 1-or-2 arg function */
#define HORUS_REG_XOP_GEN12(c_name, pp1, pp2, desc) \
XopENTRY_set(&horus_xop_##c_name, xop_name, "horus_" #c_name); \
XopENTRY_set(&horus_xop_##c_name, xop_desc, desc); \
Perl_custom_op_register(aTHX_ pp1, &horus_xop_##c_name); \
Perl_custom_op_register(aTHX_ pp2, &horus_xop_##c_name);
#define HORUS_REG_CK(perl_name, c_name) { \
CV *cv = get_cv("Horus::" perl_name, 0); \
if (cv) cv_set_call_checker(cv, horus_ck_##c_name, (SV *)cv); \
}
static void horus_register_custom_ops(pTHX) {
/* Register XOP descriptors */
HORUS_REG_XOP(fmt_str, "UUID format: hyphenated")
HORUS_REG_XOP(fmt_hex, "UUID format: hex")
HORUS_REG_XOP(fmt_braces, "UUID format: braces")
HORUS_REG_XOP(fmt_urn, "UUID format: URN")
HORUS_REG_XOP(fmt_base64, "UUID format: base64")
HORUS_REG_XOP(fmt_base32, "UUID format: base32")
HORUS_REG_XOP(fmt_crockford, "UUID format: Crockford")
HORUS_REG_XOP(fmt_binary, "UUID format: binary")
HORUS_REG_XOP(fmt_upper_str, "UUID format: upper hyphenated")
HORUS_REG_XOP(fmt_upper_hex, "UUID format: upper hex")
HORUS_REG_XOP(ns_dns, "UUID namespace: DNS")
HORUS_REG_XOP(ns_url, "UUID namespace: URL")
HORUS_REG_XOP(ns_oid, "UUID namespace: OID")
HORUS_REG_XOP(ns_x500, "UUID namespace: X500")
/* Generators with 0-or-1 arg (proper op tree restructuring) */
HORUS_REG_XOP_GEN01(uuid_v1, "generate UUID v1")
HORUS_REG_XOP_GEN01(uuid_v4, "generate UUID v4")
HORUS_REG_XOP_GEN01(uuid_v6, "generate UUID v6")
HORUS_REG_XOP_GEN01(uuid_v7, "generate UUID v7")
HORUS_REG_XOP_GEN01(uuid_nil, "generate NIL UUID")
HORUS_REG_XOP_GEN01(uuid_max, "generate MAX UUID")
/* Generators with 1-or-2 args */
HORUS_REG_XOP_GEN12(uuid_v8, pp_horus_uuid_v8_data, pp_horus_uuid_v8_data_fmt, "generate UUID v8")
HORUS_REG_XOP_GEN12(uuid_v4_bulk, pp_horus_uuid_v4_bulk_count, pp_horus_uuid_v4_bulk_count_fmt, "generate UUID v4 batch")
/* Complex generators (ppaddr swap - too many optional arg combinations) */
HORUS_REG_XOP(uuid_v2, "generate UUID v2")
HORUS_REG_XOP(uuid_v3, "generate UUID v3")
HORUS_REG_XOP(uuid_v5, "generate UUID v5")
( run in 1.463 second using v1.01-cache-2.11-cpan-2398b32b56e )