+#define PERL_NO_GET_CONTEXT
+
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
START_MY_CXT
/* Inquire the object registry (a lexical hash) from perl */
-HV* HUF_get_ob_reg(void) {
+HV *
+HUF_get_ob_reg(pTHX) {
dSP;
HV* ob_reg = NULL;
I32 items;
#define HUF_CLONE 0
#define HUF_RESET -1
-void HUF_global(I32 how) {
+void
+HUF_global(pTHX_ I32 how) {
if (how == HUF_INIT) {
MY_CXT_INIT;
- MY_CXT.ob_reg = HUF_get_ob_reg();
+ MY_CXT.ob_reg = HUF_get_ob_reg(aTHX);
} else if (how == HUF_CLONE) {
MY_CXT_CLONE;
- MY_CXT.ob_reg = HUF_get_ob_reg();
+ MY_CXT.ob_reg = HUF_get_ob_reg(aTHX);
} else if (how == HUF_RESET) {
dMY_CXT;
- MY_CXT.ob_reg = HUF_get_ob_reg();
+ MY_CXT.ob_reg = HUF_get_ob_reg(aTHX);
}
}
/* definition of id transformation */
#define HUF_OBJ_ID(x) newSVuv(PTR2UV(x))
-SV* HUF_obj_id(SV* obj) {
+SV *
+HUF_obj_id(pTHX_ SV *obj) {
SV *item = SvRV(obj);
MAGIC *mg;
SV *id;
}
/* set up uvar magic for any sv */
-void HUF_add_uvar_magic(
+void
+HUF_add_uvar_magic(
+ pTHX_
SV* sv, /* the sv to enchant, visible to get/set */
I32(* val)(pTHX_ IV, SV*), /* "get" function */
I32(* set)(pTHX_ IV, SV*), /* "set" function */
}
/* Fetch the data container of a trigger */
-AV* HUF_get_trigger_content(SV* trigger) {
+AV *
+HUF_get_trigger_content(pTHX_ SV *trigger) {
MAGIC* mg;
if (trigger && (mg = mg_find(trigger, PERL_MAGIC_uvar)))
return (AV*)mg->mg_obj;
* the object's entry from the object registry. This function goes in
* the uf_set field of the uvar magic of a trigger.
*/
-I32 HUF_destroy_obj(pTHX_ IV index, SV* trigger) {
+I32 HUF_destroy_obj(pTHX_ IV index, SV *trigger) {
PERL_UNUSED_ARG(index);
/* Do nothing if the weakref wasn't undef'd. Also don't bother
* during global destruction. (MY_CXT.ob_reg is sometimes funny there) */
if (!SvROK(trigger) && (!PL_in_clean_all)) {
dMY_CXT;
- AV* cont = HUF_get_trigger_content(trigger);
+ AV* cont = HUF_get_trigger_content(aTHX_ trigger);
SV* ob_id = *av_fetch(cont, 0, 0);
HV* field_tab = (HV*) *av_fetch(cont, 1, 0);
HE* ent;
}
/* make it safe in case we must run in global clenaup, after all */
if (PL_in_clean_all)
- HUF_global(HUF_RESET); /* shoudn't be needed */
+ HUF_global(aTHX_ HUF_RESET); /* shoudn't be needed */
(void) hv_delete_ent(MY_CXT.ob_reg, ob_id, 0, 0);
}
return 0;
* object may * have to be deleted. The trigger is stored in the
* object registry and is also deleted when the object expires.
*/
-SV* HUF_new_trigger(SV* obj, SV* ob_id) {
+SV *
+HUF_new_trigger(pTHX_ SV *obj, SV *ob_id) {
dMY_CXT;
SV* trigger = sv_rvweaken(newRV_inc(SvRV(obj)));
AV* cont = newAV();
sv_2mortal((SV*)cont);
av_store(cont, 0, SvREFCNT_inc(ob_id));
av_store(cont, 1, (SV*)newHV());
- HUF_add_uvar_magic(trigger, NULL, &HUF_destroy_obj, 0, (SV*)cont);
+ HUF_add_uvar_magic(aTHX_ trigger, NULL, &HUF_destroy_obj, 0, (SV*)cont);
(void) hv_store_ent(MY_CXT.ob_reg, ob_id, trigger, 0);
return trigger;
}
/* retrieve a trigger for obj if one exists, return NULL otherwise */
-SV* HUF_ask_trigger(SV* ob_id) {
+SV *
+HUF_ask_trigger(pTHX_ SV *ob_id) {
dMY_CXT;
HE* ent;
if ((ent = hv_fetch_ent(MY_CXT.ob_reg, ob_id, 0, 0)))
}
/* get the trigger for an object, creating it if necessary */
-SV* HUF_get_trigger0(SV* obj, SV* ob_id) {
+SV *
+HUF_get_trigger0(pTHX_ SV *obj, SV *ob_id) {
SV* trigger;
- if (!(trigger = HUF_ask_trigger(ob_id)))
- trigger = HUF_new_trigger(obj, ob_id);
+ if (!(trigger = HUF_ask_trigger(aTHX_ ob_id)))
+ trigger = HUF_new_trigger(aTHX_ obj, ob_id);
return trigger;
}
-SV* HUF_get_trigger(SV* obj, SV* ob_id) {
- SV* trigger = HUF_ask_trigger(ob_id);
+SV *
+HUF_get_trigger(pTHX_ SV *obj, SV *ob_id) {
+ SV* trigger = HUF_ask_trigger(aTHX_ ob_id);
if (!trigger)
- trigger = HUF_new_trigger(obj, ob_id);
+ trigger = HUF_new_trigger(aTHX_ obj, ob_id);
return( trigger);
}
/* mark an object (trigger) as having been used with a field
(a clenup-liability)
*/
-void HUF_mark_field(SV* trigger, SV* field) {
- AV* cont = HUF_get_trigger_content(trigger);
+void
+HUF_mark_field(pTHX_ SV *trigger, SV *field) {
+ AV* cont = HUF_get_trigger_content(aTHX_ trigger);
HV* field_tab = (HV*) *av_fetch(cont, 1, 0);
SV* field_ref = newRV_inc(field);
UV field_addr = PTR2UV(field);
SV* keysv;
if (mg && (keysv = mg->mg_obj)) {
if (SvROK(keysv)) { /* ref key */
- SV* ob_id = HUF_obj_id(keysv);
+ SV* ob_id = HUF_obj_id(aTHX_ keysv);
mg->mg_obj = ob_id; /* key replacement */
if (HUF_WOULD_CREATE_KEY(action)) {
- SV* trigger = HUF_get_trigger(keysv, ob_id);
- HUF_mark_field(trigger, field);
+ SV* trigger = HUF_get_trigger(aTHX_ keysv, ob_id);
+ HUF_mark_field(aTHX_ trigger, field);
}
} else if (HUF_WOULD_CREATE_KEY(action)) { /* string key */
/* registered as object id? */
SV* trigger;
- if (( trigger = HUF_ask_trigger(keysv)))
- HUF_mark_field( trigger, field);
+ if (( trigger = HUF_ask_trigger(aTHX_ keysv)))
+ HUF_mark_field(aTHX_ trigger, field);
}
} else {
Perl_die(aTHX_ "Rogue call of 'HUF_watch_key_safe'");
PERL_UNUSED_ARG(action);
if (mg && (keysv = mg->mg_obj)) {
if (SvROK(keysv)) /* ref key */
- mg->mg_obj = HUF_obj_id(keysv); /* key replacement */
+ mg->mg_obj = HUF_obj_id(aTHX_ keysv); /* key replacement */
} else {
Perl_die(aTHX_ "Rogue call of 'HUF_watch_key_id'");
}
}
/* see if something is a field hash */
-int HUF_get_status(HV* hash) {
+int
+HUF_get_status(pTHX_ HV *hash) {
int ans = 0;
if (hash && (SvTYPE(hash) == SVt_PVHV)) {
MAGIC* mg;
/* Thread support. These routines are called by CLONE (and nothing else) */
/* Fix entries for one object in all field hashes */
-void HUF_fix_trigger(SV* trigger, SV* new_id) {
- AV* cont = HUF_get_trigger_content(trigger);
+void
+HUF_fix_trigger(pTHX_ SV *trigger, SV *new_id) {
+ AV* cont = HUF_get_trigger_content(aTHX_ trigger);
HV* field_tab = (HV*) *av_fetch(cont, 1, 0);
HV* new_tab = newHV();
HE* ent;
/* Go over object registry and fix all objects. Also fix the object
* registry.
*/
-void HUF_fix_objects(void) {
+void
+HUF_fix_objects(pTHX) {
dMY_CXT;
I32 i, len;
HE* ent;
}
}
- HUF_fix_trigger(trigger, new_id);
+ HUF_fix_trigger(aTHX_ trigger, new_id);
(void) hv_store_ent(MY_CXT.ob_reg, new_id, SvREFCNT_inc(trigger), 0);
}
}
BOOT:
{
- HUF_global(HUF_INIT); /* create variables */
+ HUF_global(aTHX_ HUF_INIT); /* create variables */
}
int
) {
HUF_add_uvar_magic(
+ aTHX_
SvRV(href),
- HUF_mode_2func( mode),
+ HUF_mode_2func(mode),
NULL,
0,
NULL
);
- RETVAL = HUF_get_status(field);
+ RETVAL = HUF_get_status(aTHX_ field);
}
OUTPUT:
RETVAL
PROTOTYPE: $
PPCODE:
if (SvROK(ref)) {
- XPUSHs(HUF_obj_id(ref));
+ XPUSHs(HUF_obj_id(aTHX_ ref));
} else {
XPUSHs(ref);
}
id_2obj(SV* id)
PROTOTYPE: $
CODE:
- SV* obj = HUF_ask_trigger(id);
+ SV* obj = HUF_ask_trigger(aTHX_ id);
if (obj) {
RETVAL = newRV_inc(SvRV(obj));
} else {
} else {
RETVAL = newRV_inc(SvRV(obj));
}
- trigger = HUF_get_trigger(obj, HUF_obj_id(obj));
+ trigger = HUF_get_trigger(aTHX_ obj, HUF_obj_id(aTHX_ obj));
for (i = 1; i < items; ++ i) {
SV* field_ref = POPs;
if (SvROK(field_ref) && (SvTYPE(SvRV(field_ref)) == SVt_PVHV)) {
- HUF_mark_field(trigger, SvRV(field_ref));
+ HUF_mark_field(aTHX_ trigger, SvRV(field_ref));
}
}
OUTPUT:
CLONE(char* classname)
CODE:
if (0 == strcmp(classname, "Hash::Util::FieldHash")) {
- HUF_global(HUF_CLONE);
- HUF_fix_objects();
+ HUF_global(aTHX_ HUF_CLONE);
+ HUF_fix_objects(aTHX);
}
void
_active_fields(SV* obj)
PPCODE:
if (SvROK(obj)) {
- SV* ob_id = HUF_obj_id(obj);
- SV* trigger = HUF_ask_trigger(ob_id);
+ SV* ob_id = HUF_obj_id(aTHX_ obj);
+ SV* trigger = HUF_ask_trigger(aTHX_ ob_id);
if (trigger) {
- AV* cont = HUF_get_trigger_content(trigger);
+ AV* cont = HUF_get_trigger_content(aTHX_ trigger);
HV* field_tab = (HV*) *av_fetch(cont, 1, 0);
HE* ent;
hv_iterinit(field_tab);
counter = SvRV(countref);
sv_setiv(counter, 0);
HUF_add_uvar_magic(
+ aTHX_
SvRV(svref),
ix & 1 ? &HUF_inc_var : 0,
ix & 2 ? &HUF_inc_var : 0,
projects / platform / upstream / perl.git / commitdiff