1 #define PERL_NO_GET_CONTEXT
2
3 #include "EXTERN.h"
4 #include "perl.h"
5 #include "XSUB.h"
6
7 /* support for Hash::Util::FieldHash, prefix HUF_ */
8
9 /* A Perl sub that returns a hashref to the object registry */
10 #define HUF_OB_REG "Hash::Util::FieldHash::_ob_reg"
11 /* Identifier for PERL_MAGIC_ext magic */
12 #define HUF_IDCACHE 0x4944
13
14 /* For global cache of object registry */
15 #define MY_CXT_KEY "Hash::Util::FieldHash::_guts" XS_VERSION
16 typedef struct {
17 HV* ob_reg; /* Cache object registry */
18 } my_cxt_t;
19 START_MY_CXT
20
21 /* Inquire the object registry (a lexical hash) from perl */
22 static HV *
HUF_get_ob_reg(pTHX)23 HUF_get_ob_reg(pTHX) {
24 dSP;
25 HV* ob_reg = NULL;
26 I32 items;
27 ENTER;
28 SAVETMPS;
29
30 PUSHMARK(SP);
31 items = call_pv(HUF_OB_REG, G_SCALAR|G_NOARGS);
32 SPAGAIN;
33
34 if (items == 1 && TOPs && SvROK(TOPs) && SvTYPE(SvRV(TOPs)) == SVt_PVHV)
35 ob_reg = (HV*)SvRV(POPs);
36 PUTBACK;
37 FREETMPS;
38 LEAVE;
39
40 if (!ob_reg)
41 Perl_die(aTHX_ "Can't get object registry hash");
42 return ob_reg;
43 }
44
45 /* Deal with global context */
46 #define HUF_INIT 1
47 #define HUF_CLONE 0
48 #define HUF_RESET -1
49
50 static void
HUF_global(pTHX_ I32 how)51 HUF_global(pTHX_ I32 how) {
52 if (how == HUF_INIT) {
53 MY_CXT_INIT;
54 MY_CXT.ob_reg = HUF_get_ob_reg(aTHX);
55 } else if (how == HUF_CLONE) {
56 MY_CXT_CLONE;
57 MY_CXT.ob_reg = HUF_get_ob_reg(aTHX);
58 } else if (how == HUF_RESET) {
59 dMY_CXT;
60 MY_CXT.ob_reg = HUF_get_ob_reg(aTHX);
61 }
62 }
63
64 /* Object id */
65
66 /* definition of id transformation */
67 #define HUF_OBJ_ID(x) newSVuv(PTR2UV(x))
68
69 static SV *
HUF_obj_id(pTHX_ SV * obj)70 HUF_obj_id(pTHX_ SV *obj) {
71 SV *item = SvRV(obj);
72 MAGIC *mg;
73 SV *id;
74
75 /* Get cached object ID, if it exists */
76 if (SvTYPE(item) >= SVt_PVMG) {
77 for ( mg = SvMAGIC(item); mg; mg = mg->mg_moremagic ) {
78 if ((mg->mg_type == PERL_MAGIC_ext) &&
79 (mg->mg_private == HUF_IDCACHE)
80 ) {
81 return mg->mg_obj;
82 }
83 }
84 }
85
86 /* Create an object ID, cache it */
87 id = HUF_OBJ_ID(item);
88 mg = sv_magicext(item, id, PERL_MAGIC_ext, NULL, NULL, 0);
89 mg->mg_private = HUF_IDCACHE;
90 SvREFCNT_dec(id); /* refcnt++ in sv_magicext() */
91
92 /* Return the object ID */
93 return id;
94 }
95
96 /* set up uvar magic for any sv */
97 static void
HUF_add_uvar_magic(pTHX_ SV * sv,I32 (* val)(pTHX_ IV,SV *),I32 (* set)(pTHX_ IV,SV *),I32 index,SV * thing)98 HUF_add_uvar_magic(
99 pTHX_
100 SV* sv, /* the sv to enchant, visible to get/set */
101 I32(* val)(pTHX_ IV, SV*), /* "get" function */
102 I32(* set)(pTHX_ IV, SV*), /* "set" function */
103 I32 index, /* get/set will see this */
104 SV* thing /* any associated info */
105 ) {
106 struct ufuncs uf;
107 uf.uf_val = val;
108 uf.uf_set = set;
109 uf.uf_index = index;
110 sv_magic(sv, thing, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
111 }
112
113 /* Fetch the data container of a trigger */
114 static AV *
HUF_get_trigger_content(pTHX_ SV * trigger)115 HUF_get_trigger_content(pTHX_ SV *trigger) {
116 MAGIC* mg;
117 if (trigger && (mg = mg_find(trigger, PERL_MAGIC_uvar)))
118 return (AV*)mg->mg_obj;
119 return NULL;
120 }
121
122 /* Delete an object from all field hashes it may occur in. Also delete
123 * the object's entry from the object registry. This function goes in
124 * the uf_set field of the uvar magic of a trigger.
125 */
HUF_destroy_obj(pTHX_ IV index,SV * trigger)126 static I32 HUF_destroy_obj(pTHX_ IV index, SV *trigger) {
127 PERL_UNUSED_ARG(index);
128 /* Do nothing if the weakref wasn't undef'd. Also don't bother
129 * during global destruction. (MY_CXT.ob_reg is sometimes funny there) */
130 if (!SvROK(trigger) && (!PL_in_clean_all)) {
131 dMY_CXT;
132 AV* cont = HUF_get_trigger_content(aTHX_ trigger);
133 SV* ob_id = *av_fetch(cont, 0, 0);
134 HV* field_tab = (HV*) *av_fetch(cont, 1, 0);
135 HE* ent;
136 hv_iterinit(field_tab);
137 while ((ent = hv_iternext(field_tab))) {
138 SV* field_ref = HeVAL(ent);
139 SV* field = SvRV(field_ref);
140 (void) hv_delete_ent((HV*)field, ob_id, 0, 0);
141 }
142 /* make it safe in case we must run in global clenaup, after all */
143 if (PL_in_clean_all)
144 HUF_global(aTHX_ HUF_RESET); /* shoudn't be needed */
145 (void) hv_delete_ent(MY_CXT.ob_reg, ob_id, 0, 0);
146 }
147 return 0;
148 }
149
150 /* Create a trigger for an object. The trigger is a magical SV
151 * that holds a weak ref to the object. The magic fires when the object
152 * expires and takes care of garbage collection in registred hashes.
153 * For that purpose, the magic structure holds the original id of
154 * the object, and a list (a hash, really) of hashes from which the
155 * object may * have to be deleted. The trigger is stored in the
156 * object registry and is also deleted when the object expires.
157 */
158 static SV *
HUF_new_trigger(pTHX_ SV * obj,SV * ob_id)159 HUF_new_trigger(pTHX_ SV *obj, SV *ob_id) {
160 dMY_CXT;
161 SV* trigger = sv_rvweaken(newRV_inc(SvRV(obj)));
162 AV* cont = newAV_mortal();
163 av_store_simple(cont, 0, SvREFCNT_inc(ob_id));
164 av_store_simple(cont, 1, (SV*)newHV());
165 HUF_add_uvar_magic(aTHX_ trigger, NULL, &HUF_destroy_obj, 0, (SV*)cont);
166 (void) hv_store_ent(MY_CXT.ob_reg, ob_id, trigger, 0);
167 return trigger;
168 }
169
170 /* retrieve a trigger for obj if one exists, return NULL otherwise */
171 static SV *
HUF_ask_trigger(pTHX_ SV * ob_id)172 HUF_ask_trigger(pTHX_ SV *ob_id) {
173 dMY_CXT;
174 HE* ent;
175 if ((ent = hv_fetch_ent(MY_CXT.ob_reg, ob_id, 0, 0)))
176 return HeVAL(ent);
177 return NULL;
178 }
179
180 static SV *
HUF_get_trigger(pTHX_ SV * obj,SV * ob_id)181 HUF_get_trigger(pTHX_ SV *obj, SV *ob_id) {
182 SV* trigger = HUF_ask_trigger(aTHX_ ob_id);
183 if (!trigger)
184 trigger = HUF_new_trigger(aTHX_ obj, ob_id);
185 return( trigger);
186 }
187
188 /* mark an object (trigger) as having been used with a field
189 (a clenup-liability)
190 */
191 static void
HUF_mark_field(pTHX_ SV * trigger,SV * field)192 HUF_mark_field(pTHX_ SV *trigger, SV *field) {
193 AV* cont = HUF_get_trigger_content(aTHX_ trigger);
194 HV* field_tab = (HV*) *av_fetch(cont, 1, 0);
195 SV* field_ref = newRV_inc(field);
196 UV field_addr = PTR2UV(field);
197 (void) hv_store(field_tab, (char *)&field_addr, sizeof(field_addr), field_ref, 0);
198 }
199
200 /* Determine, from the value of action, whether this call may create a new
201 * hash key */
202 #define HUF_WOULD_CREATE_KEY(x) ((x) != HV_DELETE && ((x) & (HV_FETCH_ISSTORE | HV_FETCH_LVALUE)))
203
204 /* The key exchange functions. They communicate with S_hv_magic_uvar_xkey
205 * in hv.c */
HUF_watch_key_safe(pTHX_ IV action,SV * field)206 static I32 HUF_watch_key_safe(pTHX_ IV action, SV* field) {
207 MAGIC* mg = mg_find(field, PERL_MAGIC_uvar);
208 SV* keysv;
209 if (mg && (keysv = mg->mg_obj)) {
210 if (SvROK(keysv)) { /* ref key */
211 SV* ob_id = HUF_obj_id(aTHX_ keysv);
212 mg->mg_obj = ob_id; /* key replacement */
213 if (HUF_WOULD_CREATE_KEY(action)) {
214 SV* trigger = HUF_get_trigger(aTHX_ keysv, ob_id);
215 HUF_mark_field(aTHX_ trigger, field);
216 }
217 } else if (HUF_WOULD_CREATE_KEY(action)) { /* string key */
218 /* registered as object id? */
219 SV* trigger;
220 if (( trigger = HUF_ask_trigger(aTHX_ keysv)))
221 HUF_mark_field(aTHX_ trigger, field);
222 }
223 } else {
224 Perl_die(aTHX_ "Rogue call of 'HUF_watch_key_safe'");
225 }
226 return 0;
227 }
228
HUF_watch_key_id(pTHX_ IV action,SV * field)229 static I32 HUF_watch_key_id(pTHX_ IV action, SV* field) {
230 MAGIC* mg = mg_find(field, PERL_MAGIC_uvar);
231 SV* keysv;
232 PERL_UNUSED_ARG(action);
233 if (mg && (keysv = mg->mg_obj)) {
234 if (SvROK(keysv)) /* ref key */
235 mg->mg_obj = HUF_obj_id(aTHX_ keysv); /* key replacement */
236 } else {
237 Perl_die(aTHX_ "Rogue call of 'HUF_watch_key_id'");
238 }
239 return 0;
240 }
241
HUF_func_2mode(I32 (* val)(pTHX_ IV,SV *))242 static int HUF_func_2mode( I32(* val)(pTHX_ IV, SV*)) {
243 int ans = 0;
244 if (val == &HUF_watch_key_id)
245 ans = 1;
246 if (val == &HUF_watch_key_safe)
247 ans = 2;
248 return(ans);
249 }
250
HUF_mode_2func(int mode)251 static I32(* HUF_mode_2func( int mode))(pTHX_ IV, SV*) {
252 I32(* ans)(pTHX_ IV, SV*) = NULL;
253 switch (mode) {
254 case 1:
255 ans = &HUF_watch_key_id;
256 break;
257 case 2:
258 ans = &HUF_watch_key_safe;
259 break;
260 }
261 return(ans);
262 }
263
264 /* see if something is a field hash */
265 static int
HUF_get_status(pTHX_ HV * hash)266 HUF_get_status(pTHX_ HV *hash) {
267 int ans = 0;
268 if (hash && (SvTYPE(hash) == SVt_PVHV)) {
269 MAGIC* mg;
270 struct ufuncs* uf;
271 if ((mg = mg_find((SV*)hash, PERL_MAGIC_uvar)) &&
272 (uf = (struct ufuncs *)mg->mg_ptr) &&
273 (uf->uf_set == NULL)
274 ) {
275 ans = HUF_func_2mode(uf->uf_val);
276 }
277 }
278 return ans;
279 }
280
281 /* Thread support. These routines are called by CLONE (and nothing else) */
282
283 /* Fix entries for one object in all field hashes */
284 static void
HUF_fix_trigger(pTHX_ SV * trigger,SV * new_id)285 HUF_fix_trigger(pTHX_ SV *trigger, SV *new_id) {
286 AV* cont = HUF_get_trigger_content(aTHX_ trigger);
287 HV* field_tab = (HV*) *av_fetch(cont, 1, 0);
288 HV* new_tab = newHV();
289 HE* ent;
290 SV* old_id = *av_fetch(cont, 0, 0);
291 I32 entries = hv_iterinit(field_tab);
292 hv_ksplit(new_tab, entries);
293 while ((ent = hv_iternext(field_tab))) {
294 SV* field_ref = HeVAL(ent);
295 HV* field = (HV*)SvRV(field_ref);
296 UV field_addr = PTR2UV(field);
297 SV* val;
298 /* recreate field tab entry */
299 (void) hv_store(new_tab, (char *)&field_addr, sizeof(field_addr), SvREFCNT_inc(field_ref), 0);
300 /* recreate field entry, if any */
301 if ((val = hv_delete_ent(field, old_id, 0, 0)))
302 (void) hv_store_ent(field, new_id, SvREFCNT_inc(val), 0);
303 }
304 /* update the trigger */
305 av_store(cont, 0, SvREFCNT_inc(new_id));
306 av_store(cont, 1, (SV*)new_tab);
307 }
308
309 /* Go over object registry and fix all objects. Also fix the object
310 * registry.
311 */
312 static void
HUF_fix_objects(pTHX)313 HUF_fix_objects(pTHX) {
314 dMY_CXT;
315 I32 i, len;
316 HE* ent;
317 AV* oblist = newAV_mortal();
318 hv_iterinit(MY_CXT.ob_reg);
319 while((ent = hv_iternext(MY_CXT.ob_reg)))
320 av_push_simple(oblist, SvREFCNT_inc(hv_iterkeysv(ent)));
321 len = av_count(oblist);
322 for (i = 0; i < len; ++i) {
323 SV* old_id = *av_fetch_simple(oblist, i, 0);
324 SV* trigger = hv_delete_ent(MY_CXT.ob_reg, old_id, 0, 0);
325 SV* obj = SvRV(trigger);
326 MAGIC *mg;
327
328 SV* new_id = HUF_OBJ_ID(obj);
329
330 /* Replace cached object ID with this new one */
331 for (mg = SvMAGIC(obj); mg; mg = mg->mg_moremagic) {
332 if ((mg->mg_type == PERL_MAGIC_ext) &&
333 (mg->mg_private == HUF_IDCACHE)
334 ) {
335 mg->mg_obj = new_id;
336 }
337 }
338
339 HUF_fix_trigger(aTHX_ trigger, new_id);
340 (void) hv_store_ent(MY_CXT.ob_reg, new_id, SvREFCNT_inc(trigger), 0);
341 }
342 }
343
344 /* test support (not needed for functionality) */
345
346 static SV* counter;
HUF_inc_var(pTHX_ IV index,SV * which)347 I32 HUF_inc_var(pTHX_ IV index, SV* which) {
348 PERL_UNUSED_ARG(index);
349 PERL_UNUSED_ARG(which);
350 sv_setiv(counter, 1 + SvIV(counter));
351 return 0;
352 }
353
354 MODULE = Hash::Util::FieldHash PACKAGE = Hash::Util::FieldHash
355
356 BOOT:
357 {
358 HUF_global(aTHX_ HUF_INIT); /* create variables */
359 }
360
361 int
362 _fieldhash(SV* href, int mode)
363 PROTOTYPE: $$
364 CODE:
365 HV* field;
366 RETVAL = 0;
367 if (mode &&
368 href && SvROK(href) &&
369 (field = (HV*)SvRV(href)) &&
370 SvTYPE(field) == SVt_PVHV
371 ) {
372
373 HUF_add_uvar_magic(
374 aTHX_
375 SvRV(href),
376 HUF_mode_2func(mode),
377 NULL,
378 0,
379 NULL
380 );
381 RETVAL = HUF_get_status(aTHX_ field);
382 }
383 OUTPUT:
384 RETVAL
385
386 void
387 id(SV* ref)
388 PROTOTYPE: $
389 PPCODE:
390 if (SvROK(ref)) {
391 XPUSHs(HUF_obj_id(aTHX_ ref));
392 } else {
393 XPUSHs(ref);
394 }
395
396 SV*
397 id_2obj(SV* id)
398 PROTOTYPE: $
399 CODE:
400 SV* obj = HUF_ask_trigger(aTHX_ id);
401 if (obj) {
402 RETVAL = newRV_inc(SvRV(obj));
403 } else {
404 RETVAL = &PL_sv_undef;
405 }
406 OUTPUT:
407 RETVAL
408
409 SV*
410 register(SV* obj, ...)
411 PROTOTYPE: $@
412 CODE:
413 SV* trigger;
414 int i;
415 RETVAL = NULL;
416 if (!SvROK(obj)) {
417 Perl_die(aTHX_ "Attempt to register a non-ref");
418 } else {
419 RETVAL = newRV_inc(SvRV(obj));
420 }
421 trigger = HUF_get_trigger(aTHX_ obj, HUF_obj_id(aTHX_ obj));
422 for (i = 1; i < items; ++ i) {
423 SV* field_ref = POPs;
424 if (SvROK(field_ref) && (SvTYPE(SvRV(field_ref)) == SVt_PVHV)) {
425 HUF_mark_field(aTHX_ trigger, SvRV(field_ref));
426 }
427 }
428 OUTPUT:
429 RETVAL
430
431 void
432 CLONE(char* classname)
433 CODE:
434 if (strEQ(classname, "Hash::Util::FieldHash")) {
435 HUF_global(aTHX_ HUF_CLONE);
436 HUF_fix_objects(aTHX);
437 }
438
439 void
440 _active_fields(SV* obj)
441 PPCODE:
442 if (SvROK(obj)) {
443 SV* ob_id = HUF_obj_id(aTHX_ obj);
444 SV* trigger = HUF_ask_trigger(aTHX_ ob_id);
445 if (trigger) {
446 AV* cont = HUF_get_trigger_content(aTHX_ trigger);
447 HV* field_tab = (HV*) *av_fetch(cont, 1, 0);
448 HE* ent;
449 hv_iterinit(field_tab);
450 while ((ent = hv_iternext(field_tab))) {
451 HV* field = (HV*)SvRV(HeVAL(ent));
452 if (hv_exists_ent(field, ob_id, 0))
453 XPUSHs(sv_2mortal(newRV_inc((SV*)field)));
454 }
455 }
456 }
457
458 void
459 _test_uvar_get(SV* svref, SV* countref)
460 ALIAS:
461 _test_uvar_get = 1
462 _test_uvar_set = 2
463 _test_uvar_same = 3
464 CODE:
465 if (SvROK(svref) && SvROK(countref)) {
466 counter = SvRV(countref);
467 sv_setiv(counter, 0);
468 HUF_add_uvar_magic(
469 aTHX_
470 SvRV(svref),
471 ix & 1 ? &HUF_inc_var : 0,
472 ix & 2 ? &HUF_inc_var : 0,
473 0,
474 SvRV(countref)
475 );
476 }
477