Ancient
view release on metacpan or search on metacpan
xs/object/object.c view on Meta::CPAN
IV iv = SvIV(val);
return iv == 0 || iv == 1;
}
return SvTRUE(val) || !SvOK(val) || (SvPOK(val) && SvCUR(val) == 0);
case TYPE_ARRAYREF:
return SvROK(val) && SvTYPE(SvRV(val)) == SVt_PVAV;
case TYPE_HASHREF:
return SvROK(val) && SvTYPE(SvRV(val)) == SVt_PVHV;
case TYPE_CODEREF:
return SvROK(val) && SvTYPE(SvRV(val)) == SVt_PVCV;
case TYPE_OBJECT:
return SvROK(val) && sv_isobject(val);
default:
return true; /* No check or unknown */
}
}
/* Get type name for error messages */
static const char* type_id_to_name(BuiltinTypeID type_id) {
switch (type_id) {
case TYPE_ANY: return "Any";
case TYPE_DEFINED: return "Defined";
case TYPE_STR: return "Str";
case TYPE_INT: return "Int";
case TYPE_NUM: return "Num";
case TYPE_BOOL: return "Bool";
case TYPE_ARRAYREF: return "ArrayRef";
case TYPE_HASHREF: return "HashRef";
case TYPE_CODEREF: return "CodeRef";
case TYPE_OBJECT: return "Object";
case TYPE_CUSTOM: return "custom";
default: return "unknown";
}
}
/* Check a value against a slot's type constraint (handles both C and Perl callbacks) */
static bool check_slot_type(pTHX_ SV *val, SlotSpec *spec) {
if (!spec || !spec->has_type) return true;
if (spec->type_id != TYPE_CUSTOM) {
return check_builtin_type(aTHX_ val, spec->type_id);
}
if (!spec->registered) return true;
/* Try C function first (fast path - ~5 cycles) */
if (spec->registered->check) {
return spec->registered->check(aTHX_ val);
}
/* Fall back to Perl callback (~100 cycles) */
if (spec->registered->perl_check) {
dSP;
int count;
bool result = false;
SV *result_sv;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(val);
PUTBACK;
count = call_sv(spec->registered->perl_check, G_SCALAR);
SPAGAIN;
if (count > 0) {
result_sv = POPs;
result = SvTRUE(result_sv);
}
PUTBACK;
FREETMPS;
LEAVE;
return result;
}
return true;
}
/* ============================================
Slot spec parser: "name:Type:default(val)"
============================================ */
static SlotSpec* parse_slot_spec(pTHX_ const char *spec_str, STRLEN len) {
SlotSpec *spec;
const char *p = spec_str;
const char *end = spec_str + len;
const char *name_start, *name_end;
STRLEN name_len;
Newxz(spec, 1, SlotSpec);
/* Parse property name (before first ':') */
name_start = p;
while (p < end && *p != ':') p++;
name_end = p;
name_len = name_end - name_start;
Newx(spec->name, name_len + 1, char);
Copy(name_start, spec->name, name_len, char);
spec->name[name_len] = '\0';
/* Parse modifiers after name */
while (p < end) {
const char *mod_start;
const char *arg_start;
const char *arg_end;
STRLEN mod_len;
STRLEN arg_len;
int paren_depth;
if (*p == ':') p++; /* Skip separator */
if (p >= end) break;
mod_start = p;
/* Check for function-style modifiers: default(...), trigger(...) */
while (p < end && *p != ':' && *p != '(') p++;
mod_len = p - mod_start;
if (p < end && *p == '(') {
/* Function-style: default(value) or trigger(&callback) */
p++;
arg_start = p;
paren_depth = 1;
while (p < end && paren_depth > 0) {
if (*p == '(') paren_depth++;
else if (*p == ')') paren_depth--;
p++;
}
xs/object/object.c view on Meta::CPAN
IV idx = i + 1;
SV *val_sv = MARK[i + 1];
/* Type check on construction if slot has type */
if (meta->slots && meta->slots[idx] && meta->slots[idx]->has_type) {
SlotSpec *spec = meta->slots[idx];
if (spec->type_id != TYPE_CUSTOM) {
if (!check_builtin_type(aTHX_ val_sv, spec->type_id)) {
croak("Type constraint failed for '%s' in new(): expected %s",
spec->name, type_id_to_name(spec->type_id));
}
} else if (spec->registered && spec->registered->check) {
if (!spec->registered->check(aTHX_ val_sv)) {
croak("Type constraint failed for '%s' in new(): expected %s",
spec->name, spec->registered->name);
}
}
}
av_store(obj_av, idx, newSVsv(val_sv));
}
}
/* Fill unset slots with defaults or undef, check required */
for (i = 1; i < meta->slot_count; i++) {
SV **existing = av_fetch(obj_av, i, 0);
if (!existing || !SvOK(*existing)) {
SlotSpec *spec = (meta->slots) ? meta->slots[i] : NULL;
if (spec && spec->is_required) {
croak("Required slot '%s' not provided in new()", spec->name);
}
if (spec && spec->has_default && spec->default_sv) {
/* Clone the default value (in case it's a reference) */
if (SvROK(spec->default_sv)) {
/* For refs, create fresh copy each time */
if (SvTYPE(SvRV(spec->default_sv)) == SVt_PVAV) {
av_store(obj_av, i, newRV_noinc((SV*)newAV()));
} else if (SvTYPE(SvRV(spec->default_sv)) == SVt_PVHV) {
av_store(obj_av, i, newRV_noinc((SV*)newHV()));
} else {
av_store(obj_av, i, newSVsv(spec->default_sv));
}
} else {
av_store(obj_av, i, newSVsv(spec->default_sv));
}
} else {
av_store(obj_av, i, newSV(0));
}
}
}
/* Create blessed reference */
obj_sv = newRV_noinc((SV*)obj_av);
sv_bless(obj_sv, meta->stash);
/* Magic for lock/freeze is added lazily when first needed */
SP = MARK;
XPUSHs(obj_sv);
PUTBACK;
return NORMAL;
}
/* ============================================
Prototype chain resolution
============================================ */
#define MAX_PROTOTYPE_DEPTH 100
/* Resolve a property through the full prototype chain.
* Returns the value if found, or &PL_sv_undef if not.
* Detects circular references using depth limit and pointer tracking.
*/
static SV* resolve_property_chain(pTHX_ AV *av, IV idx) {
int depth = 0;
AV *visited[MAX_PROTOTYPE_DEPTH]; /* Simple stack-based cycle detection */
int i;
while (av && depth < MAX_PROTOTYPE_DEPTH) {
SV **svp;
/* Check for circular reference */
for (i = 0; i < depth; i++) {
if (visited[i] == av) {
warn("Circular prototype reference detected");
return &PL_sv_undef;
}
}
visited[depth] = av;
/* Try to fetch the property at this level */
svp = av_fetch(av, idx, 0);
if (svp && SvOK(*svp)) {
return *svp;
}
/* Follow prototype chain (slot 0) */
svp = av_fetch(av, 0, 0);
if (!svp || !SvROK(*svp) || SvTYPE(SvRV(*svp)) != SVt_PVAV) {
break;
}
av = (AV*)SvRV(*svp);
depth++;
}
if (depth >= MAX_PROTOTYPE_DEPTH) {
warn("Prototype chain too deep (max %d levels)", MAX_PROTOTYPE_DEPTH);
}
return &PL_sv_undef;
}
/* ============================================
Custom OP: property accessor (get)
============================================ */
static OP* pp_object_get(pTHX) {
dSP;
SV *obj = TOPs;
IV idx = PL_op->op_targ;
xs/object/object.c view on Meta::CPAN
} SlotOpData;
/* Helper struct for function-style accessors (cross-class support) */
struct FuncAccessorData_s {
IV slot_idx;
ClassMeta *expected_class; /* Class this accessor expects */
IV registry_id; /* ID in g_func_accessor_registry */
};
/* Register a FuncAccessorData and return its ID */
static IV register_func_accessor_data(pTHX_ FuncAccessorData *data) {
if (g_func_accessor_count >= g_func_accessor_capacity) {
IV new_capacity = g_func_accessor_capacity ? g_func_accessor_capacity * 2 : 64;
Renew(g_func_accessor_registry, new_capacity, FuncAccessorData*);
g_func_accessor_capacity = new_capacity;
}
data->registry_id = g_func_accessor_count;
g_func_accessor_registry[g_func_accessor_count] = data;
return g_func_accessor_count++;
}
/* Look up FuncAccessorData by ID */
static FuncAccessorData* get_func_accessor_data(IV id) {
if (id < 0 || id >= g_func_accessor_count) return NULL;
return g_func_accessor_registry[id];
}
static OP* pp_object_set_typed(pTHX) {
dSP;
SV *val = POPs;
SV *obj = TOPs;
SlotOpData *data = INT2PTR(SlotOpData*, PL_op->op_targ);
IV idx = data->slot_idx;
ClassMeta *meta = data->meta;
SlotSpec *spec = meta->slots[idx];
AV *av;
MAGIC *mg;
if (!SvROK(obj) || SvTYPE(SvRV(obj)) != SVt_PVAV) {
croak("Not an object");
}
av = (AV*)SvRV(obj);
/* Check frozen/locked */
mg = get_object_magic(aTHX_ obj);
if (mg && (mg->mg_private & OBJ_FLAG_FROZEN)) {
croak("Cannot modify frozen object");
}
/* Readonly check */
if (spec->is_readonly) {
croak("Cannot modify readonly slot '%s'", spec->name);
}
/* Coercion (if callback exists) */
if (spec->has_coerce && spec->coerce_cb) {
dSP;
PUSHMARK(SP);
XPUSHs(val);
PUTBACK;
call_sv(spec->coerce_cb, G_SCALAR);
SPAGAIN;
val = POPs;
PUTBACK;
}
/* External XS type coercion (C function - fast path) */
if (spec->type_id == TYPE_CUSTOM && spec->registered && spec->registered->coerce) {
val = spec->registered->coerce(aTHX_ val);
}
/* Type check using helper (handles both C and Perl callbacks) */
if (spec->has_type) {
if (!check_slot_type(aTHX_ val, spec)) {
const char *type_name = (spec->type_id == TYPE_CUSTOM && spec->registered)
? spec->registered->name
: type_id_to_name(spec->type_id);
croak("Type constraint failed for '%s': expected %s",
spec->name, type_name);
}
}
/* Trigger callback (old, new) */
if (spec->has_trigger && spec->trigger_cb) {
SV *oldval = *av_fetch(av, idx, 0);
dSP;
PUSHMARK(SP);
XPUSHs(obj);
XPUSHs(oldval);
XPUSHs(val);
PUTBACK;
call_sv(spec->trigger_cb, G_DISCARD);
}
av_store(av, idx, newSVsv(val));
SETs(val);
RETURN;
}
/* ============================================
Call checker for accessor
============================================ */
static OP* accessor_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
IV idx = SvIV(ckobj);
OP *pushop, *cvop, *selfop, *argop;
OP *newop;
PERL_UNUSED_ARG(namegv);
pushop = cUNOPx(entersubop)->op_first;
if (!OpHAS_SIBLING(pushop)) {
pushop = cUNOPx(pushop)->op_first;
}
selfop = OpSIBLING(pushop);
cvop = selfop;
argop = selfop;
while (OpHAS_SIBLING(cvop)) {
argop = cvop;
cvop = OpSIBLING(cvop);
}
/* Check if there's an argument after self (setter call) */
if (argop != selfop) {
/* Setter: $obj->name($value) */
OP *valop = OpSIBLING(selfop);
/* Detach self and val */
OpMORESIB_set(pushop, cvop);
OpLASTSIB_set(valop, NULL);
OpLASTSIB_set(selfop, NULL);
/* Create binop with self and val */
newop = newBINOP(OP_CUSTOM, 0, selfop, valop);
newop->op_ppaddr = pp_object_set;
newop->op_targ = idx;
op_free(entersubop);
return newop;
} else {
/* Getter: $obj->name */
OpMORESIB_set(pushop, cvop);
OpLASTSIB_set(selfop, NULL);
newop = newUNOP(OP_CUSTOM, 0, selfop);
newop->op_ppaddr = pp_object_get;
newop->op_targ = idx;
op_free(entersubop);
return newop;
xs/object/object.c view on Meta::CPAN
/* XS fallback accessor with type checking */
static XS(xs_accessor_typed_fallback) {
dXSARGS;
SlotOpData *data = INT2PTR(SlotOpData*, CvXSUBANY(cv).any_iv);
IV idx = data->slot_idx;
ClassMeta *meta = data->meta;
SlotSpec *spec = meta->slots[idx];
SV *self = ST(0);
AV *av;
if (!SvROK(self) || SvTYPE(SvRV(self)) != SVt_PVAV) {
croak("Not an object");
}
av = (AV*)SvRV(self);
if (items > 1) {
/* Setter with type check */
SV *val = ST(1);
MAGIC *mg = get_object_magic(aTHX_ self);
if (mg && (mg->mg_private & OBJ_FLAG_FROZEN)) {
croak("Cannot modify frozen object");
}
if (spec->is_readonly) {
croak("Cannot modify readonly slot '%s'", spec->name);
}
/* Type check */
if (spec->has_type) {
if (!check_slot_type(aTHX_ val, spec)) {
const char *type_name = (spec->type_id == TYPE_CUSTOM && spec->registered)
? spec->registered->name
: type_id_to_name(spec->type_id);
croak("Type constraint failed for '%s': expected %s",
spec->name, type_name);
}
}
av_store(av, idx, newSVsv(val));
ST(0) = val;
XSRETURN(1);
} else {
/* Getter - use prototype chain resolution, handle lazy */
SV *result = resolve_property_chain(aTHX_ av, idx);
/* Lazy initialization: if undef and is_lazy, build/default on first access */
if (spec->is_lazy && !SvOK(result)) {
SV *built_val = NULL;
if (spec->has_builder && spec->builder_name) {
/* Call builder method */
dSP;
const char *builder = SvPV_nolen(spec->builder_name);
int count;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(self);
PUTBACK;
count = call_method(builder, G_SCALAR);
SPAGAIN;
if (count > 0) {
/* Copy the value BEFORE FREETMPS to avoid freed scalar issue */
built_val = newSVsv(POPs);
} else {
built_val = newSV(0); /* undef */
}
PUTBACK;
FREETMPS;
LEAVE;
} else if (spec->has_default && spec->default_sv) {
/* Use default value for lazy default */
if (SvROK(spec->default_sv)) {
/* Clone reference types (arrays, hashes) */
SV *inner = SvRV(spec->default_sv);
if (SvTYPE(inner) == SVt_PVAV) {
built_val = newRV_noinc((SV*)newAV());
} else if (SvTYPE(inner) == SVt_PVHV) {
built_val = newRV_noinc((SV*)newHV());
} else {
built_val = newSVsv(spec->default_sv);
}
} else {
built_val = newSVsv(spec->default_sv);
}
}
if (built_val) {
/* Type check the built value */
if (spec->has_type && SvOK(built_val)) {
if (!check_slot_type(aTHX_ built_val, spec)) {
const char *type_name = (spec->type_id == TYPE_CUSTOM && spec->registered)
? spec->registered->name
: type_id_to_name(spec->type_id);
croak("Type constraint failed for lazy '%s': expected %s",
spec->name, type_name);
}
}
/* Store the built value - built_val already has correct refcount from newSVsv */
av_store(av, idx, built_val);
result = built_val;
}
}
ST(0) = result;
XSRETURN(1);
}
}
/* Call checker for typed accessor */
static OP* accessor_typed_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
SlotOpData *data = INT2PTR(SlotOpData*, SvIV(ckobj));
IV idx = data->slot_idx;
OP *pushop, *cvop, *selfop, *argop;
OP *newop;
PERL_UNUSED_ARG(namegv);
pushop = cUNOPx(entersubop)->op_first;
if (!OpHAS_SIBLING(pushop)) {
pushop = cUNOPx(pushop)->op_first;
}
selfop = OpSIBLING(pushop);
cvop = selfop;
argop = selfop;
while (OpHAS_SIBLING(cvop)) {
xs/object/object.c view on Meta::CPAN
AV *av;
SV **svp;
PERL_UNUSED_ARG(items);
if (!SvROK(self) || SvTYPE(SvRV(self)) != SVt_PVAV) {
croak("Not an object");
}
av = (AV*)SvRV(self);
/* Check if slot has a defined value */
svp = av_fetch(av, idx, 0);
if (svp && SvOK(*svp)) {
ST(0) = &PL_sv_yes;
} else {
ST(0) = &PL_sv_no;
}
XSRETURN(1);
}
/* Install predicate method (has_X) */
static void install_predicate(pTHX_ const char *class_name, const char *prop_name, IV idx, ClassMeta *meta) {
char full_name[256];
CV *cv;
SlotOpData *data;
snprintf(full_name, sizeof(full_name), "%s::has_%s", class_name, prop_name);
/* Check if method already exists */
cv = get_cvn_flags(full_name, strlen(full_name), 0);
if (cv) {
return;
}
Newx(data, 1, SlotOpData);
data->slot_idx = idx;
data->meta = meta;
cv = newXS(full_name, xs_predicate_fallback, __FILE__);
CvXSUBANY(cv).any_iv = PTR2IV(data);
}
/* ============================================
DEMOLISH Support (zero overhead if not used)
============================================ */
/* XS DESTROY wrapper that calls DEMOLISH */
static XS(xs_destroy_wrapper) {
dXSARGS;
ClassMeta *meta = INT2PTR(ClassMeta*, CvXSUBANY(cv).any_iv);
SV *self = ST(0);
PERL_UNUSED_VAR(items);
if (meta && meta->demolish_cv) {
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(self);
PUTBACK;
call_sv((SV*)meta->demolish_cv, G_DISCARD | G_EVAL);
SPAGAIN;
/* Ignore errors in DEMOLISH - don't die during destruction */
if (SvTRUE(ERRSV)) {
warn("Error in DEMOLISH: %s", SvPV_nolen(ERRSV));
}
FREETMPS;
LEAVE;
}
XSRETURN_EMPTY;
}
/* Install DESTROY wrapper - only called if DEMOLISH exists */
static void install_destroy_wrapper(pTHX_ const char *class_name, ClassMeta *meta) {
char full_name[256];
CV *cv;
snprintf(full_name, sizeof(full_name), "%s::DESTROY", class_name);
/* Check if DESTROY already exists - don't override user's DESTROY */
cv = get_cvn_flags(full_name, strlen(full_name), 0);
if (cv) {
return; /* User has their own DESTROY, don't interfere */
}
cv = newXS(full_name, xs_destroy_wrapper, __FILE__);
CvXSUBANY(cv).any_iv = PTR2IV(meta);
}
/* ============================================
Role Support (zero overhead if not used)
============================================ */
static RoleMeta* get_role_meta(pTHX_ const char *role_name, STRLEN len) {
SV **svp;
if (!g_role_registry) return NULL;
svp = hv_fetch(g_role_registry, role_name, len, 0);
if (svp && SvIOK(*svp)) {
return INT2PTR(RoleMeta*, SvIV(*svp));
}
return NULL;
}
static void register_role_meta(pTHX_ const char *role_name, STRLEN len, RoleMeta *meta) {
if (!g_role_registry) {
g_role_registry = newHV();
}
hv_store(g_role_registry, role_name, len, newSViv(PTR2IV(meta)), 0);
}
/* Copy a method from role stash to class stash */
static void copy_method(pTHX_ HV *from_stash, HV *to_stash, const char *method_name) {
GV *from_gv;
CV *cv;
char full_name[512];
GV *to_gv;
from_gv = gv_fetchmeth(from_stash, method_name, strlen(method_name), 0);
if (!from_gv || !(cv = GvCV(from_gv))) {
xs/object/object.c view on Meta::CPAN
/* Get or create modified method entry */
static ModifiedMethod* get_or_create_modified_method(pTHX_ ClassMeta *meta, const char *method_name) {
SV **svp;
ModifiedMethod *mod;
STRLEN name_len = strlen(method_name);
if (!meta->modified_methods) {
meta->modified_methods = newHV();
}
svp = hv_fetch(meta->modified_methods, method_name, name_len, 0);
if (svp && SvIOK(*svp)) {
return INT2PTR(ModifiedMethod*, SvIV(*svp));
}
/* Create new modified method entry */
Newxz(mod, 1, ModifiedMethod);
/* Get the original CV */
{
GV *gv = gv_fetchmeth(meta->stash, method_name, name_len, 0);
if (gv && GvCV(gv)) {
mod->original_cv = GvCV(gv);
SvREFCNT_inc((SV*)mod->original_cv);
}
}
hv_store(meta->modified_methods, method_name, name_len, newSViv(PTR2IV(mod)), 0);
return mod;
}
/* XS wrapper for modified methods */
static XS(xs_modified_method_wrapper) {
dXSARGS;
ModifiedMethod *mod = INT2PTR(ModifiedMethod*, CvXSUBANY(cv).any_iv);
MethodModifier *m;
int count = 0;
I32 gimme = GIMME_V;
AV *saved_args;
AV *saved_results;
int i;
/* Save original arguments for before/after chains */
saved_args = newAV();
sv_2mortal((SV*)saved_args);
for (i = 0; i < items; i++) {
av_push(saved_args, SvREFCNT_inc(ST(i)));
}
/* Call before chain (in stack order - most recent first) */
for (m = mod->before_chain; m; m = m->next) {
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
for (i = 0; i <= av_len(saved_args); i++) {
SV **svp = av_fetch(saved_args, i, 0);
XPUSHs(svp ? *svp : &PL_sv_undef);
}
PUTBACK;
call_sv(m->callback, G_DISCARD);
FREETMPS;
LEAVE;
}
/* Save results from original/around call */
saved_results = newAV();
sv_2mortal((SV*)saved_results);
/* Call around chain (or original if no around) */
if (mod->around_chain) {
/* For around, we pass ($orig, $self, @args) */
m = mod->around_chain;
{
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newRV_inc((SV*)mod->original_cv)));
for (i = 0; i <= av_len(saved_args); i++) {
SV **svp = av_fetch(saved_args, i, 0);
XPUSHs(svp ? *svp : &PL_sv_undef);
}
PUTBACK;
count = call_sv(m->callback, gimme == G_ARRAY ? G_LIST : G_SCALAR);
SPAGAIN;
/* Save results before LEAVE destroys them - they're on stack in reverse */
for (i = 0; i < count; i++) {
av_push(saved_results, newSVsv(POPs));
}
FREETMPS;
LEAVE;
}
} else if (mod->original_cv) {
/* Call original method */
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
for (i = 0; i <= av_len(saved_args); i++) {
SV **svp = av_fetch(saved_args, i, 0);
XPUSHs(svp ? *svp : &PL_sv_undef);
}
PUTBACK;
count = call_sv((SV*)mod->original_cv, gimme == G_ARRAY ? G_LIST : G_SCALAR);
SPAGAIN;
/* Save results before LEAVE destroys them */
for (i = 0; i < count; i++) {
av_push(saved_results, newSVsv(POPs));
}
FREETMPS;
LEAVE;
}
/* Call after chain (in order of registration) */
for (m = mod->after_chain; m; m = m->next) {
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
for (i = 0; i <= av_len(saved_args); i++) {
SV **svp = av_fetch(saved_args, i, 0);
XPUSHs(svp ? *svp : &PL_sv_undef);
}
PUTBACK;
call_sv(m->callback, G_DISCARD);
FREETMPS;
LEAVE;
}
/* Put saved results back on stack (they were saved in reverse order) */
{
count = av_len(saved_results) + 1;
for (i = count - 1; i >= 0; i--) {
SV **svp = av_fetch(saved_results, i, 0);
/* Use sv_mortalcopy to put a mortal copy on stack */
ST(count - 1 - i) = sv_mortalcopy(svp ? *svp : &PL_sv_undef);
}
}
XSRETURN(count);
}
/* Install the wrapper if not already done */
static void install_modifier_wrapper(pTHX_ ClassMeta *meta, const char *method_name, ModifiedMethod *mod) {
char full_name[256];
CV *existing_cv;
snprintf(full_name, sizeof(full_name), "%s::%s", meta->class_name, method_name);
existing_cv = get_cvn_flags(full_name, strlen(full_name), 0);
/* Only install wrapper once - check if it's already our wrapper */
if (existing_cv && CvXSUB(existing_cv) == xs_modified_method_wrapper) {
return; /* Already wrapped */
}
/* Install wrapper without "Subroutine redefined" warning */
{
GV *gv = gv_fetchpv(full_name, GV_ADD, SVt_PVCV);
CV *cv = newXS_flags(NULL, xs_modified_method_wrapper, __FILE__, NULL, 0);
CvXSUBANY(cv).any_iv = PTR2IV(mod);
/* Silently replace the CV in the GV */
if (GvCV(gv)) {
SvREFCNT_dec(GvCV(gv));
}
GvCV_set(gv, cv);
}
}
/* Add a modifier to a method */
static void add_modifier(pTHX_ ClassMeta *meta, const char *method_name, SV *callback, int type) {
ModifiedMethod *mod;
MethodModifier *new_mod;
mod = get_or_create_modified_method(aTHX_ meta, method_name);
Newx(new_mod, 1, MethodModifier);
new_mod->callback = newSVsv(callback);
new_mod->next = NULL;
/* Add to appropriate chain */
switch (type) {
case 0: /* before */
new_mod->next = mod->before_chain;
xs/object/object.c view on Meta::CPAN
av_push(result, newSVpvs("Any"));
av_push(result, newSVpvs("Defined"));
av_push(result, newSVpvs("Str"));
av_push(result, newSVpvs("Int"));
av_push(result, newSVpvs("Num"));
av_push(result, newSVpvs("Bool"));
av_push(result, newSVpvs("ArrayRef"));
av_push(result, newSVpvs("HashRef"));
av_push(result, newSVpvs("CodeRef"));
av_push(result, newSVpvs("Object"));
/* Add registered types */
if (g_type_registry) {
HE *he;
hv_iterinit(g_type_registry);
while ((he = hv_iternext(g_type_registry))) {
av_push(result, newSVsv(hv_iterkeysv(he)));
}
}
ST(0) = newRV_noinc((SV*)result);
sv_2mortal(ST(0));
XSRETURN(1);
}
/* ============================================
Singleton support
============================================ */
/* XS implementation of instance() method for singletons */
static XS(xs_singleton_instance) {
dXSARGS;
ClassMeta *meta = INT2PTR(ClassMeta*, CvXSUBANY(cv).any_iv);
PERL_UNUSED_ARG(items);
if (!meta) {
croak("Singleton metadata not found");
}
/* Return cached instance if it exists */
if (meta->singleton_instance && SvOK(meta->singleton_instance)) {
ST(0) = meta->singleton_instance;
XSRETURN(1);
}
/* Create new instance */
{
dSP;
int count;
SV *obj;
GV *build_gv;
char full_build[256];
ENTER;
SAVETMPS;
/* Call ClassName->new() */
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv(meta->class_name, 0)));
PUTBACK;
count = call_method("new", G_SCALAR);
SPAGAIN;
if (count != 1) {
croak("Singleton new() did not return object");
}
obj = POPs;
SvREFCNT_inc(obj); /* Keep the object alive */
PUTBACK;
/* Check for BUILD method and call it */
snprintf(full_build, sizeof(full_build), "%s::BUILD", meta->class_name);
build_gv = gv_fetchpv(full_build, 0, SVt_PVCV);
if (build_gv && GvCV(build_gv)) {
PUSHMARK(SP);
XPUSHs(obj);
PUTBACK;
call_method("BUILD", G_VOID | G_DISCARD);
}
/* Cache the instance */
meta->singleton_instance = obj;
FREETMPS;
LEAVE;
ST(0) = obj;
XSRETURN(1);
}
}
/* ============================================
Role API
============================================ */
/* object::role("RoleName", @slot_specs) - define a role */
static XS(xs_role) {
dXSARGS;
STRLEN role_len;
const char *role_pv;
RoleMeta *meta;
IV i;
if (items < 1) croak("Usage: object::role($role_name, @slot_specs)");
role_pv = SvPV(ST(0), role_len);
/* Check if role already exists */
meta = get_role_meta(aTHX_ role_pv, role_len);
if (meta) {
croak("Role '%s' already defined", role_pv);
}
/* Create role meta */
Newxz(meta, 1, RoleMeta);
Newxz(meta->role_name, role_len + 1, char);
Copy(role_pv, meta->role_name, role_len, char);
meta->role_name[role_len] = '\0';
meta->stash = gv_stashpvn(role_pv, role_len, GV_ADD);
/* Allocate slots array */
if (items > 1) {
Newx(meta->slots, items - 1, SlotSpec*);
meta->slot_count = 0;
for (i = 1; i < items; i++) {
STRLEN spec_len;
const char *spec_pv = SvPV(ST(i), spec_len);
SlotSpec *spec = parse_slot_spec(aTHX_ spec_pv, spec_len);
meta->slots[meta->slot_count++] = spec;
}
}
register_role_meta(aTHX_ role_pv, role_len, meta);
XSRETURN_EMPTY;
}
( run in 0.657 second using v1.01-cache-2.11-cpan-13bb782fe5a )