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; }