static SV *eca_new_sv(char *name, ECAtype type, SV *value, SV *check,
bool is_ro, SV *inject) {
dTHX;
ECAslot *slot = eca_init(name, type, value, check, is_ro, inject);
SV *result_sv = newSVuv(PTR2UV(slot));
MAGIC *mg =
sv_magicext(result_sv, result_sv, PERL_MAGIC_ext, &ECA_TBL, NULL, 0);
mg->mg_flags |= MGf_DUP; // to invoke attrs_dup
return result_sv;
}
void p5_add_magic(PerlInterpreter *my_perl, SV *obj, IV i) {
PERL_SET_CONTEXT(my_perl);
{
SV * const inst = SvRV(obj);
_perl6_magic priv;
/* set up magic */
priv.key = PERL6_MAGIC_KEY;
priv.index = i;
sv_magicext(inst, inst, PERL_MAGIC_ext, &p5_inline_mg_vtbl, (char *) &priv, sizeof(priv));
}
}
void
blizkost_bind_pmc_to_sv(BLIZKOST_NEXUS, SV *sv, PMC *target) {
dBNPERL; dBNINTERP;
MAGIC *mg;
mg = sv_magicext(sv, 0, PERL_MAGIC_ext, &blizkost_binder_vtbl, 0, 0);
mg->mg_ptr = (char*)nexus;
mg->mg_obj = (SV*) target;
Parrot_pmc_gc_register(interp, target);
}
void p5_rebless_object(PerlInterpreter *my_perl, SV *obj, char *package, IV i) {
PERL_SET_CONTEXT(my_perl);
{
SV * const inst = SvRV(obj);
HV *stash = gv_stashpv(package, GV_ADD);
if (stash == NULL)
croak("Perl6::Object not found!? Forgot to call init_callbacks?");
(void)sv_bless(obj, stash);
_perl6_magic priv;
/* set up magic */
priv.key = PERL6_MAGIC_KEY;
priv.index = i;
sv_magicext(inst, inst, PERL_MAGIC_ext, &p5_inline_mg_vtbl, (char *) &priv, sizeof(priv));
}
}
SV *
ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
{
SV *sv;
MAGIC *mg;
if (inc) {
MUTEX_LOCK(&thread->mutex);
thread->count++;
MUTEX_UNLOCK(&thread->mutex);
}
if (!obj)
obj = newSV(0);
sv = newSVrv(obj,classname);
sv_setiv(sv,PTR2IV(thread));
mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
mg->mg_flags |= MGf_DUP;
SvREADONLY_on(sv);
return obj;
}
SV *p5_wrap_p6_hash(
PerlInterpreter *my_perl,
IV i
) {
PERL_SET_CONTEXT(my_perl);
{
int flags = G_SCALAR;
dSP;
SV * inst;
SV * inst_ptr;
inst_ptr = newSViv(0); // will be upgraded to an RV
inst = newSVrv(inst_ptr, "Perl6::Object");
_perl6_hash_magic priv;
/* set up magic */
priv.key = PERL6_HASH_MAGIC_KEY;
priv.index = i;
sv_magicext(inst, inst, PERL_MAGIC_ext, &p5_inline_hash_mg_vtbl, (char *) &priv, sizeof(priv));
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(newSVpv("Perl6::Hash", 0));
XPUSHs(inst_ptr);
PUTBACK;
call_method("new", flags);
SPAGAIN;
SV *tied_handle = POPs;
SvREFCNT_inc(tied_handle);
PUTBACK;
FREETMPS;
LEAVE;
return tied_handle;
}
}
SV *p5_wrap_p6_object(PerlInterpreter *my_perl, IV i, SV *p5obj) {
PERL_SET_CONTEXT(my_perl);
{
SV * inst;
SV * inst_ptr;
if (p5obj == NULL) {
inst_ptr = newSViv(0); // will be upgraded to an RV
inst = newSVrv(inst_ptr, "Perl6::Object");
}
else {
inst_ptr = p5obj;
inst = SvRV(inst_ptr);
}
_perl6_magic priv;
/* set up magic */
priv.key = p5obj == NULL ? PERL6_MAGIC_KEY : PERL6_EXTENSION_MAGIC_KEY;
priv.index = i;
sv_magicext(inst, inst, PERL_MAGIC_ext, &p5_inline_mg_vtbl, (char *) &priv, sizeof(priv));
return inst_ptr;
}
}
SV *p5_wrap_p6_object(PerlInterpreter *my_perl, IV i, SV *p5obj, SV *(*call_p6_method)(IV, char * , SV *, SV **), void (*free_p6_object)(IV)) {
SV * inst;
SV * inst_ptr;
if (p5obj == NULL) {
inst_ptr = newSViv(0);
inst = newSVrv(inst_ptr, "Perl6::Object");
}
else {
inst_ptr = p5obj;
inst = SvRV(inst_ptr);
SvREFCNT_inc(inst_ptr);
}
_perl6_magic priv;
/* set up magic */
priv.key = PERL6_MAGIC_KEY;
priv.index = i;
priv.call_p6_method = call_p6_method;
priv.free_p6_object = free_p6_object;
sv_magicext(inst, inst, PERL_MAGIC_ext, &p5_inline_mg_vtbl, (char *) &priv, sizeof(priv));
return inst_ptr;
}
HR_INLINE MAGIC*
get_our_magic(SV* objref, int create)
{
MAGIC *mg;
HR_Action *action_list;
SV *target;
if(!SvROK(objref)) {
die("Value=%p must be a reference type", objref);
}
target = SvRV(objref);
objref = NULL; /*Don't use this anymore*/
if(SvTYPE(target) < SVt_PVMG) {
HR_DEBUG("Object=%p is not yet magical!", target);
if(create) {
goto GT_NEW_MAGIC;
} else {
HR_DEBUG("No magic found, but creation not requested");
return NULL;
}
}
HR_DEBUG("Will try to locate existing magic");
mg = mg_find(target, PERL_MAGIC_ext);
if(mg) {
HR_DEBUG("Found initial mg=%p", mg);
} else {
HR_DEBUG("Can't find existing magic!");
}
for(; mg; mg = mg->mg_moremagic) {
HR_DEBUG("Checking mg=%p", mg);
if(mg->mg_virtual == &vtbl) {
return mg;
}
}
if(!create) {
return NULL;
}
GT_NEW_MAGIC:
HR_DEBUG("Creating new magic for %p", target);
Newxz_Action(action_list);
mg = sv_magicext(target, target, PERL_MAGIC_ext, &vtbl,
(const char*)action_list, 0);
mg->mg_flags |= MGf_DUP;
OURMAGIC_infree(mg) = 0;
if(!mg) {
die("Couldn't create magic!");
} else {
HR_DEBUG("Created mg=%p, alist=%p", mg, action_list);
}
return mg;
}
